maintainers/scripts/nix-generate-from-cpan.pl

   1 #!/usr/bin/env perl
   2
   3 use utf8;
   4 use strict;
   5 use warnings;
   6
   7 use CPAN::Meta();
   8 use CPANPLUS::Backend();
   9 use Module::CoreList;
  10 use Getopt::Long::Descriptive qw( describe_options );
  11 use JSON::PP qw( encode_json );
  12 use Log::Log4perl qw(:easy);
  13 use Readonly();
  14
  15 # Readonly hash that maps CPAN style license strings to information
  16 # necessary to generate a Nixpkgs style license attribute.
  17 Readonly::Hash my %LICENSE_MAP => (
  18
  19     # The Perl 5 License (Artistic 1 & GPL 1 or later).
  20     perl_5 => {
  21         licenses => [qw( artistic1 gpl1Plus )]
  22     },
  23
  24     # GNU Affero General Public License, Version 3.
  25     agpl_3 => {
  26         licenses => [qw( agpl3Plus )],
  27         amb      => 1
  28     },
  29
  30     # Apache Software License, Version 1.1.
  31     apache_1_1 => {
  32         licenses => ["Apache License 1.1"],
  33         in_set   => 0
  34     },
  35
  36     # Apache License, Version 2.0.
  37     apache_2_0 => {
  38         licenses => [qw( asl20 )]
  39     },
  40
  41     # Artistic License, (Version 1).
  42     artistic_1 => {
  43         licenses => [qw( artistic1 )]
  44     },
  45
  46     # Artistic License, Version 2.0.
  47     artistic_2 => {
  48         licenses => [qw( artistic2 )]
  49     },
  50
  51     # BSD License (three-clause).
  52     bsd => {
  53         licenses => [qw( bsd3 )],
  54         amb      => 1
  55     },
  56
  57     # FreeBSD License (two-clause).
  58     freebsd => {
  59         licenses => [qw( bsd2 )]
  60     },
  61
  62     # GNU Free Documentation License, Version 1.2.
  63     gfdl_1_2 => {
  64         licenses => [qw( fdl12Plus )]
  65     },
  66
  67     # GNU Free Documentation License, Version 1.3.
  68     gfdl_1_3 => {
  69         licenses => [qw( fdl13Plus )]
  70     },
  71
  72     # GNU General Public License, Version 1.
  73     gpl_1 => {
  74         licenses => [qw( gpl1Plus )],
  75         amb      => 1
  76     },
  77
  78     # GNU General Public License, Version 2. Note, we will interpret
  79     # "gpl" alone as GPL v2+.
  80     gpl_2 => {
  81         licenses => [qw( gpl2Plus )],
  82         amb      => 1
  83     },
  84
  85     # GNU General Public License, Version 3.
  86     gpl_3 => {
  87         licenses => [qw( gpl3Plus )],
  88         amb      => 1
  89     },
  90
  91     # GNU Lesser General Public License, Version 2.1. Note, we will
  92     # interpret "gpl" alone as LGPL v2.1+.
  93     lgpl_2_1 => {
  94         licenses => [qw( lgpl21Plus )],
  95         amb      => 1
  96     },
  97
  98     # GNU Lesser General Public License, Version 3.0.
  99     lgpl_3_0 => {
 100         licenses => [qw( lgpl3Plus )],
 101         amb      => 1
 102     },
 103
 104     # MIT (aka X11) License.
 105     mit => {
 106         licenses => [qw( mit )]
 107     },
 108
 109     # Mozilla Public License, Version 1.0.
 110     mozilla_1_0 => {
 111         licenses => [qw( mpl10 )]
 112     },
 113
 114     # Mozilla Public License, Version 1.1.
 115     mozilla_1_1 => {
 116         licenses => [qw( mpl11 )]
 117     },
 118
 119     # OpenSSL License.
 120     openssl => {
 121         licenses => [qw( openssl )]
 122     },
 123
 124     # Q Public License, Version 1.0.
 125     qpl_1_0 => {
 126         licenses => [qw( qpl )]
 127     },
 128
 129     # Original SSLeay License.
 130     ssleay => {
 131         licenses => ["Original SSLeay License"],
 132         in_set   => 0
 133     },
 134
 135     # Sun Internet Standards Source License (SISSL).
 136     sun => {
 137         licenses => ["Sun Industry Standards Source License v1.1"],
 138         in_set   => 0
 139     },
 140
 141     # zlib License.
 142     zlib => {
 143         licenses => [qw( zlib )]
 144     },
 145
 146     # Other Open Source Initiative (OSI) approved license.
 147     open_source => {
 148         licenses => [qw( free )],
 149         amb      => 1
 150     },
 151
 152     # Requires special permission from copyright holder.
 153     restricted => {
 154         licenses => [qw( unfree )],
 155         amb      => 1
 156     },
 157
 158     # Not an OSI approved license, but not restricted. Note, we
 159     # currently map this to unfreeRedistributable, which is a
 160     # conservative choice.
 161     unrestricted => {
 162         licenses => [qw( unfreeRedistributable )],
 163         amb      => 1
 164     },
 165
 166     # License not provided in metadata.
 167     unknown => {
 168         licenses => [],
 169         amb      => 1
 170     }
 171 );
 172
 173 sub handle_opts {
 174     my ( $opt, $usage ) = describe_options(
 175         'usage: $0 %o MODULE',
 176         [ 'maintainer|m=s', 'the package maintainer' ],
 177         [ 'debug|d',        'enable debug output' ],
 178         [ 'help',           'print usage message and exit' ]
 179     );
 180
 181     if ( $opt->help ) {
 182         print $usage->text;
 183         exit;
 184     }
 185
 186     my $module_name = $ARGV[0];
 187
 188     if ( !defined $module_name ) {
 189         print STDERR "Missing module name\n";
 190         print STDERR $usage->text;
 191         exit 1;
 192     }
 193
 194     return ( $opt, $module_name );
 195 }
 196
 197 # Takes a Perl package attribute name and returns 1 if the name cannot
 198 # be referred to as a bareword. This typically happens if the package
 199 # name is a reserved Nix keyword.
 200 sub is_reserved {
 201     my ($pkg) = @_;
 202
 203     return $pkg =~ /^(?: assert    |
 204                          else      |
 205                          if        |
 206                          import    |
 207                          in        |
 208                          inherit   |
 209                          let       |
 210                          rec       |
 211                          then      |
 212                          while     |
 213                          with      )$/x;
 214 }
 215
 216 sub pkg_to_attr {
 217     my ($module) = @_;
 218     my $attr_name = $module->package_name;
 219     if ( $attr_name eq "libwww-perl" ) {
 220         return "LWP";
 221     }
 222     else {
 223         $attr_name =~ s/-//g;
 224         return $attr_name;
 225     }
 226 }
 227
 228 sub get_pkg_name {
 229     my ($module) = @_;
 230     return ( $module->package_name, $module->package_version =~ s/^v(\d)/$1/r );
 231 }
 232
 233 sub read_meta {
 234     my ($pkg_path) = @_;
 235
 236     my $yaml_path = "$pkg_path/META.yml";
 237     my $json_path = "$pkg_path/META.json";
 238     my $meta;
 239
 240     if ( -r $json_path ) {
 241         $meta = CPAN::Meta->load_file($json_path);
 242     }
 243     elsif ( -r $yaml_path ) {
 244         $meta = CPAN::Meta->load_file($yaml_path);
 245     }
 246     else {
 247         WARN("package has no META.yml or META.json");
 248     }
 249
 250     return $meta;
 251 }
 252
 253 # Map a module to the attribute corresponding to its package
 254 # (e.g. HTML::HeadParser will be mapped to HTMLParser, because that
 255 # module is in the HTML-Parser package).
 256 sub module_to_pkg {
 257     my ( $cb, $module_name ) = @_;
 258     my @modules = $cb->search( type => "name", allow => [$module_name] );
 259     if ( scalar @modules == 0 ) {
 260
 261         # Fallback.
 262         $module_name =~ s/:://g;
 263         return $module_name;
 264     }
 265     my $module    = $modules[0];
 266     my $attr_name = pkg_to_attr($module);
 267     DEBUG("mapped dep $module_name to $attr_name");
 268     return $attr_name;
 269 }
 270
 271 sub get_deps {
 272     my ( $cb, $meta, $type ) = @_;
 273
 274     return if !defined $meta;
 275
 276     my $prereqs = $meta->effective_prereqs;
 277     my $deps = $prereqs->requirements_for( $type, "requires" );
 278     my @res;
 279     foreach my $n ( $deps->required_modules ) {
 280         next if $n eq "perl";
 281
 282         my @core = Module::CoreList->find_modules(qr/^$n$/);
 283         next if (@core);
 284
 285         my $pkg = module_to_pkg( $cb, $n );
 286
 287         # If the package name is reserved then we need to refer to it
 288         # through the "self" variable.
 289         $pkg = "self.\"$pkg\"" if is_reserved($pkg);
 290
 291         push @res, $pkg;
 292     }
 293     return @res;
 294 }
 295
 296 sub uniq {
 297     return keys %{ { map { $_ => 1 } @_ } };
 298 }
 299
 300 sub render_license {
 301     my ($cpan_license) = @_;
 302
 303     return if !defined $cpan_license;
 304
 305     my $licenses;
 306
 307     # If the license is ambiguous then we'll print an extra warning.
 308     # For example, "gpl_2" is ambiguous since it may refer to exactly
 309     # "GPL v2" or to "GPL v2 or later".
 310     my $amb = 0;
 311
 312     # Whether the license is available inside `lib.licenses`.
 313     my $in_set = 1;
 314
 315     my $nix_license = $LICENSE_MAP{$cpan_license};
 316     if ( !$nix_license ) {
 317         WARN("Unknown license: $cpan_license");
 318         $licenses = [$cpan_license];
 319         $in_set   = 0;
 320     }
 321     else {
 322         $licenses = $nix_license->{licenses};
 323         $amb      = $nix_license->{amb};
 324         $in_set   = !$nix_license->{in_set};
 325     }
 326
 327     my $license_line;
 328
 329     if ( @$licenses == 0 ) {
 330
 331         # Avoid defining the license line.
 332     }
 333     elsif ($in_set) {
 334         my $lic = 'lib.licenses';
 335         if ( @$licenses == 1 ) {
 336             $license_line = "$lic.$licenses->[0]";
 337         }
 338         else {
 339             $license_line = "with $lic; [ " . join( ' ', @$licenses ) . " ]";
 340         }
 341     }
 342     else {
 343         if ( @$licenses == 1 ) {
 344             $license_line = $licenses->[0];
 345         }
 346         else {
 347             $license_line = '[ ' . join( ' ', @$licenses ) . ' ]';
 348         }
 349     }
 350
 351     INFO("license: $cpan_license");
 352     WARN("License '$cpan_license' is ambiguous, please verify") if $amb;
 353
 354     return $license_line;
 355 }
 356
 357 my ( $opt, $module_name ) = handle_opts();
 358
 359 Log::Log4perl->easy_init(
 360     {
 361         level => $opt->debug ? $DEBUG : $INFO,
 362         layout => '%m%n'
 363     }
 364 );
 365
 366 my $cb = CPANPLUS::Backend->new;
 367
 368 my @modules = $cb->search( type => "name", allow => [$module_name] );
 369 die "module $module_name not found\n" if scalar @modules == 0;
 370 die "multiple packages that match module $module_name\n" if scalar @modules > 1;
 371 my $module = $modules[0];
 372
 373 my ($pkg_name, $pkg_version) = get_pkg_name $module;
 374 my $attr_name = pkg_to_attr $module;
 375
 376 INFO( "attribute name: ", $attr_name );
 377 INFO( "module: ",         $module->module );
 378 INFO( "version: ",        $module->version );
 379 INFO( "package: ", $module->package, " (", "$pkg_name-$pkg_version", ", ", $attr_name, ")" );
 380 INFO( "path: ",    $module->path );
 381
 382 my $tar_path = $module->fetch();
 383 INFO( "downloaded to: ", $tar_path );
 384 INFO( "sha-256: ",       $module->status->checksum_value );
 385
 386 my $pkg_path = $module->extract();
 387 INFO( "unpacked to: ", $pkg_path );
 388
 389 my $meta = read_meta($pkg_path);
 390
 391 DEBUG( "metadata: ", encode_json( $meta->as_struct ) ) if defined $meta;
 392
 393 my @runtime_deps = sort( uniq( get_deps( $cb, $meta, "runtime" ) ) );
 394 INFO("runtime deps: @runtime_deps");
 395
 396 my @build_deps = sort( uniq(
 397         get_deps( $cb, $meta, "configure" ),
 398         get_deps( $cb, $meta, "build" ),
 399         get_deps( $cb, $meta, "test" )
 400 ) );
 401
 402 # Filter out runtime dependencies since those are already handled.
 403 my %in_runtime_deps = map { $_ => 1 } @runtime_deps;
 404 @build_deps = grep { not $in_runtime_deps{$_} } @build_deps;
 405
 406 INFO("build deps: @build_deps");
 407
 408 my $homepage = $meta ? $meta->resources->{homepage} : undef;
 409 INFO("homepage: $homepage") if defined $homepage;
 410
 411 my $description = $meta ? $meta->abstract : undef;
 412 if ( defined $description ) {
 413     $description = uc( substr( $description, 0, 1 ) )
 414       . substr( $description, 1 );    # capitalise first letter
 415     $description =~ s/\.$//;          # remove period at the end
 416     $description =~ s/\s*$//;
 417     $description =~ s/^\s*//;
 418     $description =~ s/\n+/ /;         # Replace new lines by space.
 419     INFO("description: $description");
 420 }
 421
 422 #print(Data::Dumper::Dumper($meta->licenses) . "\n");
 423 my $license = $meta ? render_license( $meta->licenses ) : undef;
 424
 425 INFO( "RSS feed: https://metacpan.org/feed/distribution/",
 426     $module->package_name );
 427
 428 my $build_fun = -e "$pkg_path/Build.PL"
 429   && !-e "$pkg_path/Makefile.PL" ? "buildPerlModule" : "buildPerlPackage";
 430
 431 print STDERR "===\n";
 432
 433 print <<EOF;
 434   ${\(is_reserved($attr_name) ? "\"$attr_name\"" : $attr_name)} = $build_fun {
 435     pname = "$pkg_name";
 436     version = "$pkg_version";
 437     src = fetchurl {
 438       url = "mirror://cpan/${\$module->path}/${\$module->package}";
 439       sha256 = "${\$module->status->checksum_value}";
 440     };
 441 EOF
 442 print <<EOF if scalar @build_deps > 0;
 443     buildInputs = [ @build_deps ];
 444 EOF
 445 print <<EOF if scalar @runtime_deps > 0;
 446     propagatedBuildInputs = [ @runtime_deps ];
 447 EOF
 448 print <<EOF;
 449     meta = {
 450 EOF
 451 print <<EOF if defined $homepage;
 452       homepage = "$homepage";
 453 EOF
 454 print <<EOF if defined $description && $description ne "Unknown";
 455       description = "$description";
 456 EOF
 457 print <<EOF if defined $license;
 458       license = $license;
 459 EOF
 460 print <<EOF if $opt->maintainer;
 461       maintainers = [ maintainers.${\$opt->maintainer} ];
 462 EOF
 463 print <<EOF;
 464     };
 465   };
 466 EOF