/[gentoo-perl]/g-cpan/trunk/lib/Gentoo/CPAN.pm
Gentoo

Contents of /g-cpan/trunk/lib/Gentoo/CPAN.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 90 - (show annotations) (download) (as text)
Wed Aug 2 01:27:42 2006 UTC (7 years, 8 months ago) by mcummings
File MIME type: text/x-perl
File size: 18507 byte(s)
Last commit for 0.14.0. 


1 package Gentoo::CPAN;
2
3 use 5.008007;
4 use strict;
5 use warnings;
6 use File::Spec;
7 use CPAN;
8 use File::Path;
9 use YAML;
10 use YAML::Node;
11 use Memoize;
12 use Cwd qw(getcwd abs_path cwd);
13 use File::Basename;
14 use Shell qw(perl);
15
16 memoize('transformCPAN');
17 memoize('FindDeps');
18
19 # These libraries were influenced and largely written by
20 # Christian Hartmann <ian@gentoo.org> originally. All of the good
21 # parts are ian's - the rest is mcummings messing around.
22
23 require Exporter;
24
25 our @ISA = qw(Exporter Gentoo );
26
27 our @EXPORT = qw( getCPANInfo makeCPANstub unpackModule transformCPAN
28 );
29
30 our $VERSION = '0.01';
31
32 ##### CPAN CONFIG #####
33 use constant CPAN_CFG_DIR => '.cpan/CPAN';
34 use constant CPAN_CFG_NAME => 'MyConfig.pm';
35
36 # defaults tools for CPAN Config
37 use constant DEF_FTP_PROG => '/usr/bin/ftp';
38 use constant DEF_GPG_PROG => '/usr/bin/gpg';
39 use constant DEF_GZIP_PROG => '/bin/gzip';
40 use constant DEF_LYNX_PROG => '/usr/bin/lynx';
41 use constant DEF_MAKE_PROG => '/usr/bin/make';
42 use constant DEF_NCFTPGET_PROG => '/usr/bin/ncftpget';
43 use constant DEF_LESS_PROG => '/usr/bin/less';
44 use constant DEF_TAR_PROG => '/bin/tar';
45 use constant DEF_UNZIP_PROG => '/usr/bin/unzip';
46 use constant DEF_WGET_PROG => '/usr/bin/wget';
47 use constant DEF_BASH_PROG => '/bin/bash';
48
49 unless ( $ENV{TMPDIR} ) { $ENV{TMPDIR} = '/var/tmp/g-cpan' }
50
51 sub new {
52 my $proto = shift;
53 my %args = @_;
54 my $class = ref($proto) || $proto;
55 my $self = {};
56
57 $self->{cpan} = {};
58 $self->{DEBUG} = $args{debug}||"";
59
60 bless( $self, $class );
61 return $self;
62 }
63
64 sub getCPANInfo {
65 my $self = shift;
66 my $find_module = shift;
67 my @tmp_v = ();
68
69 unless ($find_module) {
70 croak("No module supplied");
71 }
72
73 if ( $self->{cpan_reload} ) {
74
75 # - User forced reload of the CPAN index >
76 CPAN::Index->force_reload();
77
78 # Reset so we don't run it for every module after the initial reload
79 $self->{cpan_reload} = 0;
80 }
81
82 my $mod;
83
84 unless (($mod = CPAN::Shell->expand("Module",$find_module)) ||
85 ($mod = CPAN::Shell->expand("Bundle",$find_module)) ||
86 ($mod = CPAN::Shell->expand("Distribution",$find_module)) ||
87 ($mod = CPAN::Shell->expandany($find_module)) )
88 { return }
89
90 # - Fetch CPAN-filename and cut out the filename of the tarball.
91 # We are not using $mod->id here because doing so would end up
92 # missing a lot of our ebuilds/packages >
93 # Addendum. Appears we are missing items both ways - have to test both the name in cpan_file and the mod->id. :/
94 next unless ( $mod->id );
95 $self->{'cpan'}{ lc($find_module) }{'description'} =
96 $mod->{RO}{'description'} || "No description available";
97 $self->{'cpan'}{ lc($find_module) }{'src_uri'} = $mod->{RO}{'CPAN_FILE'};
98 $self->{'cpan'}{ lc($find_module) }{'name'} = $mod->id;
99 $self->{'cpan'}{ lc($find_module) }{'version'} = $mod->{RO}{'CPAN_VERSION'}
100 || "0";
101 return;
102 }
103
104 sub unpackModule {
105 my $self = shift;
106 my $module_name = shift;
107 if ( $module_name !~ m|::| ) {
108 $module_name =~ s{-}{::}xmsg;
109 } # Assume they gave us module-name instead of module::name
110
111 my $obj = CPAN::Shell->expandany($module_name);
112 unless ( ( ref $obj eq "CPAN::Module" )
113 || ( ref $obj eq "CPAN::Bundle" )
114 || ( ref $obj eq "CPAN::Distribution" ) )
115 {
116 warn("Don't know what '$module_name' is\n");
117 return;
118 }
119 my $file = $obj->cpan_file;
120
121 $CPAN::Config->{prerequisites_policy} = "";
122 $CPAN::Config->{inactivity_timeout} = 10;
123
124 my $pack = $CPAN::META->instance( 'CPAN::Distribution', $file );
125 if ( $pack->can('called_for') ) {
126 $pack->called_for( $obj->id );
127 }
128
129 # Grab the tarball and unpack it
130 $pack->get;
131 my $tmp_dir = $pack->{build_dir};
132
133 # Set our starting point
134 my $localf = $pack->{localfile};
135 $self->{'cpan'}{ lc($module_name) }{'cpan_tarball'} = $pack->{localfile};
136 my ($startdir) = &cwd;
137
138 # chdir to where we were unpacked
139 chdir($tmp_dir) or die "Unable to enter dir $tmp_dir:$!\n";
140
141 # If we have a Makefile.PL, run it to generate Makefile
142 if ( -f "Makefile.PL" ) {
143 perl("Makefile.PL");
144 }
145
146 # If we have a Build.PL, run it to generate the Build script
147 if ( -f "Build.PL" ) {
148 perl("Build.PL");
149 }
150
151 # Return whence we came
152 chdir($startdir);
153
154 $pack->unforce if $pack->can("unforce") && exists $obj->{'force_update'};
155 delete $obj->{'force_update'};
156
157 # While we're at it, get the ${S} dir for the ebuld ;)
158 $self->{'cpan'}{ lc($module_name) }{'portage_sdir'} = $pack->{build_dir};
159 $self->{'cpan'}{ lc($module_name) }{'portage_sdir'} =~ s{.*/}{}xmsg;
160 # If name is bundle::, then scan the bundle's deps, otherwise findep it
161 if (lc($module_name) =~ m{^bundle\::})
162 {
163 UnBundle( $self, $tmp_dir, $module_name );
164 } else {
165 FindDeps( $self, $tmp_dir, $module_name );
166 }
167
168 # Most modules don't list module-build as a dep - so we force it if there
169 # is a Build.PL file
170 if ( -f "Build.PL" ) {
171 $self->{'cpan'}{ lc($module_name) }{'depends'}{"Module::Build"} = '0';
172 }
173
174 # Final measure - if somehow we got an undef along the way, set to 0
175 foreach my $dep ( keys %{ $self->{'cpan'}{ lc($module_name) }{'depends'} } )
176 {
177 unless (
178 defined( $self->{'cpan'}{ lc($module_name) }{'depends'}{$dep} ) ||
179 ($self->{'cpan'}{ lc($module_name) }{'depends'}{$dep} eq "undef" )
180 )
181 {
182 $self->{'cpan'}{ lc($module_name) }{'depends'}{$dep} = "0";
183 }
184 }
185 return ($self);
186 }
187
188 sub UnBundle {
189 my $self = shift;
190 my ($workdir) = shift;
191 my $module_name = shift;
192 my ($startdir) = &cwd;
193 chdir($workdir) or die "Unable to enter dir $workdir:$!\n";
194 opendir( CURD, "." );
195 my @dirs = readdir(CURD);
196 closedir(CURD);
197 foreach my $object (@dirs) {
198 next if ( $object eq "." );
199 next if ( $object eq ".." );
200 if ( -f $object ) {
201 if ($object =~ m{\.pm$} )
202 {
203 my $fh;
204 my $in_cont = 0;
205 open ($fh, "$object");
206 while (<$fh>) {
207 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
208 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
209 next unless $in_cont;
210 next if /^=/;
211 s/\#.*//;
212 next if /^\s+$/;
213 chomp;
214 my $module;
215 my $ver = 0;
216 my $junk;
217 if (m{ }) {
218 ($module,$ver,$junk) = (split " ", $_);
219 if ($ver !~ m{^\d+}) { $ver = 0}
220 } else {
221 $module = (split " ", $_, 2)[0];
222 }
223
224 $self->{'cpan'}{ lc($module_name) }{'depends'}{$module}
225 = $ver;
226 }
227 }
228 }
229 elsif ( -d $object ) {
230 UnBundle( $self, $object, $module_name );
231 next;
232 }
233
234 }
235 chdir($startdir) or die "Unable to change to dir $startdir:$!\n";
236 return ($self);
237 }
238
239
240 sub FindDeps {
241 my $self = shift;
242 my ($workdir) = shift;
243 my $module_name = shift;
244 my ($startdir) = &cwd;
245 chdir($workdir) or die "Unable to enter dir $workdir:$!\n";
246 opendir( CURD, "." );
247 my @dirs = readdir(CURD);
248 closedir(CURD);
249 my %req_list = ();
250
251 foreach my $object (@dirs) {
252 next if ( $object eq "." );
253 next if ( $object eq ".." );
254 if ( -f $object ) {
255 my $abs_path = abs_path($object);
256 if ( $object =~ m{META.yml}i ) {
257
258 # Do YAML parsing if you can
259 my $b_n = dirname($abs_path);
260 $b_n = basename($b_n);
261 my $arr = YAML::LoadFile($abs_path);
262 foreach my $type qw(requires build_requires recommends) {
263 if ( my $ar_type = $arr->{$type} ) {
264 foreach my $module ( keys %{$ar_type} ) {
265 next if ( $module eq "" );
266 next if ( $module =~ /Cwd/i );
267 #next if ( lc($module) eq "perl" );
268 next unless ($module);
269 $self->{'cpan'}{ lc($module_name) }{'depends'}
270 {$module} = $ar_type->{$module};
271 }
272 }
273 }
274 }
275 if ( $object =~ m/^Makefile$/ ) {
276
277 # Do some makefile parsing
278 # RIPPED from CPAN.pm ;)
279 use FileHandle;
280
281 my $b_dir = dirname($abs_path);
282 my $makefile = File::Spec->catfile( $b_dir, "Makefile" );
283
284 my $fh;
285 my (%p) = ();
286 if ( $fh = FileHandle->new("<$makefile\0") ) {
287 local ($/) = "\n";
288 while (<$fh>) {
289 chomp;
290 last if /MakeMaker post_initialize section/;
291 my ($p) = m{^[\#]
292 \s{0,}PREREQ_PM\s+=>\s+(.+)
293 }x;
294 next unless $p;
295 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ) {
296 my $module = $1;
297 next if ( $module eq "" );
298 next if ( $module =~ /Cwd/i );
299 #next if ( lc($module) eq "perl" );
300 next unless ($module);
301 my $version = $2;
302 $self->{'cpan'}{ lc($module_name) }{'depends'}
303 {$module} = $version;
304 }
305
306 last;
307 }
308 }
309 }
310 if ( $object eq "Build.PL" ) {
311
312 # Do some Build file parsing
313 use FileHandle;
314 my $b_dir = dirname($abs_path);
315 my $b_n = dirname($abs_path);
316 $b_n = basename($b_n);
317 my $makefile = File::Spec->catfile( $b_dir, "Build.PL" );
318 my (%p) = ();
319 my $fh;
320
321 foreach my $type qw(requires recommends build_requires) {
322 if ( $fh = FileHandle->new("<$makefile\0") ) {
323 local ($/) = "";
324 while (<$fh>) {
325 chomp;
326 my ($p) = m/^\s+$type\s+=>\s+\{(.*?)(?:\#.*)?\}/smx;
327 next unless $p;
328 undef($/);
329
330 #local($/) = "\n";
331 my @list = split( ',', $p );
332 foreach my $pa (@list) {
333 $pa =~ s/\n|\s+|\'//mg;
334 if ($pa) {
335 my ( $module, $vers ) = split( /=>/, $pa );
336 next if ( $module eq "" );
337 next if ( $module =~ /Cwd/i );
338 #next if ( lc($module) eq "perl" );
339 next unless ($module);
340 $self->{'cpan'}{ lc($module_name) }
341 {'depends'}{$module} = $vers;
342 }
343 }
344 last;
345
346 }
347 }
348 }
349
350 }
351
352 }
353 elsif ( -d $object ) {
354 FindDeps( $self, $object, $module_name );
355 next;
356 }
357
358 }
359 chdir($startdir) or die "Unable to change to dir $startdir:$!\n";
360 return ($self);
361
362 }
363
364 sub transformCPAN {
365 my $self = shift;
366 my $name = shift;
367 my $req = shift;
368 return unless ( defined($name) );
369 my $re_path = '(?:.*)?';
370 my $re_pkg = '(?:.*)?';
371 my $re_ver = '(?:v?[\d\.]+[a-z]?)?';
372 my $re_suf = '(?:_(?:alpha|beta|pre|rc|p)(?:\d+)?)?';
373 my $re_rev = '(?:\-r?\d+)?';
374 my $re_ext = '(?:(?:tar|tgz|zip|bz2|gz|tar\.gz))?';
375
376 my $filename = $name;
377 my($modpath, $filenamever, $fileext);
378 $fileext = $1 if $filename =~ s/\.($re_ext)$//;
379 $modpath = $1 if $filename =~ s/^($re_path)\///;
380 $filenamever = $1 if $filename =~ s/-($re_ver$re_suf$re_rev)$//;
381
382 # Alphanumeric version numbers? (http://search.cpan.org/~pip/)
383 if ($filename =~ s/-(\d\.\d\.\d)([A-Za-z0-9]{6})$//) {
384 $filenamever = $1;
385 $filenamever .= ('.'.ord($_)) foreach split(//, $2);
386 }
387
388 # remove underscores
389 return unless ($filename);
390 unless ($filename) { print STDERR "$name yielded $filename\n"; sleep(4); }
391 $filename =~ tr/A-Za-z0-9\./-/c;
392 $filename =~ s/\.pm//; # e.g. CGI.pm
393
394 # Remove double .'s - happens on occasion with odd packages
395 $filenamever =~ s/\.$//;
396
397 # rename a double version -0.55-7 to ebuild style -0.55-r7
398 $filenamever =~ s/([0-9.]+)-([0-9.]+)$/$1\.$2/;
399
400 # Remove leading v's - happens on occasion
401 $filenamever =~ s{^v}{}i;
402
403 # Some modules don't use the /\d\.\d\d/ convention, and portage goes
404 # berserk if the ebuild is called ebulldname-.02.ebuild -- so we treat
405 # this special case
406 if ( substr( $filenamever, 0, 1 ) eq '.' ) {
407 $filenamever = 0 . $filenamever;
408 }
409 if ($req eq "v")
410 {
411 return ($filenamever);
412 }
413 else
414 {
415 return ($filename);
416 }
417 }
418
419 sub makeCPANstub {
420 my $self = shift;
421 my $cpan_cfg_dir = File::Spec->catfile( $ENV{HOME}, CPAN_CFG_DIR );
422 my $cpan_cfg_file = File::Spec->catfile( $cpan_cfg_dir, CPAN_CFG_NAME );
423
424 if ( not -d $cpan_cfg_dir ) {
425 mkpath( $cpan_cfg_dir, 1, 0755 )
426 or fatal( $Gentoo::ERR_FOLDER_CREATE, $cpan_cfg_dir, $! );
427 }
428
429 my $tmp_dir = -d $ENV{TMPDIR} ? $ENV{TMPDIR} : $ENV{HOME};
430 my $ftp_proxy = defined( $ENV{ftp_proxy} ) ? $ENV{ftp_proxy} : '';
431 my $http_proxy = defined( $ENV{http_proxy} ) ? $ENV{http_proxy} : '';
432 my $user_shell = defined( $ENV{SHELL} ) ? $ENV{SHELL} : DEF_BASH_PROG;
433 my $ftp_prog = -f DEF_FTP_PROG ? DEF_FTP_PROG : '';
434 my $gpg_prog = -f DEF_GPG_PROG ? DEF_GPG_PROG : '';
435 my $gzip_prog = -f DEF_GZIP_PROG ? DEF_GZIP_PROG : '';
436 my $lynx_prog = -f DEF_LYNX_PROG ? DEF_LYNX_PROG : '';
437 my $make_prog = -f DEF_MAKE_PROG ? DEF_MAKE_PROG : '';
438 my $ncftpget_prog = -f DEF_NCFTPGET_PROG ? DEF_NCFTPGET_PROG : '';
439 my $less_prog = -f DEF_LESS_PROG ? DEF_LESS_PROG : '';
440 my $tar_prog = -f DEF_TAR_PROG ? DEF_TAR_PROG : '';
441 my $unzip_prog = -f DEF_UNZIP_PROG ? DEF_UNZIP_PROG : '';
442 my $wget_prog = -f DEF_WGET_PROG ? DEF_WGET_PROG : '';
443
444 open CPANCONF, ">$cpan_cfg_file"
445 or fatal( $Gentoo::ERR_FOLDER_CREATE, $cpan_cfg_file, $! );
446 print CPANCONF <<"SHERE";
447
448 # This is CPAN.pm's systemwide configuration file. This file provides
449 # defaults for users, and the values can be changed in a per-user
450 # configuration file. The user-config file is being looked for as
451 # ~/.cpan/CPAN/MyConfig\.pm. This was generated by g-cpan for temporary usage
452
453 \$CPAN::Config = {
454 'build_cache' => q[10],
455 'build_dir' => q[$tmp_dir/.cpan/build],
456 'cache_metadata' => q[1],
457 'cpan_home' => q[$tmp_dir/.cpan],
458 'dontload_hash' => { },
459 'ftp' => q[$ftp_prog],
460 'ftp_proxy' => q[$ftp_proxy],
461 'getcwd' => q[cwd],
462 'gpg' => q[$gpg_prog],
463 'gzip' => q[$gzip_prog],
464 'histfile' => q[$tmp_dir/.cpan/histfile],
465 'histsize' => q[100],
466 'http_proxy' => q[$http_proxy],
467 'inactivity_timeout' => q[0],
468 'index_expire' => q[1],
469 'inhibit_startup_message' => q[1],
470 'keep_source_where' => q[$tmp_dir/.cpan/sources],
471 'lynx' => q[$lynx_prog],
472 'make' => q[$make_prog],
473 'make_arg' => q[],
474 'make_install_arg' => q[],
475 'makepl_arg' => q[],
476 'ncftpget' => q[$ncftpget_prog],
477 'no_proxy' => q[],
478 'pager' => q[$less_prog],
479 'prerequisites_policy' => q[follow],
480 'scan_cache' => q[atstart],
481 'shell' => q[$user_shell],
482 'tar' => q[$tar_prog],
483 'term_is_latin' => q[1],
484 'unzip' => q[$unzip_prog],
485 'urllist' => [qw["http://search.cpan.org/CPAN" "http://www.cpan.org/pub/CPAN" ],],
486 'wget' => q[$wget_prog],
487 };
488 1;
489 __END__
490
491 SHERE
492
493 close CPANCONF;
494 }
495
496 1;
497
498 =pod
499
500 =head1 NAME
501
502 Gentoo::CPAN - Perform CPAN calls, emulating some functionality where possible
503 for a portage friendly environment
504
505 =head1 SYNOPSIS
506
507 use Gentoo::CPAN;
508 my $obj = Gentoo::CPAN->new();
509 $obj->getCPANInfo("Module::Build");
510 my $version = $obj->{cpan}{lc("Module::Build")}{'version'};
511 my $realname = $obj->{cpan}{lc($module)}{'name'};
512 my $srcuri = $obj->{cpan}{lc($module)}{'src_uri'};
513 my $desc = $obj->{cpan}{lc($module)}{'description'};
514
515 =head1 DESCRIPTION
516
517 The C<Gentoo::CPAN> class gives us a method of working with CPAN modules. In
518 part it emulates the behavior of L<CPAN> itself, in other parts it simply
519 relies on L<CPAN> to do the work for us.
520
521 =head1 METHODS
522
523 =over 4
524
525 =item my $obj = Gentoo::CPAN->new();
526
527 Create a new Gentoo CPAN object.
528
529 =item $obj->getCPANInfo($somemodule);
530
531 Given the name of a CPAN module, extract the information from CPAN on this
532 object and populate the $obj hash. Provides:
533
534 =over 4
535
536 =item $obj->{cpan}{lc($module)}{'version'}
537
538 Version number
539
540 =item $obj->{cpan}{lc($module)}{'name'}
541
542 CPAN's name for the distribution
543
544 =item $obj->{cpan}{lc($module)}{'src_uri'}
545
546 The context path on cpan for the module source
547
548 =item $obj->{cpan}{lc($module)}{'description'}
549
550 Description, if available
551
552 =back
553
554 =item $obj->unpackModule($somemodule)
555
556 Grabs the module from CPAN and unpacks it. It then procedes to scan for
557 dependencies, filling in $obj->{'cpan'}{lc($somemodule)}{'depends'} with and
558 deps that were found (hash).
559
560 =item $obj->transformCPANVersion($somemodule)
561
562 =item $obj->transformCPANName($somemodule)
563
564 Returns a portage friend version or module name from the name that is used on
565 CPAN. Useful for modules that use names or versions that would break as a
566 portage ebuild.
567
568 =item $obj->makeCPANstub()
569
570 Generates a default CPAN stub file if none exists in the user's environment
571
572 =back
573
574 =cut

  ViewVC Help
Powered by ViewVC 1.1.20