/[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 121 - (show annotations) (download) (as text)
Sat Nov 25 16:58:17 2006 UTC (10 years, 10 months ago) by mcummings
File MIME type: text/x-perl
File size: 18563 byte(s)
Committing basic fixes


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 use Data::Dumper;
260 my $b_n = dirname($abs_path);
261 $b_n = basename($b_n);
262 my $arr = YAML::LoadFile($abs_path);
263 foreach my $type qw(requires build_requires recommends) {
264 if ( my $ar_type = $arr->{$type} ) {
265 foreach my $module ( keys %{$ar_type} ) {
266 next if ( $module eq "" );
267 next if ( $module =~ /Cwd/i );
268 #next if ( lc($module) eq "perl" );
269 next unless ($module);
270 $self->{'cpan'}{ lc($module_name) }{'depends'}
271 {$module} = $ar_type->{$module};
272 }
273 }
274 }
275 }
276 if ( $object =~ m/^Makefile$/ ) {
277
278 # Do some makefile parsing
279 # RIPPED from CPAN.pm ;)
280 use FileHandle;
281
282 my $b_dir = dirname($abs_path);
283 my $makefile = File::Spec->catfile( $b_dir, "Makefile" );
284
285 my $fh;
286 my (%p) = ();
287 if ( $fh = FileHandle->new("<$makefile\0") ) {
288 local ($/) = "\n";
289 while (<$fh>) {
290 chomp;
291 last if /MakeMaker post_initialize section/;
292 my ($p) = m{^[\#]
293 \s{0,}PREREQ_PM\s+=>\s+(.+)
294 }x;
295 next unless $p;
296 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ) {
297 my $module = $1;
298 next if ( $module eq "" );
299 next if ( $module =~ /Cwd/i );
300 #next if ( lc($module) eq "perl" );
301 next unless ($module);
302 my $version = $2;
303 $self->{'cpan'}{ lc($module_name) }{'depends'}
304 {$module} = $version;
305 }
306
307 last;
308 }
309 }
310 }
311 if ( $object eq "Build.PL" ) {
312
313 # Do some Build file parsing
314 use FileHandle;
315 my $b_dir = dirname($abs_path);
316 my $b_n = dirname($abs_path);
317 $b_n = basename($b_n);
318 my $makefile = File::Spec->catfile( $b_dir, "Build.PL" );
319 my (%p) = ();
320 my $fh;
321
322 foreach my $type qw(requires recommends build_requires) {
323 if ( $fh = FileHandle->new("<$makefile\0") ) {
324 local ($/) = "";
325 while (<$fh>) {
326 chomp;
327 my ($p) = m/^\s+$type\s+=>\s+\{(.*?)(?:\#.*)?\}/smx;
328 next unless $p;
329 undef($/);
330
331 #local($/) = "\n";
332 my @list = split( ',', $p );
333 foreach my $pa (@list) {
334 $pa =~ s/\n|\s+|\'//mg;
335 if ($pa) {
336 my ( $module, $version ) = split( /=>/, $pa );
337 next if ( $module eq "" );
338 next if ( $module =~ /Cwd/i );
339 #next if ( lc($module) eq "perl" );
340 next unless ($module);
341 $self->{'cpan'}{ lc($module_name) }
342 {'depends'}{$module} = $version;
343 }
344 }
345 last;
346
347 }
348 }
349 }
350
351 }
352
353 }
354 elsif ( -d $object ) {
355 FindDeps( $self, $object, $module_name );
356 next;
357 }
358
359 }
360 chdir($startdir) or die "Unable to change to dir $startdir:$!\n";
361 return ($self);
362
363 }
364
365 sub transformCPAN {
366 my $self = shift;
367 my $name = shift;
368 my $req = shift;
369 return unless ( defined($name) );
370 my $re_path = '(?:.*)?';
371 my $re_pkg = '(?:.*)?';
372 my $re_ver = '(?:v?[\d\.]+[a-z]?)?';
373 my $re_suf = '(?:_(?:alpha|beta|pre|rc|p)(?:\d+)?)?';
374 my $re_rev = '(?:\-r?\d+)?';
375 my $re_ext = '(?:(?:tar|tgz|zip|bz2|gz|tar\.gz))?';
376
377 my $filename = $name;
378 my($modpath, $filenamever, $fileext);
379 $fileext = $1 if $filename =~ s/\.($re_ext)$//;
380 $modpath = $1 if $filename =~ s/^($re_path)\///;
381 $filenamever = $1 if $filename =~ s/-($re_ver$re_suf$re_rev)$//;
382
383 # Alphanumeric version numbers? (http://search.cpan.org/~pip/)
384 if ($filename =~ s/-(\d\.\d\.\d)([A-Za-z0-9]{6})$//) {
385 $filenamever = $1;
386 $filenamever .= ('.'.ord($_)) foreach split(//, $2);
387 }
388
389 # remove underscores
390 return unless ($filename);
391 unless ($filename) { print STDERR "$name yielded $filename\n"; sleep(4); }
392 $filename =~ tr/A-Za-z0-9\./-/c;
393 $filename =~ s/\.pm//; # e.g. CGI.pm
394
395 # Remove double .'s - happens on occasion with odd packages
396 $filenamever =~ s/\.$//;
397
398 # rename a double version -0.55-7 to ebuild style -0.55-r7
399 $filenamever =~ s/([0-9.]+)-([0-9.]+)$/$1\.$2/;
400
401 # Remove leading v's - happens on occasion
402 $filenamever =~ s{^v}{}i;
403
404 # Some modules don't use the /\d\.\d\d/ convention, and portage goes
405 # berserk if the ebuild is called ebulldname-.02.ebuild -- so we treat
406 # this special case
407 if ( substr( $filenamever, 0, 1 ) eq '.' ) {
408 $filenamever = 0 . $filenamever;
409 }
410 if ($req eq "v")
411 {
412 return ($filenamever);
413 }
414 else
415 {
416 return ($filename);
417 }
418 }
419
420 sub makeCPANstub {
421 my $self = shift;
422 my $cpan_cfg_dir = File::Spec->catfile( $ENV{HOME}, CPAN_CFG_DIR );
423 my $cpan_cfg_file = File::Spec->catfile( $cpan_cfg_dir, CPAN_CFG_NAME );
424
425 if ( not -d $cpan_cfg_dir ) {
426 mkpath( $cpan_cfg_dir, 1, 0755 )
427 or fatal( $Gentoo::ERR_FOLDER_CREATE, $cpan_cfg_dir, $! );
428 }
429
430 my $tmp_dir = -d $ENV{TMPDIR} ? $ENV{TMPDIR} : $ENV{HOME};
431 my $ftp_proxy = defined( $ENV{ftp_proxy} ) ? $ENV{ftp_proxy} : '';
432 my $http_proxy = defined( $ENV{http_proxy} ) ? $ENV{http_proxy} : '';
433 my $user_shell = defined( $ENV{SHELL} ) ? $ENV{SHELL} : DEF_BASH_PROG;
434 my $ftp_prog = -f DEF_FTP_PROG ? DEF_FTP_PROG : '';
435 my $gpg_prog = -f DEF_GPG_PROG ? DEF_GPG_PROG : '';
436 my $gzip_prog = -f DEF_GZIP_PROG ? DEF_GZIP_PROG : '';
437 my $lynx_prog = -f DEF_LYNX_PROG ? DEF_LYNX_PROG : '';
438 my $make_prog = -f DEF_MAKE_PROG ? DEF_MAKE_PROG : '';
439 my $ncftpget_prog = -f DEF_NCFTPGET_PROG ? DEF_NCFTPGET_PROG : '';
440 my $less_prog = -f DEF_LESS_PROG ? DEF_LESS_PROG : '';
441 my $tar_prog = -f DEF_TAR_PROG ? DEF_TAR_PROG : '';
442 my $unzip_prog = -f DEF_UNZIP_PROG ? DEF_UNZIP_PROG : '';
443 my $wget_prog = -f DEF_WGET_PROG ? DEF_WGET_PROG : '';
444
445 open CPANCONF, ">$cpan_cfg_file"
446 or fatal( $Gentoo::ERR_FOLDER_CREATE, $cpan_cfg_file, $! );
447 print CPANCONF <<"SHERE";
448
449 # This is CPAN.pm's systemwide configuration file. This file provides
450 # defaults for users, and the values can be changed in a per-user
451 # configuration file. The user-config file is being looked for as
452 # ~/.cpan/CPAN/MyConfig\.pm. This was generated by g-cpan for temporary usage
453
454 \$CPAN::Config = {
455 'build_cache' => q[10],
456 'build_dir' => q[$tmp_dir/.cpan/build],
457 'cache_metadata' => q[1],
458 'cpan_home' => q[$tmp_dir/.cpan],
459 'dontload_hash' => { },
460 'ftp' => q[$ftp_prog],
461 'ftp_proxy' => q[$ftp_proxy],
462 'getcwd' => q[cwd],
463 'gpg' => q[$gpg_prog],
464 'gzip' => q[$gzip_prog],
465 'histfile' => q[$tmp_dir/.cpan/histfile],
466 'histsize' => q[100],
467 'http_proxy' => q[$http_proxy],
468 'inactivity_timeout' => q[0],
469 'index_expire' => q[1],
470 'inhibit_startup_message' => q[1],
471 'keep_source_where' => q[$tmp_dir/.cpan/sources],
472 'lynx' => q[$lynx_prog],
473 'make' => q[$make_prog],
474 'make_arg' => q[],
475 'make_install_arg' => q[],
476 'makepl_arg' => q[],
477 'ncftpget' => q[$ncftpget_prog],
478 'no_proxy' => q[],
479 'pager' => q[$less_prog],
480 'prerequisites_policy' => q[follow],
481 'scan_cache' => q[atstart],
482 'shell' => q[$user_shell],
483 'tar' => q[$tar_prog],
484 'term_is_latin' => q[1],
485 'unzip' => q[$unzip_prog],
486 'urllist' => [qw["http://search.cpan.org/CPAN" "http://www.cpan.org/pub/CPAN" ],],
487 'wget' => q[$wget_prog],
488 };
489 1;
490 __END__
491
492 SHERE
493
494 close CPANCONF;
495 }
496
497 1;
498
499 =pod
500
501 =head1 NAME
502
503 Gentoo::CPAN - Perform CPAN calls, emulating some functionality where possible
504 for a portage friendly environment
505
506 =head1 SYNOPSIS
507
508 use Gentoo::CPAN;
509 my $obj = Gentoo::CPAN->new();
510 $obj->getCPANInfo("Module::Build");
511 my $version = $obj->{cpan}->{lc("Module::Build")}->{'version'};
512 my $realname = $obj->{cpan}->{lc($module)}->{'name'};
513 my $srcuri = $obj->{cpan}->{lc($module)}->{'src_uri'};
514 my $desc = $obj->{cpan}->{lc($module)}->{'description'};
515
516 =head1 DESCRIPTION
517
518 The C<Gentoo::CPAN> class gives us a method of working with CPAN modules. In
519 part it emulates the behavior of L<CPAN> itself, in other parts it simply
520 relies on L<CPAN> to do the work for us.
521
522 =head1 METHODS
523
524 =over 4
525
526 =item my $obj = Gentoo::CPAN->new();
527
528 Create a new Gentoo CPAN object.
529
530 =item $obj->getCPANInfo($somemodule);
531
532 Given the name of a CPAN module, extract the information from CPAN on this
533 object and populate the $obj hash. Provides:
534
535 =over 4
536
537 =item $obj->{cpan}{lc($module)}{'version'}
538
539 Version number
540
541 =item $obj->{cpan}{lc($module)}{'name'}
542
543 CPAN's name for the distribution
544
545 =item $obj->{cpan}{lc($module)}{'src_uri'}
546
547 The context path on cpan for the module source
548
549 =item $obj->{cpan}{lc($module)}{'description'}
550
551 Description, if available
552
553 =back
554
555 =item $obj->unpackModule($somemodule)
556
557 Grabs the module from CPAN and unpacks it. It then procedes to scan for
558 dependencies, filling in $obj->{'cpan'}{lc($somemodule)}{'depends'} with and
559 deps that were found (hash).
560
561 =item $obj->transformCPANVersion($somemodule)
562
563 =item $obj->transformCPANName($somemodule)
564
565 Returns a portage friend version or module name from the name that is used on
566 CPAN. Useful for modules that use names or versions that would break as a
567 portage ebuild.
568
569 =item $obj->makeCPANstub()
570
571 Generates a default CPAN stub file if none exists in the user's environment
572
573 =back
574
575 =cut

  ViewVC Help
Powered by ViewVC 1.1.20