/[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 75 - (show annotations) (download) (as text)
Tue Jun 6 21:54:58 2006 UTC (8 years, 6 months ago) by mcummings
File MIME type: text/x-perl
File size: 17157 byte(s)
bug 135783


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

  ViewVC Help
Powered by ViewVC 1.1.20