xref: /OK3568_Linux_fs/buildroot/utils/scancpan (revision 4882a59341e53eb6f0b4789bf948001014eff981)
1*4882a593Smuzhiyun#!/usr/bin/env perl
2*4882a593Smuzhiyun
3*4882a593Smuzhiyun# This chunk of stuff was generated by App::FatPacker. To find the original
4*4882a593Smuzhiyun# file's code, look for the end of this BEGIN block or the string 'FATPACK'
5*4882a593SmuzhiyunBEGIN {
6*4882a593Smuzhiyunmy %fatpacked;
7*4882a593Smuzhiyun
8*4882a593Smuzhiyun$fatpacked{"MetaCPAN/API/Tiny.pm"} = <<'METACPAN_API_TINY';
9*4882a593Smuzhiyun  package MetaCPAN::API::Tiny;
10*4882a593Smuzhiyun  {
11*4882a593Smuzhiyun    $MetaCPAN::API::Tiny::VERSION = '1.131730';
12*4882a593Smuzhiyun  }
13*4882a593Smuzhiyun  use strict;
14*4882a593Smuzhiyun  use warnings;
15*4882a593Smuzhiyun  # ABSTRACT: A Tiny API client for MetaCPAN
16*4882a593Smuzhiyun
17*4882a593Smuzhiyun  use Carp;
18*4882a593Smuzhiyun  use JSON::PP 'encode_json', 'decode_json';
19*4882a593Smuzhiyun  use HTTP::Tiny;
20*4882a593Smuzhiyun
21*4882a593Smuzhiyun
22*4882a593Smuzhiyun  sub new {
23*4882a593Smuzhiyun      my ($class, @args) = @_;
24*4882a593Smuzhiyun
25*4882a593Smuzhiyun      $#_ % 2 == 0
26*4882a593Smuzhiyun          or croak 'Arguments must be provided as name/value pairs';
27*4882a593Smuzhiyun
28*4882a593Smuzhiyun      my %params = @args;
29*4882a593Smuzhiyun
30*4882a593Smuzhiyun      die 'ua_args must be an array reference'
31*4882a593Smuzhiyun          if $params{ua_args} && ref($params{ua_args}) ne 'ARRAY';
32*4882a593Smuzhiyun
33*4882a593Smuzhiyun      my $self = +{
34*4882a593Smuzhiyun          base_url => $params{base_url} || 'http://api.metacpan.org/v0',
35*4882a593Smuzhiyun          ua => $params{ua} || HTTP::Tiny->new(
36*4882a593Smuzhiyun              $params{ua_args}
37*4882a593Smuzhiyun                  ? @{$params{ua_args}}
38*4882a593Smuzhiyun                  : (agent => 'MetaCPAN::API::Tiny/'
39*4882a593Smuzhiyun                      . ($MetaCPAN::API::VERSION || 'xx'))),
40*4882a593Smuzhiyun      };
41*4882a593Smuzhiyun
42*4882a593Smuzhiyun      return bless($self, $class);
43*4882a593Smuzhiyun  }
44*4882a593Smuzhiyun
45*4882a593Smuzhiyun  sub _build_extra_params {
46*4882a593Smuzhiyun      my $self = shift;
47*4882a593Smuzhiyun
48*4882a593Smuzhiyun      @_ % 2 == 0
49*4882a593Smuzhiyun          or croak 'Incorrect number of params, must be key/value';
50*4882a593Smuzhiyun
51*4882a593Smuzhiyun      my %extra = @_;
52*4882a593Smuzhiyun      my $ua = $self->{ua};
53*4882a593Smuzhiyun
54*4882a593Smuzhiyun      foreach my $key (keys %extra)
55*4882a593Smuzhiyun      {
56*4882a593Smuzhiyun          # The implementation in HTTP::Tiny uses + instead of %20, fix that
57*4882a593Smuzhiyun          $extra{$key} = $ua->_uri_escape($extra{$key});
58*4882a593Smuzhiyun          $extra{$key} =~ s/\+/%20/g;
59*4882a593Smuzhiyun      }
60*4882a593Smuzhiyun
61*4882a593Smuzhiyun      my $params = join '&', map { "$_=" . $extra{$_} } sort keys %extra;
62*4882a593Smuzhiyun
63*4882a593Smuzhiyun      return $params;
64*4882a593Smuzhiyun  }
65*4882a593Smuzhiyun
66*4882a593Smuzhiyun
67*4882a593Smuzhiyun  # /source/{author}/{release}/{path}
68*4882a593Smuzhiyun  sub source {
69*4882a593Smuzhiyun      my $self  = shift;
70*4882a593Smuzhiyun      my %opts  = @_ ? @_ : ();
71*4882a593Smuzhiyun      my $url   = '';
72*4882a593Smuzhiyun      my $error = "Provide 'author' and 'release' and 'path'";
73*4882a593Smuzhiyun
74*4882a593Smuzhiyun      %opts or croak $error;
75*4882a593Smuzhiyun
76*4882a593Smuzhiyun      if (
77*4882a593Smuzhiyun          defined ( my $author  = $opts{'author'}  ) &&
78*4882a593Smuzhiyun          defined ( my $release = $opts{'release'} ) &&
79*4882a593Smuzhiyun          defined ( my $path    = $opts{'path'}    )
80*4882a593Smuzhiyun        ) {
81*4882a593Smuzhiyun          $url = "source/$author/$release/$path";
82*4882a593Smuzhiyun      } else {
83*4882a593Smuzhiyun          croak $error;
84*4882a593Smuzhiyun      }
85*4882a593Smuzhiyun
86*4882a593Smuzhiyun      $url = $self->{base_url} . "/$url";
87*4882a593Smuzhiyun
88*4882a593Smuzhiyun      my $result = $self->{ua}->get($url);
89*4882a593Smuzhiyun      $result->{'success'}
90*4882a593Smuzhiyun          or croak "Failed to fetch '$url': " . $result->{'reason'};
91*4882a593Smuzhiyun
92*4882a593Smuzhiyun      return $result->{'content'};
93*4882a593Smuzhiyun  }
94*4882a593Smuzhiyun
95*4882a593Smuzhiyun
96*4882a593Smuzhiyun  # /release/{distribution}
97*4882a593Smuzhiyun  # /release/{author}/{release}
98*4882a593Smuzhiyun  sub release {
99*4882a593Smuzhiyun      my $self  = shift;
100*4882a593Smuzhiyun      my %opts  = @_ ? @_ : ();
101*4882a593Smuzhiyun      my $url   = '';
102*4882a593Smuzhiyun      my $error = "Either provide 'distribution', or 'author' and 'release', " .
103*4882a593Smuzhiyun                  "or 'search'";
104*4882a593Smuzhiyun
105*4882a593Smuzhiyun      %opts or croak $error;
106*4882a593Smuzhiyun
107*4882a593Smuzhiyun      my %extra_opts = ();
108*4882a593Smuzhiyun
109*4882a593Smuzhiyun      if ( defined ( my $dist = $opts{'distribution'} ) ) {
110*4882a593Smuzhiyun          $url = "release/$dist";
111*4882a593Smuzhiyun      } elsif (
112*4882a593Smuzhiyun          defined ( my $author  = $opts{'author'}  ) &&
113*4882a593Smuzhiyun          defined ( my $release = $opts{'release'} )
114*4882a593Smuzhiyun        ) {
115*4882a593Smuzhiyun          $url = "release/$author/$release";
116*4882a593Smuzhiyun      } elsif ( defined ( my $search_opts = $opts{'search'} ) ) {
117*4882a593Smuzhiyun          ref $search_opts && ref $search_opts eq 'HASH'
118*4882a593Smuzhiyun              or croak $error;
119*4882a593Smuzhiyun
120*4882a593Smuzhiyun          %extra_opts = %{$search_opts};
121*4882a593Smuzhiyun          $url        = 'release/_search';
122*4882a593Smuzhiyun      } else {
123*4882a593Smuzhiyun          croak $error;
124*4882a593Smuzhiyun      }
125*4882a593Smuzhiyun
126*4882a593Smuzhiyun      return $self->fetch( $url, %extra_opts );
127*4882a593Smuzhiyun  }
128*4882a593Smuzhiyun
129*4882a593Smuzhiyun
130*4882a593Smuzhiyun  # /pod/{module}
131*4882a593Smuzhiyun  # /pod/{author}/{release}/{path}
132*4882a593Smuzhiyun  sub pod {
133*4882a593Smuzhiyun      my $self  = shift;
134*4882a593Smuzhiyun      my %opts  = @_ ? @_ : ();
135*4882a593Smuzhiyun      my $url   = '';
136*4882a593Smuzhiyun      my $error = "Either provide 'module' or 'author and 'release' and 'path'";
137*4882a593Smuzhiyun
138*4882a593Smuzhiyun      %opts or croak $error;
139*4882a593Smuzhiyun
140*4882a593Smuzhiyun      if ( defined ( my $module = $opts{'module'} ) ) {
141*4882a593Smuzhiyun          $url = "pod/$module";
142*4882a593Smuzhiyun      } elsif (
143*4882a593Smuzhiyun          defined ( my $author  = $opts{'author'}  ) &&
144*4882a593Smuzhiyun          defined ( my $release = $opts{'release'} ) &&
145*4882a593Smuzhiyun          defined ( my $path    = $opts{'path'}    )
146*4882a593Smuzhiyun        ) {
147*4882a593Smuzhiyun          $url = "pod/$author/$release/$path";
148*4882a593Smuzhiyun      } else {
149*4882a593Smuzhiyun          croak $error;
150*4882a593Smuzhiyun      }
151*4882a593Smuzhiyun
152*4882a593Smuzhiyun      # check content-type
153*4882a593Smuzhiyun      my %extra = ();
154*4882a593Smuzhiyun      if ( defined ( my $type = $opts{'content-type'} ) ) {
155*4882a593Smuzhiyun          $type =~ m{^ text/ (?: html|plain|x-pod|x-markdown ) $}x
156*4882a593Smuzhiyun              or croak 'Incorrect content-type provided';
157*4882a593Smuzhiyun
158*4882a593Smuzhiyun          $extra{headers}{'content-type'} = $type;
159*4882a593Smuzhiyun      }
160*4882a593Smuzhiyun
161*4882a593Smuzhiyun      $url = $self->{base_url}. "/$url";
162*4882a593Smuzhiyun
163*4882a593Smuzhiyun      my $result = $self->{ua}->get( $url, \%extra );
164*4882a593Smuzhiyun      $result->{'success'}
165*4882a593Smuzhiyun          or croak "Failed to fetch '$url': " . $result->{'reason'};
166*4882a593Smuzhiyun
167*4882a593Smuzhiyun      return $result->{'content'};
168*4882a593Smuzhiyun  }
169*4882a593Smuzhiyun
170*4882a593Smuzhiyun
171*4882a593Smuzhiyun  # /module/{module}
172*4882a593Smuzhiyun  sub module {
173*4882a593Smuzhiyun      my $self = shift;
174*4882a593Smuzhiyun      my $name = shift;
175*4882a593Smuzhiyun
176*4882a593Smuzhiyun      $name or croak 'Please provide a module name';
177*4882a593Smuzhiyun
178*4882a593Smuzhiyun      return $self->fetch("module/$name");
179*4882a593Smuzhiyun  }
180*4882a593Smuzhiyun
181*4882a593Smuzhiyun
182*4882a593Smuzhiyun  # file() is a synonym of module
183*4882a593Smuzhiyun  sub file { goto &module }
184*4882a593Smuzhiyun
185*4882a593Smuzhiyun
186*4882a593Smuzhiyun  # /author/{author}
187*4882a593Smuzhiyun  sub author {
188*4882a593Smuzhiyun      my $self = shift;
189*4882a593Smuzhiyun      my ( $pause_id, $url, %extra_opts );
190*4882a593Smuzhiyun
191*4882a593Smuzhiyun      if ( @_ == 1 ) {
192*4882a593Smuzhiyun          $url = 'author/' . shift;
193*4882a593Smuzhiyun      } elsif ( @_ == 2 ) {
194*4882a593Smuzhiyun          my %opts = @_;
195*4882a593Smuzhiyun
196*4882a593Smuzhiyun          if ( defined $opts{'pauseid'} ) {
197*4882a593Smuzhiyun              $url = "author/" . $opts{'pauseid'};
198*4882a593Smuzhiyun          } elsif ( defined $opts{'search'} ) {
199*4882a593Smuzhiyun              my $search_opts = $opts{'search'};
200*4882a593Smuzhiyun
201*4882a593Smuzhiyun              ref $search_opts && ref $search_opts eq 'HASH'
202*4882a593Smuzhiyun                  or croak "'search' key must be hashref";
203*4882a593Smuzhiyun
204*4882a593Smuzhiyun              %extra_opts = %{$search_opts};
205*4882a593Smuzhiyun              $url        = 'author/_search';
206*4882a593Smuzhiyun          } else {
207*4882a593Smuzhiyun              croak 'Unknown option given';
208*4882a593Smuzhiyun          }
209*4882a593Smuzhiyun      } else {
210*4882a593Smuzhiyun          croak 'Please provide an author PAUSEID or a "search"';
211*4882a593Smuzhiyun      }
212*4882a593Smuzhiyun
213*4882a593Smuzhiyun      return $self->fetch( $url, %extra_opts );
214*4882a593Smuzhiyun  }
215*4882a593Smuzhiyun
216*4882a593Smuzhiyun
217*4882a593Smuzhiyun
218*4882a593Smuzhiyun  sub fetch {
219*4882a593Smuzhiyun      my $self    = shift;
220*4882a593Smuzhiyun      my $url     = shift;
221*4882a593Smuzhiyun      my $extra   = $self->_build_extra_params(@_);
222*4882a593Smuzhiyun      my $base    = $self->{base_url};
223*4882a593Smuzhiyun      my $req_url = $extra ? "$base/$url?$extra" : "$base/$url";
224*4882a593Smuzhiyun
225*4882a593Smuzhiyun      my $result  = $self->{ua}->get($req_url);
226*4882a593Smuzhiyun      return $self->_decode_result( $result, $req_url );
227*4882a593Smuzhiyun  }
228*4882a593Smuzhiyun
229*4882a593Smuzhiyun
230*4882a593Smuzhiyun  sub post {
231*4882a593Smuzhiyun      my $self  = shift;
232*4882a593Smuzhiyun      my $url   = shift;
233*4882a593Smuzhiyun      my $query = shift;
234*4882a593Smuzhiyun      my $base  = $self->{base_url};
235*4882a593Smuzhiyun
236*4882a593Smuzhiyun      defined $url
237*4882a593Smuzhiyun          or croak 'First argument of URL must be provided';
238*4882a593Smuzhiyun
239*4882a593Smuzhiyun      ref $query and ref $query eq 'HASH'
240*4882a593Smuzhiyun          or croak 'Second argument of query hashref must be provided';
241*4882a593Smuzhiyun
242*4882a593Smuzhiyun      my $query_json = encode_json( $query );
243*4882a593Smuzhiyun      my $result     = $self->{ua}->request(
244*4882a593Smuzhiyun          'POST',
245*4882a593Smuzhiyun          "$base/$url",
246*4882a593Smuzhiyun          {
247*4882a593Smuzhiyun              headers => { 'Content-Type' => 'application/json' },
248*4882a593Smuzhiyun              content => $query_json,
249*4882a593Smuzhiyun          }
250*4882a593Smuzhiyun      );
251*4882a593Smuzhiyun
252*4882a593Smuzhiyun      return $self->_decode_result( $result, $url, $query_json );
253*4882a593Smuzhiyun  }
254*4882a593Smuzhiyun
255*4882a593Smuzhiyun  sub _decode_result {
256*4882a593Smuzhiyun      my $self = shift;
257*4882a593Smuzhiyun      my ( $result, $url, $original ) = @_;
258*4882a593Smuzhiyun      my $decoded_result;
259*4882a593Smuzhiyun
260*4882a593Smuzhiyun      ref $result and ref $result eq 'HASH'
261*4882a593Smuzhiyun          or croak 'First argument must be hashref';
262*4882a593Smuzhiyun
263*4882a593Smuzhiyun      defined $url
264*4882a593Smuzhiyun          or croak 'Second argument of a URL must be provided';
265*4882a593Smuzhiyun
266*4882a593Smuzhiyun      if ( defined ( my $success = $result->{'success'} ) ) {
267*4882a593Smuzhiyun          my $reason = $result->{'reason'} || '';
268*4882a593Smuzhiyun          $reason .= ( defined $original ? " (request: $original)" : '' );
269*4882a593Smuzhiyun
270*4882a593Smuzhiyun          $success or croak "Failed to fetch '$url': $reason";
271*4882a593Smuzhiyun      } else {
272*4882a593Smuzhiyun          croak 'Missing success in return value';
273*4882a593Smuzhiyun      }
274*4882a593Smuzhiyun
275*4882a593Smuzhiyun      defined ( my $content = $result->{'content'} )
276*4882a593Smuzhiyun          or croak 'Missing content in return value';
277*4882a593Smuzhiyun
278*4882a593Smuzhiyun      eval { $decoded_result = decode_json $content; 1 }
279*4882a593Smuzhiyun      or do { croak "Couldn't decode '$content': $@" };
280*4882a593Smuzhiyun
281*4882a593Smuzhiyun      return $decoded_result;
282*4882a593Smuzhiyun  }
283*4882a593Smuzhiyun
284*4882a593Smuzhiyun  1;
285*4882a593Smuzhiyun
286*4882a593Smuzhiyun  __END__
287*4882a593Smuzhiyun
288*4882a593Smuzhiyun  =pod
289*4882a593Smuzhiyun
290*4882a593Smuzhiyun  =head1 NAME
291*4882a593Smuzhiyun
292*4882a593Smuzhiyun  MetaCPAN::API::Tiny - A Tiny API client for MetaCPAN
293*4882a593Smuzhiyun
294*4882a593Smuzhiyun  =head1 VERSION
295*4882a593Smuzhiyun
296*4882a593Smuzhiyun  version 1.131730
297*4882a593Smuzhiyun
298*4882a593Smuzhiyun  =head1 DESCRIPTION
299*4882a593Smuzhiyun
300*4882a593Smuzhiyun  This is the Tiny version of L<MetaCPAN::API>. It implements a compatible API
301*4882a593Smuzhiyun  with a few notable exceptions:
302*4882a593Smuzhiyun
303*4882a593Smuzhiyun  =over 4
304*4882a593Smuzhiyun
305*4882a593Smuzhiyun  =item Attributes are direct hash access
306*4882a593Smuzhiyun
307*4882a593Smuzhiyun  The attributes defined using Mo(o|u)se are now accessed via the blessed hash
308*4882a593Smuzhiyun  directly. There are no accessors defined to access this elements.
309*4882a593Smuzhiyun
310*4882a593Smuzhiyun  =item Exception handling
311*4882a593Smuzhiyun
312*4882a593Smuzhiyun  Instead of using Try::Tiny, raw evals are used. This could potentially cause
313*4882a593Smuzhiyun  issues, so just be aware.
314*4882a593Smuzhiyun
315*4882a593Smuzhiyun  =item Testing
316*4882a593Smuzhiyun
317*4882a593Smuzhiyun  Test::Fatal was replaced with an eval implementation of exception().
318*4882a593Smuzhiyun  Test::TinyMocker usage is retained, but may be absorbed since it is pure perl
319*4882a593Smuzhiyun
320*4882a593Smuzhiyun  =back
321*4882a593Smuzhiyun
322*4882a593Smuzhiyun  =head1 CLASS_METHODS
323*4882a593Smuzhiyun
324*4882a593Smuzhiyun  =head2 new
325*4882a593Smuzhiyun
326*4882a593Smuzhiyun  new is the constructor for MetaCPAN::API::Tiny. In the non-tiny version of this
327*4882a593Smuzhiyun  module, this is provided via Any::Moose built from the attributes defined. In
328*4882a593Smuzhiyun  the tiny version, we define our own constructor. It takes the same arguments
329*4882a593Smuzhiyun  and provides similar checks to MetaCPAN::API with regards to arguments passed.
330*4882a593Smuzhiyun
331*4882a593Smuzhiyun  =head1 PUBLIC_METHODS
332*4882a593Smuzhiyun
333*4882a593Smuzhiyun  =head2 source
334*4882a593Smuzhiyun
335*4882a593Smuzhiyun      my $source = $mcpan->source(
336*4882a593Smuzhiyun          author  => 'DOY',
337*4882a593Smuzhiyun          release => 'Moose-2.0201',
338*4882a593Smuzhiyun          path    => 'lib/Moose.pm',
339*4882a593Smuzhiyun      );
340*4882a593Smuzhiyun
341*4882a593Smuzhiyun  Searches MetaCPAN for a module or a specific release and returns the plain source.
342*4882a593Smuzhiyun
343*4882a593Smuzhiyun  =head2 release
344*4882a593Smuzhiyun
345*4882a593Smuzhiyun      my $result = $mcpan->release( distribution => 'Moose' );
346*4882a593Smuzhiyun
347*4882a593Smuzhiyun      # or
348*4882a593Smuzhiyun      my $result = $mcpan->release( author => 'DOY', release => 'Moose-2.0001' );
349*4882a593Smuzhiyun
350*4882a593Smuzhiyun  Searches MetaCPAN for a dist.
351*4882a593Smuzhiyun
352*4882a593Smuzhiyun  You can do complex searches using 'search' parameter:
353*4882a593Smuzhiyun
354*4882a593Smuzhiyun      # example lifted from MetaCPAN docs
355*4882a593Smuzhiyun      my $result = $mcpan->release(
356*4882a593Smuzhiyun          search => {
357*4882a593Smuzhiyun              author => "OALDERS AND ",
358*4882a593Smuzhiyun              filter => "status:latest",
359*4882a593Smuzhiyun              fields => "name",
360*4882a593Smuzhiyun              size   => 1,
361*4882a593Smuzhiyun          },
362*4882a593Smuzhiyun      );
363*4882a593Smuzhiyun
364*4882a593Smuzhiyun  =head2 pod
365*4882a593Smuzhiyun
366*4882a593Smuzhiyun      my $result = $mcpan->pod( module => 'Moose' );
367*4882a593Smuzhiyun
368*4882a593Smuzhiyun      # or
369*4882a593Smuzhiyun      my $result = $mcpan->pod(
370*4882a593Smuzhiyun          author  => 'DOY',
371*4882a593Smuzhiyun          release => 'Moose-2.0201',
372*4882a593Smuzhiyun          path    => 'lib/Moose.pm',
373*4882a593Smuzhiyun      );
374*4882a593Smuzhiyun
375*4882a593Smuzhiyun  Searches MetaCPAN for a module or a specific release and returns the POD.
376*4882a593Smuzhiyun
377*4882a593Smuzhiyun  =head2 module
378*4882a593Smuzhiyun
379*4882a593Smuzhiyun      my $result = $mcpan->module('MetaCPAN::API');
380*4882a593Smuzhiyun
381*4882a593Smuzhiyun  Searches MetaCPAN and returns a module's ".pm" file.
382*4882a593Smuzhiyun
383*4882a593Smuzhiyun  =head2 file
384*4882a593Smuzhiyun
385*4882a593Smuzhiyun  A synonym of L</module>
386*4882a593Smuzhiyun
387*4882a593Smuzhiyun  =head2 author
388*4882a593Smuzhiyun
389*4882a593Smuzhiyun      my $result1 = $mcpan->author('XSAWYERX');
390*4882a593Smuzhiyun      my $result2 = $mcpan->author( pauseid => 'XSAWYERX' );
391*4882a593Smuzhiyun
392*4882a593Smuzhiyun  Searches MetaCPAN for a specific author.
393*4882a593Smuzhiyun
394*4882a593Smuzhiyun  You can do complex searches using 'search' parameter:
395*4882a593Smuzhiyun
396*4882a593Smuzhiyun      # example lifted from MetaCPAN docs
397*4882a593Smuzhiyun      my $result = $mcpan->author(
398*4882a593Smuzhiyun          search => {
399*4882a593Smuzhiyun              q    => 'profile.name:twitter',
400*4882a593Smuzhiyun              size => 1,
401*4882a593Smuzhiyun          },
402*4882a593Smuzhiyun      );
403*4882a593Smuzhiyun
404*4882a593Smuzhiyun  =head2 fetch
405*4882a593Smuzhiyun
406*4882a593Smuzhiyun      my $result = $mcpan->fetch('/release/distribution/Moose');
407*4882a593Smuzhiyun
408*4882a593Smuzhiyun      # with parameters
409*4882a593Smuzhiyun      my $more = $mcpan->fetch(
410*4882a593Smuzhiyun          '/release/distribution/Moose',
411*4882a593Smuzhiyun          param => 'value',
412*4882a593Smuzhiyun      );
413*4882a593Smuzhiyun
414*4882a593Smuzhiyun  This is a helper method for API implementations. It fetches a path from MetaCPAN, decodes the JSON from the content variable and returns it.
415*4882a593Smuzhiyun
416*4882a593Smuzhiyun  You don't really need to use it, but you can in case you want to write your own extension implementation to MetaCPAN::API.
417*4882a593Smuzhiyun
418*4882a593Smuzhiyun  It accepts an additional hash as "GET" parameters.
419*4882a593Smuzhiyun
420*4882a593Smuzhiyun  =head2 post
421*4882a593Smuzhiyun
422*4882a593Smuzhiyun      # /release&content={"query":{"match_all":{}},"filter":{"prefix":{"archive":"Cache-Cache-1.06"}}}
423*4882a593Smuzhiyun      my $result = $mcpan->post(
424*4882a593Smuzhiyun          'release',
425*4882a593Smuzhiyun          {
426*4882a593Smuzhiyun              query  => { match_all => {} },
427*4882a593Smuzhiyun              filter => { prefix => { archive => 'Cache-Cache-1.06' } },
428*4882a593Smuzhiyun          },
429*4882a593Smuzhiyun      );
430*4882a593Smuzhiyun
431*4882a593Smuzhiyun  The POST equivalent of the "fetch()" method. It gets the path and JSON request.
432*4882a593Smuzhiyun
433*4882a593Smuzhiyun  =head1 THANKS
434*4882a593Smuzhiyun
435*4882a593Smuzhiyun  Overall the tests and code were ripped directly from MetaCPAN::API and
436*4882a593Smuzhiyun  tiny-fied. A big thanks to Sawyer X for writing the original module.
437*4882a593Smuzhiyun
438*4882a593Smuzhiyun  =head1 AUTHOR
439*4882a593Smuzhiyun
440*4882a593Smuzhiyun  Nicholas R. Perez <nperez@cpan.org>
441*4882a593Smuzhiyun
442*4882a593Smuzhiyun  =head1 COPYRIGHT AND LICENSE
443*4882a593Smuzhiyun
444*4882a593Smuzhiyun  This software is copyright (c) 2013 by Nicholas R. Perez <nperez@cpan.org>.
445*4882a593Smuzhiyun
446*4882a593Smuzhiyun  This is free software; you can redistribute it and/or modify it under
447*4882a593Smuzhiyun  the same terms as the Perl 5 programming language system itself.
448*4882a593Smuzhiyun
449*4882a593Smuzhiyun  =cut
450*4882a593SmuzhiyunMETACPAN_API_TINY
451*4882a593Smuzhiyun
452*4882a593Smuzhiyuns/^  //mg for values %fatpacked;
453*4882a593Smuzhiyun
454*4882a593Smuzhiyununshift @INC, sub {
455*4882a593Smuzhiyun  if (my $fat = $fatpacked{$_[1]}) {
456*4882a593Smuzhiyun    if ($] < 5.008) {
457*4882a593Smuzhiyun      return sub {
458*4882a593Smuzhiyun        return 0 unless length $fat;
459*4882a593Smuzhiyun        $fat =~ s/^([^\n]*\n?)//;
460*4882a593Smuzhiyun        $_ = $1;
461*4882a593Smuzhiyun        return 1;
462*4882a593Smuzhiyun      };
463*4882a593Smuzhiyun    }
464*4882a593Smuzhiyun    open my $fh, '<', \$fat
465*4882a593Smuzhiyun      or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
466*4882a593Smuzhiyun    return $fh;
467*4882a593Smuzhiyun  }
468*4882a593Smuzhiyun  return
469*4882a593Smuzhiyun};
470*4882a593Smuzhiyun
471*4882a593Smuzhiyun} # END OF FATPACK CODE
472*4882a593Smuzhiyun
473*4882a593Smuzhiyun
474*4882a593Smuzhiyunuse 5.010;
475*4882a593Smuzhiyunuse strict;
476*4882a593Smuzhiyunuse warnings;
477*4882a593Smuzhiyunuse Fatal qw(open close);
478*4882a593Smuzhiyun
479*4882a593Smuzhiyunuse Getopt::Long;
480*4882a593Smuzhiyunuse Pod::Usage;
481*4882a593Smuzhiyunuse File::Basename;
482*4882a593Smuzhiyunuse File::Path qw(make_path);
483*4882a593Smuzhiyunuse Module::CoreList;
484*4882a593Smuzhiyunuse HTTP::Tiny;
485*4882a593Smuzhiyunuse Safe;
486*4882a593Smuzhiyunuse MetaCPAN::API::Tiny;
487*4882a593Smuzhiyunuse Digest::SHA qw(sha256_hex);
488*4882a593Smuzhiyunuse Text::Wrap;
489*4882a593Smuzhiyun$Text::Wrap::columns = 62;
490*4882a593Smuzhiyun
491*4882a593Smuzhiyun# Below, 5.032 should be aligned with the version of perl actually
492*4882a593Smuzhiyun# bundled in Buildroot:
493*4882a593Smuzhiyundie <<"MSG" if $] < 5.032;
494*4882a593SmuzhiyunThis script needs a host perl with the same major version as Buildroot target perl.
495*4882a593Smuzhiyun
496*4882a593SmuzhiyunYour current host perl is:
497*4882a593Smuzhiyun    $^X
498*4882a593Smuzhiyun    version $]
499*4882a593Smuzhiyun
500*4882a593SmuzhiyunYou may install a local one by running:
501*4882a593Smuzhiyun    perlbrew install perl-5.32.0
502*4882a593SmuzhiyunMSG
503*4882a593Smuzhiyun
504*4882a593Smuzhiyunmy ($help, $man, $quiet, $force, $recommend, $test, $host);
505*4882a593Smuzhiyunmy $target = 1;
506*4882a593SmuzhiyunGetOptions( 'help|?' => \$help,
507*4882a593Smuzhiyun            'man' => \$man,
508*4882a593Smuzhiyun            'quiet|q' => \$quiet,
509*4882a593Smuzhiyun            'force|f' => \$force,
510*4882a593Smuzhiyun            'host!' => \$host,
511*4882a593Smuzhiyun            'target!' => \$target,
512*4882a593Smuzhiyun            'recommend' => \$recommend,
513*4882a593Smuzhiyun            'test' => \$test
514*4882a593Smuzhiyun) or pod2usage(-exitval => 1);
515*4882a593Smuzhiyunpod2usage(-exitval => 0) if $help;
516*4882a593Smuzhiyunpod2usage(-exitval => 0, -verbose => 2) if $man;
517*4882a593Smuzhiyunpod2usage(-exitval => 1) if scalar @ARGV == 0;
518*4882a593Smuzhiyun
519*4882a593Smuzhiyunmy %dist;               # name -> metacpan data
520*4882a593Smuzhiyunmy %need_target;        # name -> 1 if target package is needed
521*4882a593Smuzhiyunmy %need_host;          # name -> 1 if host package is needed
522*4882a593Smuzhiyunmy %need_dlopen;        # name -> 1 if requires dynamic library
523*4882a593Smuzhiyunmy %is_xs;              # name -> 1 if XS module
524*4882a593Smuzhiyunmy %deps_build;         # name -> list of host dependencies
525*4882a593Smuzhiyunmy %deps_runtime;       # name -> list of target dependencies
526*4882a593Smuzhiyunmy %license_files;      # name -> hash of license files
527*4882a593Smuzhiyunmy %checksum;           # author -> list of checksum
528*4882a593Smuzhiyunmy $mirror = 'http://cpan.metacpan.org';        # a CPAN mirror
529*4882a593Smuzhiyunmy $mcpan = MetaCPAN::API::Tiny->new(base_url => 'http://fastapi.metacpan.org/v1');
530*4882a593Smuzhiyunmy $ua = HTTP::Tiny->new();
531*4882a593Smuzhiyunmy $new_pkgs;
532*4882a593Smuzhiyun
533*4882a593Smuzhiyunmy %white_list = (
534*4882a593Smuzhiyun    'ExtUtils-Config' => 1,
535*4882a593Smuzhiyun    'ExtUtils-InstallPaths' => 1,
536*4882a593Smuzhiyun    'ExtUtils-Helpers' => 1,
537*4882a593Smuzhiyun    'File-ShareDir-Install' => 1,
538*4882a593Smuzhiyun    'Module-Build' => 1,
539*4882a593Smuzhiyun    'Module-Build-Tiny' => 1,
540*4882a593Smuzhiyun);
541*4882a593Smuzhiyunmy @info = ();
542*4882a593Smuzhiyun
543*4882a593Smuzhiyunsub get_checksum {
544*4882a593Smuzhiyun    my ($url) = @_;
545*4882a593Smuzhiyun    my ($path) = $url =~ m|^[^:/?#]+://[^/?#]*([^?#]*)|;
546*4882a593Smuzhiyun    my ($basename, $dirname) = fileparse( $path );
547*4882a593Smuzhiyun    unless ($checksum{$dirname}) {
548*4882a593Smuzhiyun        my $url = $mirror . $dirname . q{CHECKSUMS};
549*4882a593Smuzhiyun        my $response = $ua->get($url);
550*4882a593Smuzhiyun        $checksum{$dirname} = $response->{content};
551*4882a593Smuzhiyun    }
552*4882a593Smuzhiyun    my $chksum = Safe->new->reval($checksum{$dirname});
553*4882a593Smuzhiyun    return $chksum->{$basename}, $basename;
554*4882a593Smuzhiyun}
555*4882a593Smuzhiyun
556*4882a593Smuzhiyunsub is_xs {
557*4882a593Smuzhiyun    my ($manifest) = @_;
558*4882a593Smuzhiyun    # This heuristic determines if a module is a native extension, by searching
559*4882a593Smuzhiyun    # some file extension types in the MANIFEST of the distribution.
560*4882a593Smuzhiyun    # It was inspired by http://deps.cpantesters.org/static/purity.html
561*4882a593Smuzhiyun    return $manifest =~ m/\.(swg|xs|c|h|i)[\n\s]/;
562*4882a593Smuzhiyun}
563*4882a593Smuzhiyun
564*4882a593Smuzhiyunsub find_license_files {
565*4882a593Smuzhiyun    my ($manifest) = @_;
566*4882a593Smuzhiyun    my @license_files;
567*4882a593Smuzhiyun    foreach (split /\n/, $manifest) {
568*4882a593Smuzhiyun        next if m|/|;
569*4882a593Smuzhiyun        s|\s+.*$||;
570*4882a593Smuzhiyun        push @license_files, $_ if m/(ARTISTIC|COPYING|COPYRIGHT|GPL\S*|LICENSE|LICENCE)/i;
571*4882a593Smuzhiyun    }
572*4882a593Smuzhiyun    if (scalar @license_files == 0 && $manifest =~ m/(README)[\n\s]/i) {
573*4882a593Smuzhiyun        @license_files = ($1);
574*4882a593Smuzhiyun    }
575*4882a593Smuzhiyun    if (scalar @license_files == 0 && $manifest =~ m/(README\.md)[\n\s]/i) {
576*4882a593Smuzhiyun        @license_files = ($1);
577*4882a593Smuzhiyun    }
578*4882a593Smuzhiyun    if (scalar @license_files == 0 && $manifest =~ m/(README\.pod)[\n\s]/i) {
579*4882a593Smuzhiyun        @license_files = ($1);
580*4882a593Smuzhiyun    }
581*4882a593Smuzhiyun    return @license_files;
582*4882a593Smuzhiyun}
583*4882a593Smuzhiyun
584*4882a593Smuzhiyunsub want_test {
585*4882a593Smuzhiyun    my ($distname) = @_;
586*4882a593Smuzhiyun    return 1 if $need_dlopen{$distname} && scalar @{$deps_runtime{$distname}} > 0;
587*4882a593Smuzhiyun}
588*4882a593Smuzhiyun
589*4882a593Smuzhiyunsub get_dependencies {
590*4882a593Smuzhiyun    my ($distname) = @_;
591*4882a593Smuzhiyun    my %dep = map { $_ => 1 } @{$deps_runtime{$distname}};
592*4882a593Smuzhiyun    for my $direct (@{$deps_runtime{$distname}}) {
593*4882a593Smuzhiyun        for (get_dependencies( $direct )) {
594*4882a593Smuzhiyun            $dep{$_} = 1;
595*4882a593Smuzhiyun        }
596*4882a593Smuzhiyun    }
597*4882a593Smuzhiyun    return keys %dep;
598*4882a593Smuzhiyun}
599*4882a593Smuzhiyun
600*4882a593Smuzhiyunsub get_indirect_dependencies {
601*4882a593Smuzhiyun    my ($distname) = @_;
602*4882a593Smuzhiyun    my %indirect;
603*4882a593Smuzhiyun    my %direct = map { $_ => 1 } @{$deps_runtime{$distname}};
604*4882a593Smuzhiyun    for my $dep (get_dependencies( $distname )) {
605*4882a593Smuzhiyun        $indirect{$dep} = 1 unless exists $direct{$dep};
606*4882a593Smuzhiyun    }
607*4882a593Smuzhiyun    return keys %indirect;
608*4882a593Smuzhiyun}
609*4882a593Smuzhiyun
610*4882a593Smuzhiyunsub fetch {
611*4882a593Smuzhiyun    my ($name, $need_target, $need_host, $top) = @_;
612*4882a593Smuzhiyun    $need_target{$name} = $need_target if $need_target;
613*4882a593Smuzhiyun    $need_host{$name} = $need_host if $need_host;
614*4882a593Smuzhiyun    unless ($dist{$name} && !$top) {
615*4882a593Smuzhiyun        say qq{fetch ${name}} unless $quiet;
616*4882a593Smuzhiyun        my $result = $mcpan->release( distribution => $name );
617*4882a593Smuzhiyun        my $main_module = $result->{main_module};
618*4882a593Smuzhiyun        push @info, qq{[$name] $main_module is a core module}
619*4882a593Smuzhiyun            if $top && Module::CoreList::is_core( $main_module, undef, $] );
620*4882a593Smuzhiyun        $dist{$name} = $result;
621*4882a593Smuzhiyun        $license_files{$name} = {};
622*4882a593Smuzhiyun        eval {
623*4882a593Smuzhiyun            my $author = $result->{author};
624*4882a593Smuzhiyun            my $release = $name . q{-} . $result->{version};
625*4882a593Smuzhiyun            my $manifest = $mcpan->source( author => $author, release => $release, path => 'MANIFEST' );
626*4882a593Smuzhiyun            $need_dlopen{$name} = $is_xs{$name} = is_xs( $manifest );
627*4882a593Smuzhiyun            foreach my $fname (find_license_files( $manifest )) {
628*4882a593Smuzhiyun                my $license = $mcpan->source( author => $author, release => $release, path => $fname );
629*4882a593Smuzhiyun                $license_files{$name}->{$fname} = sha256_hex( $license );
630*4882a593Smuzhiyun            }
631*4882a593Smuzhiyun        };
632*4882a593Smuzhiyun        if ($@) {
633*4882a593Smuzhiyun            warn $@;
634*4882a593Smuzhiyun        }
635*4882a593Smuzhiyun        my %build = ();
636*4882a593Smuzhiyun        my %runtime = ();
637*4882a593Smuzhiyun        my %optional = ();
638*4882a593Smuzhiyun        foreach my $dep (@{$result->{dependency}}) {
639*4882a593Smuzhiyun            my $modname = ${$dep}{module};
640*4882a593Smuzhiyun            next if $modname eq q{perl};
641*4882a593Smuzhiyun            next if $modname =~ m|^Alien|;
642*4882a593Smuzhiyun            next if $modname =~ m|^Win32|;
643*4882a593Smuzhiyun            next if !($test && $top) && $modname =~ m|^Test|;
644*4882a593Smuzhiyun            next if Module::CoreList::is_core( $modname, undef, $] );
645*4882a593Smuzhiyun            # we could use the host Module::CoreList data, because host perl and
646*4882a593Smuzhiyun            # target perl have the same major version
647*4882a593Smuzhiyun            next if ${$dep}{phase} eq q{develop};
648*4882a593Smuzhiyun            next if ${$dep}{phase} eq q{x_Dist_Zilla};
649*4882a593Smuzhiyun            next if !($test && $top) && ${$dep}{phase} eq q{test};
650*4882a593Smuzhiyun            my $distname = $mcpan->module( $modname )->{distribution};
651*4882a593Smuzhiyun            if (${$dep}{phase} eq q{runtime}) {
652*4882a593Smuzhiyun                if (${$dep}{relationship} eq q{requires}) {
653*4882a593Smuzhiyun                    $runtime{$distname} = 1;
654*4882a593Smuzhiyun                }
655*4882a593Smuzhiyun                else {
656*4882a593Smuzhiyun                    $optional{$distname} = 1 if $recommend && $top;
657*4882a593Smuzhiyun                }
658*4882a593Smuzhiyun            }
659*4882a593Smuzhiyun            else { # configure, build
660*4882a593Smuzhiyun                $build{$distname} = 1;
661*4882a593Smuzhiyun                push @info, qq{[$name] suspicious dependency on $distname}
662*4882a593Smuzhiyun                    unless exists $white_list{$distname};
663*4882a593Smuzhiyun            }
664*4882a593Smuzhiyun        }
665*4882a593Smuzhiyun        $deps_build{$name} = [keys %build];
666*4882a593Smuzhiyun        $deps_runtime{$name} = [keys %runtime];
667*4882a593Smuzhiyun        foreach my $distname (@{$deps_build{$name}}) {
668*4882a593Smuzhiyun            fetch( $distname, 0, 1 );
669*4882a593Smuzhiyun        }
670*4882a593Smuzhiyun        foreach my $distname (@{$deps_runtime{$name}}) {
671*4882a593Smuzhiyun            fetch( $distname, $need_target, $need_host );
672*4882a593Smuzhiyun            $need_dlopen{$name} ||= $need_dlopen{$distname};
673*4882a593Smuzhiyun        }
674*4882a593Smuzhiyun        foreach my $distname (keys %optional) {
675*4882a593Smuzhiyun            fetch( $distname, $need_target, $need_host );
676*4882a593Smuzhiyun        }
677*4882a593Smuzhiyun    }
678*4882a593Smuzhiyun    return;
679*4882a593Smuzhiyun}
680*4882a593Smuzhiyun
681*4882a593Smuzhiyunforeach my $distname (@ARGV) {
682*4882a593Smuzhiyun    # Command-line's distributions
683*4882a593Smuzhiyun    fetch( $distname, !!$target, !!$host, 1 );
684*4882a593Smuzhiyun}
685*4882a593Smuzhiyunsay scalar keys %dist, q{ packages fetched.} unless $quiet;
686*4882a593Smuzhiyun
687*4882a593Smuzhiyun# Buildroot package name: lowercase
688*4882a593Smuzhiyunsub fsname {
689*4882a593Smuzhiyun    my $name = shift;
690*4882a593Smuzhiyun    $name =~ s|_|-|g;
691*4882a593Smuzhiyun    return q{perl-} . lc $name;
692*4882a593Smuzhiyun}
693*4882a593Smuzhiyun
694*4882a593Smuzhiyun# Buildroot variable name: uppercase
695*4882a593Smuzhiyunsub brname {
696*4882a593Smuzhiyun    my $name = shift;
697*4882a593Smuzhiyun    $name =~ s|-|_|g;
698*4882a593Smuzhiyun    return uc $name;
699*4882a593Smuzhiyun}
700*4882a593Smuzhiyun
701*4882a593Smuzhiyun# Buildroot requires license name as in http://spdx.org/licenses/
702*4882a593Smuzhiyunsub brlicense {
703*4882a593Smuzhiyun    my $license = shift;
704*4882a593Smuzhiyun    $license =~ s|apache_1_1|Apache-1.1|;
705*4882a593Smuzhiyun    $license =~ s|apache_2_0|Apache-2.0|;
706*4882a593Smuzhiyun    $license =~ s|artistic_2|Artistic-2.0|;
707*4882a593Smuzhiyun    $license =~ s|artistic|Artistic-1.0|;
708*4882a593Smuzhiyun    $license =~ s|lgpl_2_1|LGPL-2.1|;
709*4882a593Smuzhiyun    $license =~ s|lgpl_3_0|LGPL-3.0|;
710*4882a593Smuzhiyun    $license =~ s|gpl_2|GPL-2.0|;
711*4882a593Smuzhiyun    $license =~ s|gpl_3|GPL-3.0|;
712*4882a593Smuzhiyun    $license =~ s|mit|MIT|;
713*4882a593Smuzhiyun    $license =~ s|mozilla_1_1|Mozilla-1.1|;
714*4882a593Smuzhiyun    $license =~ s|openssl|OpenSSL|;
715*4882a593Smuzhiyun    $license =~ s|perl_5|Artistic or GPL-1.0+|;
716*4882a593Smuzhiyun    return $license;
717*4882a593Smuzhiyun}
718*4882a593Smuzhiyun
719*4882a593Smuzhiyunwhile (my ($distname, $dist) = each %dist) {
720*4882a593Smuzhiyun    my $fsname = fsname( $distname );
721*4882a593Smuzhiyun    my $dirname = q{package/} . $fsname;
722*4882a593Smuzhiyun    my $cfgname = $dirname . q{/Config.in};
723*4882a593Smuzhiyun    my $mkname = $dirname . q{/} . $fsname . q{.mk};
724*4882a593Smuzhiyun    my $hashname = $dirname . q{/} . $fsname . q{.hash};
725*4882a593Smuzhiyun    my $brname = brname( $fsname );
726*4882a593Smuzhiyun    my $testdir = q{support/testing/tests/package};
727*4882a593Smuzhiyun    my $testname = $testdir . q{/test_} . lc $brname . q{.py};
728*4882a593Smuzhiyun    unless (-d $dirname) {
729*4882a593Smuzhiyun        make_path $dirname;
730*4882a593Smuzhiyun        $new_pkgs = 1;
731*4882a593Smuzhiyun    }
732*4882a593Smuzhiyun    if ($need_target{$distname} && ($force || !-f $cfgname)) {
733*4882a593Smuzhiyun        $dist->{abstract} =~ s|\s+$||;
734*4882a593Smuzhiyun        $dist->{abstract} .= q{.} unless $dist->{abstract} =~ m|\.$|;
735*4882a593Smuzhiyun        my $abstract = wrap( q{}, qq{\t  }, $dist->{abstract} );
736*4882a593Smuzhiyun        my $homepage = $dist->{resources}->{homepage} || qq{https://metacpan.org/release/${distname}};
737*4882a593Smuzhiyun        say qq{write ${cfgname}} unless $quiet;
738*4882a593Smuzhiyun        open my $fh, q{>}, $cfgname;
739*4882a593Smuzhiyun        say {$fh} qq{config BR2_PACKAGE_${brname}};
740*4882a593Smuzhiyun        say {$fh} qq{\tbool "${fsname}"};
741*4882a593Smuzhiyun        say {$fh} qq{\tdepends on !BR2_STATIC_LIBS} if $need_dlopen{$distname};
742*4882a593Smuzhiyun        foreach my $dep (sort @{$deps_runtime{$distname}}) {
743*4882a593Smuzhiyun            my $brdep = brname( fsname( $dep ) );
744*4882a593Smuzhiyun            say {$fh} qq{\tselect BR2_PACKAGE_${brdep} # runtime};
745*4882a593Smuzhiyun        }
746*4882a593Smuzhiyun        say {$fh} qq{\thelp};
747*4882a593Smuzhiyun        say {$fh} qq{\t  ${abstract}\n} if $abstract;
748*4882a593Smuzhiyun        say {$fh} qq{\t  ${homepage}};
749*4882a593Smuzhiyun        if ($need_dlopen{$distname}) {
750*4882a593Smuzhiyun            say {$fh} qq{\ncomment "${fsname} needs a toolchain w/ dynamic library"};
751*4882a593Smuzhiyun            say {$fh} qq{\tdepends on BR2_STATIC_LIBS};
752*4882a593Smuzhiyun        }
753*4882a593Smuzhiyun        close $fh;
754*4882a593Smuzhiyun    }
755*4882a593Smuzhiyun    if ($force || !-f $mkname) {
756*4882a593Smuzhiyun        my $version = $dist->{version};
757*4882a593Smuzhiyun        my ($path) = $dist->{download_url} =~ m|^[^:/?#]+://[^/?#]*([^?#]*)|;
758*4882a593Smuzhiyun        # this URL contains only the scheme, auth and path parts (but no query and fragment parts)
759*4882a593Smuzhiyun        # the scheme is not used, because the job is done by the BR download infrastructure
760*4882a593Smuzhiyun        # the auth part is not used, because we use $(BR2_CPAN_MIRROR)
761*4882a593Smuzhiyun        my ($filename, $directories, $suffix) = fileparse( $path, q{tar.gz}, q{tgz} );
762*4882a593Smuzhiyun        $directories =~ s|/$||;
763*4882a593Smuzhiyun        my @dependencies = map( { q{host-} . fsname( $_ ); } sort @{$deps_build{$distname}} );
764*4882a593Smuzhiyun        my $dependencies = join qq{ \\\n\t}, @dependencies;
765*4882a593Smuzhiyun        $dependencies = qq{\\\n\t} . $dependencies if scalar @dependencies > 1;
766*4882a593Smuzhiyun        my @host_dependencies = map { q{host-} . fsname( $_ ); } sort( @{$deps_build{$distname}},
767*4882a593Smuzhiyun                                                                       @{$deps_runtime{$distname}} );
768*4882a593Smuzhiyun        my $host_dependencies = join qq{ \\\n\t}, @host_dependencies;
769*4882a593Smuzhiyun        $host_dependencies = qq{\\\n\t} . $host_dependencies if scalar @host_dependencies > 1;
770*4882a593Smuzhiyun        my $license = brlicense( ref $dist->{license} eq 'ARRAY'
771*4882a593Smuzhiyun                               ? join q{ or }, @{$dist->{license}}
772*4882a593Smuzhiyun                               : $dist->{license} );
773*4882a593Smuzhiyun        my $license_files = join q{ }, sort keys %{$license_files{$distname}};
774*4882a593Smuzhiyun        if ($license_files && (!$license || $license eq q{unknown})) {
775*4882a593Smuzhiyun            push @info, qq{[$distname] undefined LICENSE, see $license_files};
776*4882a593Smuzhiyun            $license = q{???};
777*4882a593Smuzhiyun        }
778*4882a593Smuzhiyun        say qq{write ${mkname}} unless $quiet;
779*4882a593Smuzhiyun        open my $fh, q{>}, $mkname;
780*4882a593Smuzhiyun        say {$fh} qq{################################################################################};
781*4882a593Smuzhiyun        say {$fh} qq{#};
782*4882a593Smuzhiyun        say {$fh} qq{# ${fsname}};
783*4882a593Smuzhiyun        say {$fh} qq{#};
784*4882a593Smuzhiyun        say {$fh} qq{################################################################################};
785*4882a593Smuzhiyun        say {$fh} qq{};
786*4882a593Smuzhiyun        say {$fh} qq{${brname}_VERSION = ${version}};
787*4882a593Smuzhiyun        say {$fh} qq{${brname}_SOURCE = ${distname}-\$(${brname}_VERSION).${suffix}};
788*4882a593Smuzhiyun        say {$fh} qq{${brname}_SITE = \$(BR2_CPAN_MIRROR)${directories}};
789*4882a593Smuzhiyun        say {$fh} qq{${brname}_DEPENDENCIES = ${dependencies}} if $need_target{$distname} && $dependencies;
790*4882a593Smuzhiyun        say {$fh} qq{HOST_${brname}_DEPENDENCIES = ${host_dependencies}} if $need_host{$distname} && $host_dependencies;
791*4882a593Smuzhiyun        say {$fh} qq{${brname}_LICENSE = ${license}} if $license;
792*4882a593Smuzhiyun        say {$fh} qq{${brname}_LICENSE_FILES = ${license_files}} if $license_files;
793*4882a593Smuzhiyun        say {$fh} qq{${brname}_DISTNAME = ${distname}};
794*4882a593Smuzhiyun        say {$fh} qq{};
795*4882a593Smuzhiyun        say {$fh} qq{\$(eval \$(perl-package))} if $need_target{$distname};
796*4882a593Smuzhiyun        say {$fh} qq{\$(eval \$(host-perl-package))} if $need_host{$distname};
797*4882a593Smuzhiyun        close $fh;
798*4882a593Smuzhiyun    }
799*4882a593Smuzhiyun    if ($force || !-f $hashname) {
800*4882a593Smuzhiyun        my ($checksum, $filename) = get_checksum($dist->{download_url});
801*4882a593Smuzhiyun        my $md5 = $checksum->{md5};
802*4882a593Smuzhiyun        my $sha256 = $checksum->{sha256};
803*4882a593Smuzhiyun        say qq{write ${hashname}} unless $quiet;
804*4882a593Smuzhiyun        open my $fh, q{>}, $hashname;
805*4882a593Smuzhiyun        say {$fh} qq{# retrieved by scancpan from ${mirror}/};
806*4882a593Smuzhiyun        say {$fh} qq{md5  ${md5}  ${filename}};
807*4882a593Smuzhiyun        say {$fh} qq{sha256  ${sha256}  ${filename}};
808*4882a593Smuzhiyun        my %license_files =  %{$license_files{$distname}};
809*4882a593Smuzhiyun        if (scalar keys %license_files) {
810*4882a593Smuzhiyun            say {$fh} q{};
811*4882a593Smuzhiyun            say {$fh} qq{# computed by scancpan};
812*4882a593Smuzhiyun            foreach my $license (sort keys %license_files) {
813*4882a593Smuzhiyun                my $digest = $license_files{$license};
814*4882a593Smuzhiyun                say {$fh} qq{sha256  ${digest}  ${license}};
815*4882a593Smuzhiyun            }
816*4882a593Smuzhiyun        }
817*4882a593Smuzhiyun        close $fh;
818*4882a593Smuzhiyun    }
819*4882a593Smuzhiyun    if (want_test( $distname ) && ($force || !-f $testname)) {
820*4882a593Smuzhiyun        my $classname = $distname;
821*4882a593Smuzhiyun        $classname =~ s|-||g;
822*4882a593Smuzhiyun        my $modname = $distname;
823*4882a593Smuzhiyun        $modname =~ s|-|::|g;
824*4882a593Smuzhiyun        my $mark = $is_xs{$distname} ? q{   XS} : q{};
825*4882a593Smuzhiyun        my @indirect = (get_indirect_dependencies( $distname ));
826*4882a593Smuzhiyun        say qq{write ${testname}} unless $quiet;
827*4882a593Smuzhiyun        make_path $testdir unless -d $testdir;
828*4882a593Smuzhiyun        open my $fh, q{>}, $testname;
829*4882a593Smuzhiyun        say {$fh} qq{from tests.package.test_perl import TestPerlBase};
830*4882a593Smuzhiyun        say {$fh} qq{};
831*4882a593Smuzhiyun        say {$fh} qq{};
832*4882a593Smuzhiyun        say {$fh} qq{class TestPerl${classname}(TestPerlBase):};
833*4882a593Smuzhiyun        say {$fh} qq{    """};
834*4882a593Smuzhiyun        say {$fh} qq{    package:};
835*4882a593Smuzhiyun        say {$fh} qq{        ${distname}${mark}};
836*4882a593Smuzhiyun        say {$fh} qq{    direct dependencies:};
837*4882a593Smuzhiyun        foreach my $dep (sort @{$deps_runtime{$distname}}) {
838*4882a593Smuzhiyun            $mark = $is_xs{$dep} ? q{   XS} : q{};
839*4882a593Smuzhiyun            say {$fh} qq{        ${dep}${mark}};
840*4882a593Smuzhiyun        }
841*4882a593Smuzhiyun        if (scalar @indirect > 0) {
842*4882a593Smuzhiyun            say {$fh} qq{    indirect dependencies:};
843*4882a593Smuzhiyun            foreach my $dep (sort @indirect) {
844*4882a593Smuzhiyun                $mark = $is_xs{$dep} ? q{   XS} : q{};
845*4882a593Smuzhiyun                say {$fh} qq{        ${dep}${mark}};
846*4882a593Smuzhiyun            }
847*4882a593Smuzhiyun        }
848*4882a593Smuzhiyun        say {$fh} qq{    """};
849*4882a593Smuzhiyun        say {$fh} qq{};
850*4882a593Smuzhiyun        say {$fh} qq{    config = TestPerlBase.config + \\};
851*4882a593Smuzhiyun        say {$fh} qq{        """};
852*4882a593Smuzhiyun        say {$fh} qq{        BR2_PACKAGE_PERL=y};
853*4882a593Smuzhiyun        say {$fh} qq{        BR2_PACKAGE_${brname}=y};
854*4882a593Smuzhiyun        say {$fh} qq{        """};
855*4882a593Smuzhiyun        say {$fh} qq{};
856*4882a593Smuzhiyun        say {$fh} qq{    def test_run(self):};
857*4882a593Smuzhiyun        say {$fh} qq{        self.login()};
858*4882a593Smuzhiyun        foreach my $dep (sort grep { $is_xs{$_} } @indirect) {
859*4882a593Smuzhiyun            $dep =~ s|-|::|g;
860*4882a593Smuzhiyun            say {$fh} qq{        self.module_test("${dep}")};
861*4882a593Smuzhiyun        }
862*4882a593Smuzhiyun        foreach my $dep (sort grep { $is_xs{$_} } @{$deps_runtime{$distname}}) {
863*4882a593Smuzhiyun            $dep =~ s|-|::|g;
864*4882a593Smuzhiyun            say {$fh} qq{        self.module_test("${dep}")};
865*4882a593Smuzhiyun        }
866*4882a593Smuzhiyun        say {$fh} qq{        self.module_test("${modname}")};
867*4882a593Smuzhiyun        close $fh;
868*4882a593Smuzhiyun    }
869*4882a593Smuzhiyun}
870*4882a593Smuzhiyun
871*4882a593Smuzhiyunif ($new_pkgs) {
872*4882a593Smuzhiyun    my %pkg;
873*4882a593Smuzhiyun    my $cfgname = q{package/Config.in};
874*4882a593Smuzhiyun    if (-f $cfgname) {
875*4882a593Smuzhiyun        open my $fh, q{<}, $cfgname;
876*4882a593Smuzhiyun        while (<$fh>) {
877*4882a593Smuzhiyun            chomp;
878*4882a593Smuzhiyun            $pkg{$_} = 1 if m|package/perl-|;
879*4882a593Smuzhiyun        }
880*4882a593Smuzhiyun        close $fh;
881*4882a593Smuzhiyun    }
882*4882a593Smuzhiyun
883*4882a593Smuzhiyun    foreach my $distname (keys %need_target) {
884*4882a593Smuzhiyun        my $fsname = fsname( $distname );
885*4882a593Smuzhiyun        $pkg{qq{\tsource "package/${fsname}/Config.in"}} = 1;
886*4882a593Smuzhiyun    }
887*4882a593Smuzhiyun
888*4882a593Smuzhiyun    say qq{${cfgname} must contain the following lines:};
889*4882a593Smuzhiyun    say join qq{\n}, sort keys %pkg;
890*4882a593Smuzhiyun}
891*4882a593Smuzhiyun
892*4882a593Smuzhiyunsay join qq{\n}, @info;
893*4882a593Smuzhiyun
894*4882a593Smuzhiyun__END__
895*4882a593Smuzhiyun
896*4882a593Smuzhiyun=head1 NAME
897*4882a593Smuzhiyun
898*4882a593Smuzhiyunutils/scancpan Try-Tiny Moo
899*4882a593Smuzhiyun
900*4882a593Smuzhiyun=head1 SYNOPSIS
901*4882a593Smuzhiyun
902*4882a593Smuzhiyunutils/scancpan [options] [distname ...]
903*4882a593Smuzhiyun
904*4882a593Smuzhiyun Options:
905*4882a593Smuzhiyun   -help
906*4882a593Smuzhiyun   -man
907*4882a593Smuzhiyun   -quiet
908*4882a593Smuzhiyun   -force
909*4882a593Smuzhiyun   -target/-notarget
910*4882a593Smuzhiyun   -host/-nohost
911*4882a593Smuzhiyun   -recommend
912*4882a593Smuzhiyun   -test
913*4882a593Smuzhiyun
914*4882a593Smuzhiyun=head1 OPTIONS
915*4882a593Smuzhiyun
916*4882a593Smuzhiyun=over 8
917*4882a593Smuzhiyun
918*4882a593Smuzhiyun=item B<-help>
919*4882a593Smuzhiyun
920*4882a593SmuzhiyunPrints a brief help message and exits.
921*4882a593Smuzhiyun
922*4882a593Smuzhiyun=item B<-man>
923*4882a593Smuzhiyun
924*4882a593SmuzhiyunPrints the manual page and exits.
925*4882a593Smuzhiyun
926*4882a593Smuzhiyun=item B<-quiet>
927*4882a593Smuzhiyun
928*4882a593SmuzhiyunExecutes without output
929*4882a593Smuzhiyun
930*4882a593Smuzhiyun=item B<-force>
931*4882a593Smuzhiyun
932*4882a593SmuzhiyunForces the overwriting of existing files.
933*4882a593Smuzhiyun
934*4882a593Smuzhiyun=item B<-target/-notarget>
935*4882a593Smuzhiyun
936*4882a593SmuzhiyunSwitches package generation for the target variant (the default is C<-target>).
937*4882a593Smuzhiyun
938*4882a593Smuzhiyun=item B<-host/-nohost>
939*4882a593Smuzhiyun
940*4882a593SmuzhiyunSwitches package generation for the host variant (the default is C<-nohost>).
941*4882a593Smuzhiyun
942*4882a593Smuzhiyun=item B<-recommend>
943*4882a593Smuzhiyun
944*4882a593SmuzhiyunAdds I<recommended> dependencies.
945*4882a593Smuzhiyun
946*4882a593Smuzhiyun=item B<-test>
947*4882a593Smuzhiyun
948*4882a593SmuzhiyunAdds dependencies for test.
949*4882a593Smuzhiyun
950*4882a593Smuzhiyun=back
951*4882a593Smuzhiyun
952*4882a593Smuzhiyun=head1 DESCRIPTION
953*4882a593Smuzhiyun
954*4882a593SmuzhiyunThis script creates templates of the Buildroot package files for all the
955*4882a593SmuzhiyunPerl/CPAN distributions required by the specified distnames. The
956*4882a593Smuzhiyundependencies and metadata are fetched from https://metacpan.org/.
957*4882a593Smuzhiyun
958*4882a593SmuzhiyunAfter running this script, it is necessary to check the generated files.
959*4882a593SmuzhiyunFor distributions that link against a target library, you have to add the
960*4882a593Smuzhiyunbuildroot package name for that library to the DEPENDENCIES variable.
961*4882a593Smuzhiyun
962*4882a593SmuzhiyunSee the Buildroot documentation for details on the usage of the Perl
963*4882a593Smuzhiyuninfrastructure.
964*4882a593Smuzhiyun
965*4882a593SmuzhiyunThe major version of the host perl must be aligned on the target one,
966*4882a593Smuzhiyunin order to work with the right CoreList data.
967*4882a593Smuzhiyun
968*4882a593Smuzhiyun=head1 LICENSE
969*4882a593Smuzhiyun
970*4882a593SmuzhiyunCopyright (C) 2013-2020 by Francois Perrad <francois.perrad@gadz.org>
971*4882a593Smuzhiyun
972*4882a593SmuzhiyunThis program is free software; you can redistribute it and/or modify
973*4882a593Smuzhiyunit under the terms of the GNU General Public License as published by
974*4882a593Smuzhiyunthe Free Software Foundation; either version 2 of the License, or
975*4882a593Smuzhiyun(at your option) any later version.
976*4882a593Smuzhiyun
977*4882a593SmuzhiyunThis program is distributed in the hope that it will be useful,
978*4882a593Smuzhiyunbut WITHOUT ANY WARRANTY; without even the implied warranty of
979*4882a593SmuzhiyunMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
980*4882a593SmuzhiyunGeneral Public License for more details.
981*4882a593Smuzhiyun
982*4882a593SmuzhiyunYou should have received a copy of the GNU General Public License
983*4882a593Smuzhiyunalong with this program; if not, write to the Free Software
984*4882a593SmuzhiyunFoundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
985*4882a593Smuzhiyun
986*4882a593SmuzhiyunThis script is a part of Buildroot.
987*4882a593Smuzhiyun
988*4882a593SmuzhiyunThis script requires the module C<MetaCPAN::API::Tiny> (version 1.131730)
989*4882a593Smuzhiyunwhich was included at the beginning of this file by the tool C<fatpack>.
990*4882a593Smuzhiyun
991*4882a593SmuzhiyunSee L<https://metacpan.org/release/NPEREZ/MetaCPAN-API-Tiny-1.131730>.
992*4882a593Smuzhiyun
993*4882a593SmuzhiyunSee L<https://metacpan.org/release/App-FatPacker>.
994*4882a593Smuzhiyun
995*4882a593SmuzhiyunThese both libraries are free software and may be distributed under the same
996*4882a593Smuzhiyunterms as perl itself.
997*4882a593Smuzhiyun
998*4882a593SmuzhiyunAnd perl may be distributed under the terms of Artistic v1 or GPL v1 license.
999*4882a593Smuzhiyun
1000*4882a593Smuzhiyun=cut
1001