scancpan: a new script

which creates Perl/CPAN package files

[Peter: strip trailing spaces]
Signed-off-by: Francois Perrad <francois.perrad@gadz.org>
Acked-by: Arnout Vandecappelle (Essensium/Mind) <arnout@mind.be>
Signed-off-by: Peter Korsgaard <peter@korsgaard.com>

support/scripts/scancpan

@@ -0,0 +1,741 @@
+#!/usr/bin/env perl
+
+# This chunk of stuff was generated by App::FatPacker. To find the original
+# file's code, look for the end of this BEGIN block or the string 'FATPACK'
+BEGIN {
+my %fatpacked;
+
+$fatpacked{"MetaCPAN/API/Tiny.pm"} = <<'METACPAN_API_TINY';
+  package MetaCPAN::API::Tiny;
+  {
+    $MetaCPAN::API::Tiny::VERSION = '1.131730';
+  }
+  use strict;
+  use warnings;
+  # ABSTRACT: A Tiny API client for MetaCPAN
+
+  use Carp;
+  use JSON::PP 'encode_json', 'decode_json';
+  use HTTP::Tiny;
+
+
+  sub new {
+      my ($class, @args) = @_;
+
+      $#_ % 2 == 0
+          or croak 'Arguments must be provided as name/value pairs';
+
+      my %params = @args;
+
+      die 'ua_args must be an array reference'
+          if $params{ua_args} && ref($params{ua_args}) ne 'ARRAY';
+
+      my $self = +{
+          base_url => $params{base_url} || 'http://api.metacpan.org/v0',
+          ua => $params{ua} || HTTP::Tiny->new(
+              $params{ua_args}
+                  ? @{$params{ua_args}}
+                  : (agent => 'MetaCPAN::API::Tiny/'
+                      . ($MetaCPAN::API::VERSION || 'xx'))),
+      };
+
+      return bless($self, $class);
+  }
+
+  sub _build_extra_params {
+      my $self = shift;
+
+      @_ % 2 == 0
+          or croak 'Incorrect number of params, must be key/value';
+
+      my %extra = @_;
+      my $ua = $self->{ua};
+
+      foreach my $key (keys %extra)
+      {
+          # The implementation in HTTP::Tiny uses + instead of %20, fix that
+          $extra{$key} = $ua->_uri_escape($extra{$key});
+          $extra{$key} =~ s/\+/%20/g;
+      }
+
+      my $params = join '&', map { "$_=" . $extra{$_} } sort keys %extra;
+
+      return $params;
+  }
+
+
+  # /source/{author}/{release}/{path}
+  sub source {
+      my $self  = shift;
+      my %opts  = @_ ? @_ : ();
+      my $url   = '';
+      my $error = "Provide 'author' and 'release' and 'path'";
+
+      %opts or croak $error;
+
+      if (
+          defined ( my $author  = $opts{'author'}  ) &&
+          defined ( my $release = $opts{'release'} ) &&
+          defined ( my $path    = $opts{'path'}    )
+        ) {
+          $url = "source/$author/$release/$path";
+      } else {
+          croak $error;
+      }
+
+      $url = $self->{base_url} . "/$url";
+
+      my $result = $self->{ua}->get($url);
+      $result->{'success'}
+          or croak "Failed to fetch '$url': " . $result->{'reason'};
+
+      return $result->{'content'};
+  }
+
+
+  # /release/{distribution}
+  # /release/{author}/{release}
+  sub release {
+      my $self  = shift;
+      my %opts  = @_ ? @_ : ();
+      my $url   = '';
+      my $error = "Either provide 'distribution', or 'author' and 'release', " .
+                  "or 'search'";
+
+      %opts or croak $error;
+
+      my %extra_opts = ();
+
+      if ( defined ( my $dist = $opts{'distribution'} ) ) {
+          $url = "release/$dist";
+      } elsif (
+          defined ( my $author  = $opts{'author'}  ) &&
+          defined ( my $release = $opts{'release'} )
+        ) {
+          $url = "release/$author/$release";
+      } elsif ( defined ( my $search_opts = $opts{'search'} ) ) {
+          ref $search_opts && ref $search_opts eq 'HASH'
+              or croak $error;
+
+          %extra_opts = %{$search_opts};
+          $url        = 'release/_search';
+      } else {
+          croak $error;
+      }
+
+      return $self->fetch( $url, %extra_opts );
+  }
+
+
+  # /pod/{module}
+  # /pod/{author}/{release}/{path}
+  sub pod {
+      my $self  = shift;
+      my %opts  = @_ ? @_ : ();
+      my $url   = '';
+      my $error = "Either provide 'module' or 'author and 'release' and 'path'";
+
+      %opts or croak $error;
+
+      if ( defined ( my $module = $opts{'module'} ) ) {
+          $url = "pod/$module";
+      } elsif (
+          defined ( my $author  = $opts{'author'}  ) &&
+          defined ( my $release = $opts{'release'} ) &&
+          defined ( my $path    = $opts{'path'}    )
+        ) {
+          $url = "pod/$author/$release/$path";
+      } else {
+          croak $error;
+      }
+
+      # check content-type
+      my %extra = ();
+      if ( defined ( my $type = $opts{'content-type'} ) ) {
+          $type =~ m{^ text/ (?: html|plain|x-pod|x-markdown ) $}x
+              or croak 'Incorrect content-type provided';
+
+          $extra{headers}{'content-type'} = $type;
+      }
+
+      $url = $self->{base_url}. "/$url";
+
+      my $result = $self->{ua}->get( $url, \%extra );
+      $result->{'success'}
+          or croak "Failed to fetch '$url': " . $result->{'reason'};
+
+      return $result->{'content'};
+  }
+
+
+  # /module/{module}
+  sub module {
+      my $self = shift;
+      my $name = shift;
+
+      $name or croak 'Please provide a module name';
+
+      return $self->fetch("module/$name");
+  }
+
+
+  # file() is a synonym of module
+  sub file { goto &module }
+
+
+  # /author/{author}
+  sub author {
+      my $self = shift;
+      my ( $pause_id, $url, %extra_opts );
+
+      if ( @_ == 1 ) {
+          $url = 'author/' . shift;
+      } elsif ( @_ == 2 ) {
+          my %opts = @_;
+
+          if ( defined $opts{'pauseid'} ) {
+              $url = "author/" . $opts{'pauseid'};
+          } elsif ( defined $opts{'search'} ) {
+              my $search_opts = $opts{'search'};
+
+              ref $search_opts && ref $search_opts eq 'HASH'
+                  or croak "'search' key must be hashref";
+
+              %extra_opts = %{$search_opts};
+              $url        = 'author/_search';
+          } else {
+              croak 'Unknown option given';
+          }
+      } else {
+          croak 'Please provide an author PAUSEID or a "search"';
+      }
+
+      return $self->fetch( $url, %extra_opts );
+  }
+
+
+
+  sub fetch {
+      my $self    = shift;
+      my $url     = shift;
+      my $extra   = $self->_build_extra_params(@_);
+      my $base    = $self->{base_url};
+      my $req_url = $extra ? "$base/$url?$extra" : "$base/$url";
+
+      my $result  = $self->{ua}->get($req_url);
+      return $self->_decode_result( $result, $req_url );
+  }
+
+
+  sub post {
+      my $self  = shift;
+      my $url   = shift;
+      my $query = shift;
+      my $base  = $self->{base_url};
+
+      defined $url
+          or croak 'First argument of URL must be provided';
+
+      ref $query and ref $query eq 'HASH'
+          or croak 'Second argument of query hashref must be provided';
+
+      my $query_json = encode_json( $query );
+      my $result     = $self->{ua}->request(
+          'POST',
+          "$base/$url",
+          {
+              headers => { 'Content-Type' => 'application/json' },
+              content => $query_json,
+          }
+      );
+
+      return $self->_decode_result( $result, $url, $query_json );
+  }
+
+  sub _decode_result {
+      my $self = shift;
+      my ( $result, $url, $original ) = @_;
+      my $decoded_result;
+
+      ref $result and ref $result eq 'HASH'
+          or croak 'First argument must be hashref';
+
+      defined $url
+          or croak 'Second argument of a URL must be provided';
+
+      if ( defined ( my $success = $result->{'success'} ) ) {
+          my $reason = $result->{'reason'} || '';
+          $reason .= ( defined $original ? " (request: $original)" : '' );
+
+          $success or croak "Failed to fetch '$url': $reason";
+      } else {
+          croak 'Missing success in return value';
+      }
+
+      defined ( my $content = $result->{'content'} )
+          or croak 'Missing content in return value';
+
+      eval { $decoded_result = decode_json $content; 1 }
+      or do { croak "Couldn't decode '$content': $@" };
+
+      return $decoded_result;
+  }
+
+  1;
+
+  __END__
+
+  =pod
+
+  =head1 NAME
+
+  MetaCPAN::API::Tiny - A Tiny API client for MetaCPAN
+
+  =head1 VERSION
+
+  version 1.131730
+
+  =head1 DESCRIPTION
+
+  This is the Tiny version of L<MetaCPAN::API>. It implements a compatible API
+  with a few notable exceptions:
+
+  =over 4
+
+  =item Attributes are direct hash access
+
+  The attributes defined using Mo(o|u)se are now accessed via the blessed hash
+  directly. There are no accessors defined to access this elements.
+
+  =item Exception handling
+
+  Instead of using Try::Tiny, raw evals are used. This could potentially cause
+  issues, so just be aware.
+
+  =item Testing
+
+  Test::Fatal was replaced with an eval implementation of exception().
+  Test::TinyMocker usage is retained, but may be absorbed since it is pure perl
+
+  =back
+
+  =head1 CLASS_METHODS
+
+  =head2 new
+
+  new is the constructor for MetaCPAN::API::Tiny. In the non-tiny version of this
+  module, this is provided via Any::Moose built from the attributes defined. In
+  the tiny version, we define our own constructor. It takes the same arguments
+  and provides similar checks to MetaCPAN::API with regards to arguments passed.
+
+  =head1 PUBLIC_METHODS
+
+  =head2 source
+
+      my $source = $mcpan->source(
+          author  => 'DOY',
+          release => 'Moose-2.0201',
+          path    => 'lib/Moose.pm',
+      );
+
+  Searches MetaCPAN for a module or a specific release and returns the plain source.
+
+  =head2 release
+
+      my $result = $mcpan->release( distribution => 'Moose' );
+
+      # or
+      my $result = $mcpan->release( author => 'DOY', release => 'Moose-2.0001' );
+
+  Searches MetaCPAN for a dist.
+
+  You can do complex searches using 'search' parameter:
+
+      # example lifted from MetaCPAN docs
+      my $result = $mcpan->release(
+          search => {
+              author => "OALDERS AND ",
+              filter => "status:latest",
+              fields => "name",
+              size   => 1,
+          },
+      );
+
+  =head2 pod
+
+      my $result = $mcpan->pod( module => 'Moose' );
+
+      # or
+      my $result = $mcpan->pod(
+          author  => 'DOY',
+          release => 'Moose-2.0201',
+          path    => 'lib/Moose.pm',
+      );
+
+  Searches MetaCPAN for a module or a specific release and returns the POD.
+
+  =head2 module
+
+      my $result = $mcpan->module('MetaCPAN::API');
+
+  Searches MetaCPAN and returns a module's ".pm" file.
+
+  =head2 file
+
+  A synonym of L</module>
+
+  =head2 author
+
+      my $result1 = $mcpan->author('XSAWYERX');
+      my $result2 = $mcpan->author( pauseid => 'XSAWYERX' );
+
+  Searches MetaCPAN for a specific author.
+
+  You can do complex searches using 'search' parameter:
+
+      # example lifted from MetaCPAN docs
+      my $result = $mcpan->author(
+          search => {
+              q    => 'profile.name:twitter',
+              size => 1,
+          },
+      );
+
+  =head2 fetch
+
+      my $result = $mcpan->fetch('/release/distribution/Moose');
+
+      # with parameters
+      my $more = $mcpan->fetch(
+          '/release/distribution/Moose',
+          param => 'value',
+      );
+
+  This is a helper method for API implementations. It fetches a path from MetaCPAN, decodes the JSON from the content variable and returns it.
+
+  You don't really need to use it, but you can in case you want to write your own extension implementation to MetaCPAN::API.
+
+  It accepts an additional hash as "GET" parameters.
+
+  =head2 post
+
+      # /release&content={"query":{"match_all":{}},"filter":{"prefix":{"archive":"Cache-Cache-1.06"}}}
+      my $result = $mcpan->post(
+          'release',
+          {
+              query  => { match_all => {} },
+              filter => { prefix => { archive => 'Cache-Cache-1.06' } },
+          },
+      );
+
+  The POST equivalent of the "fetch()" method. It gets the path and JSON request.
+
+  =head1 THANKS
+
+  Overall the tests and code were ripped directly from MetaCPAN::API and
+  tiny-fied. A big thanks to Sawyer X for writing the original module.
+
+  =head1 AUTHOR
+
+  Nicholas R. Perez <nperez@cpan.org>
+
+  =head1 COPYRIGHT AND LICENSE
+
+  This software is copyright (c) 2013 by Nicholas R. Perez <nperez@cpan.org>.
+
+  This is free software; you can redistribute it and/or modify it under
+  the same terms as the Perl 5 programming language system itself.
+
+  =cut
+METACPAN_API_TINY
+
+s/^  //mg for values %fatpacked;
+
+unshift @INC, sub {
+  if (my $fat = $fatpacked{$_[1]}) {
+    if ($] < 5.008) {
+      return sub {
+        return 0 unless length $fat;
+        $fat =~ s/^([^\n]*\n?)//;
+        $_ = $1;
+        return 1;
+      };
+    }
+    open my $fh, '<', \$fat
+      or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
+    return $fh;
+  }
+  return
+};
+
+} # END OF FATPACK CODE
+
+
+use 5.018;      # same major version as target perl
+use strict;
+use warnings;
+use Fatal qw(open close);
+
+use Getopt::Long;
+use Pod::Usage;
+use File::Basename;
+use Module::CoreList;
+use MetaCPAN::API::Tiny;
+
+my ($help, $man, $quiet, $force, $recommend);
+GetOptions( 'help|?' => \$help,
+            'man' => \$man,
+            'quiet|q' => \$quiet,
+            'force|f' => \$force,
+            'recommend' => \$recommend
+) or pod2usage(-exitval => 1);
+pod2usage(-exitval => 0) if $help;
+pod2usage(-exitval => 0, -verbose => 2) if $man;
+pod2usage(-exitval => 1) if scalar @ARGV == 0;
+
+my %dist;               # name -> metacpan data
+my %need_target;        # name -> 1 if target package is needed
+my %need_host;          # name -> 1 if host package is needed
+my %deps_build;         # name -> list of host dependencies
+my %deps_runtime;       # name -> list of target dependencies
+my $mcpan = MetaCPAN::API::Tiny->new();
+
+sub fetch {
+    my ($name, $need_target, $need_host) = @_;
+    $need_target{$name} = $need_target if $need_target;
+    $need_host{$name} = $need_host if $need_host;
+    unless ($dist{$name}) {
+        say qq{fetch ${name}} unless $quiet;
+        my $result = $mcpan->release( distribution => $name );
+        $dist{$name} = $result;
+        my @deps_build = ();
+        my @deps_runtime = ();
+        my $mb;
+        foreach my $dep (@{$result->{dependency}}) {
+            my $modname = ${$dep}{module};
+            $mb = 1 if $modname eq q{Module::Build};
+            # Module::Build has a special treatment, because it is a core module,
+            # but some module require a very recent version of it
+            next if $modname eq q{perl};
+            next if $modname =~ m|^Alien|;
+            next if $modname =~ m|^Win32|;
+            next if Module::CoreList::first_release( $modname );
+            # we could use the host Module::CoreList data, because host perl and
+            # target perl have the same major version
+            next if ${$dep}{phase} eq q{develop};
+            next if ${$dep}{phase} eq q{test};
+            next if !$recommend && ${$dep}{relationship} ne q{requires};
+            my $distname = $mcpan->module( $modname )->{distribution};
+            if (${$dep}{phase} eq q{runtime}) {
+                push @deps_runtime, $distname;
+            }
+            else { # configure, build
+                push @deps_build, $distname;
+            }
+        }
+        unshift @deps_build, q{Module-Build} if $mb;
+        $deps_build{$name} = \@deps_build;
+        $deps_runtime{$name} = \@deps_runtime;
+    }
+    foreach my $distname (@{$deps_build{$name}}) {
+        fetch( $distname, 0, 1 );
+    }
+    foreach my $distname (@{$deps_runtime{$name}}) {
+        fetch( $distname, $need_target, $need_host );
+    }
+    return;
+}
+
+foreach my $distname (@ARGV) {
+    # Command-line's distributions are needed for target, not host
+    fetch( $distname, 1, 0 );
+}
+say scalar keys %dist, q{ packages fetched.} unless $quiet;
+
+# Buildroot package name: lowercase
+sub fsname {
+    my $name = shift;
+    return q{perl-} . lc $name;
+}
+
+# Buildroot variable name: uppercase
+sub brname {
+    my $name = shift;
+    $name =~ s|-|_|g;
+    return uc $name;
+}
+
+while (my ($distname, $dist) = each %dist) {
+    my $fsname = fsname( $distname );
+    my $dirname = q{package/} . $fsname;
+    my $cfgname = $dirname . q{/Config.in};
+    my $mkname = $dirname . q{/} . $fsname . q{.mk};
+    my $brname = brname( $fsname );
+    mkdir $dirname unless -d $dirname;
+    if ($need_target{$distname} && ($force || !-f $cfgname)) {
+        my $abstract = $dist->{abstract};
+        say qq{write ${cfgname}} unless $quiet;
+        open my $fh, q{>}, $cfgname;
+        say {$fh} qq{config BR2_PACKAGE_${brname}};
+        say {$fh} qq{\tbool "${fsname}"};
+        foreach my $dep (@{$deps_runtime{$distname}}) {
+            my $brdep = brname( fsname( $dep ) );
+            say {$fh} qq{\tselect BR2_PACKAGE_${brdep}};
+        }
+        say {$fh} qq{\thelp} if $abstract;
+        say {$fh} qq{\t  ${abstract}} if $abstract;
+        close $fh;
+    }
+    if ($force || !-f $mkname) {
+        my $version = $dist->{version};
+        my($path) = $dist->{download_url} =~ m|^[^:/?#]+://[^/?#]*([^?#]*)|;
+        # this URL contains only the scheme, auth and path parts (but no query and fragment parts)
+        # the scheme is not used, because the job is done by the BR download infrastructure
+        # the auth part is not used, because we use $(BR2_CPAN_MIRROR)
+        my($filename, $directories, $suffix) = fileparse( $path, q{tar.gz}, q{tgz} );
+        my $dependencies = join q{ }, map( { q{host-} . fsname( $_ ); } @{$deps_build{$distname}} ),
+                                      map( { fsname( $_ ); } @{$deps_runtime{$distname}} );
+        my $host_dependencies = join q{ }, map { q{host-} . fsname( $_ ); } @{$deps_build{$distname}},
+                                                                            @{$deps_runtime{$distname}};
+        my $license = ref $dist->{license} eq 'ARRAY'
+                    ? join q{ or }, @{$dist->{license}}
+                    : $dist->{license};
+        $license = q{Artistic or GPLv1+} if $license eq q{perl_5};
+        say qq{write ${mkname}} unless $quiet;
+        open my $fh, q{>}, $mkname;
+        say {$fh} qq{################################################################################};
+        say {$fh} qq{#};
+        say {$fh} qq{# ${fsname}};
+        say {$fh} qq{#};
+        say {$fh} qq{################################################################################};
+        say {$fh} qq{};
+        say {$fh} qq{${brname}_VERSION = ${version}};
+        say {$fh} qq{${brname}_SOURCE = ${distname}-\$(${brname}_VERSION).${suffix}};
+        say {$fh} qq{${brname}_SITE = \$(BR2_CPAN_MIRROR)${directories}};
+        say {$fh} qq{${brname}_DEPENDENCIES = perl ${dependencies}} if $need_target{$distname};
+        say {$fh} qq{HOST_${brname}_DEPENDENCIES = ${host_dependencies}} if $need_host{$distname};
+        say {$fh} qq{${brname}_LICENSE = ${license}} if $license && $license ne q{unknown};
+        say {$fh} qq{};
+        say {$fh} qq{\$(eval \$(perl-package))} if $need_target{$distname};
+        say {$fh} qq{\$(eval \$(host-perl-package))} if $need_host{$distname};
+        close $fh;
+    }
+}
+
+my %pkg;
+my $cfgname = q{package/Config.in};
+if (-f $cfgname) {
+    open my $fh, q{<}, $cfgname;
+    while (<$fh>) {
+        chomp;
+        $pkg{$_} = 1 if m|package/perl-|;
+    }
+    close $fh;
+}
+
+foreach my $distname (keys %need_target) {
+    my $fsname = fsname( $distname );
+    $pkg{qq{source "package/${fsname}/Config.in"}} = 1;
+}
+
+say qq{${cfgname} must contain the following lines:};
+say join qq{\n}, sort keys %pkg;
+
+__END__
+
+=head1 NAME
+
+support/scripts/scancpan Try-Tiny Moo
+
+=head1 SYNOPSIS
+
+curl -kL http://install.perlbrew.pl | bash
+
+perlbrew install perl-5.18.2
+
+supports/scripts/scancpan [options] [distname ...]
+
+ Options:
+   -help
+   -man
+   -quiet
+   -force
+   -recommend
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-help>
+
+Prints a brief help message and exits.
+
+=item B<-man>
+
+Prints the manual page and exits.
+
+=item B<-quiet>
+
+Executes without output
+
+=item B<-force>
+
+Forces the overwriting of existing files.
+
+=item B<-recommend>
+
+Adds I<recommended> dependencies.
+
+=back
+
+=head1 DESCRIPTION
+
+This script creates templates of the Buildroot package files for all the
+Perl/CPAN distributions required by the specified distnames. The
+dependencies and metadata are fetched from https://metacpan.org/.
+
+After running this script, it is necessary to check the generated files.
+You have to manually enable the host- version if you need it. You have to
+manually add the license files (PERL_FOO_LICENSE_FILES variable). For
+distributions that link against a target library, you have to add the
+buildroot package name for that library to the DEPENDENCIES variable.
+
+See the Buildroot documentation for details on the usage of the Perl
+infrastructure.
+
+The major version of the host perl must be aligned on the target one,
+in order to work with the right CoreList data.
+
+=head1 LICENSE
+
+Copyright (C) 2013-2014 by Francois Perrad <francois.perrad@gadz.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+This script is a part of Buildroot.
+
+This script requires the module C<MetaCPAN::API::Tiny> (version 1.131730)
+which was included at the beginning of this file by the tool C<fatpack>.
+
+See L<http://search.cpan.org/~nperez/MetaCPAN-API-Tiny-1.131730/>.
+
+See L<http://search.cpan.org/search?query=App-FatPacker&mode=dist>.
+
+These both libraries are free software and may be distributed under the same
+terms as perl itself.
+
+And perl may be distributed under the terms of Artistic v1 or GPL v1 license.
+
+=cut