CPANPLUS-0.9144/0000755000175000017500000000000012251422462012364 5ustar bingosbingosCPANPLUS-0.9144/MANIFEST.SKIP0000644000175000017500000000070212207704351014262 0ustar bingosbingos^blib/ ^t/dummy-cpanplus/(?!\.hidden) ^t/dummy-localmirror/authors/id ^t/dummy-localmirror/.*gz t/dummy-perl/.*(pm|3|packlist)$ ^t/\..* ^\.#autoinstall ^pmfiles.dat$ ^Makefile$ ^Makefile.old$ ^MANIFEST.bak$ ^pm_to_blib ^blibdirs ^TODO$ ^cover_db/ ^tmp/ ^samples/ ^CPANPLUS.*gz$ \.DS_Store$ \.swp$ \.orig$ \.rpt$ lib/CPANPLUS/inc/installers/patches/ Changes ^patches/ \.org$ \.rej$ dev-bin/ ^CPANPLUS ^.cpanplus/ ^sandbox ~$ ^patches ^.git ^MYMETA\.* CPANPLUS-0.9144/META.yml0000644000175000017500000000101412251421370013626 0ustar bingosbingos--- abstract: Ameliorated interface to the CPAN author: 'Jos Boumans ' distribution_type: module dynamic_config: 1 generated_by: Module::Install version 0.650 license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 name: CPANPLUS no_index: directory: - lib/CPANPLUS/inc - inc - t resources: license: http://dev.perl.org/licenses/ homepage: http://github.com/jib/cpanplus-devel repository: http://github.com/jib/cpanplus-devel version: 0.9144 CPANPLUS-0.9144/t/0000755000175000017500000000000012251422462012627 5ustar bingosbingosCPANPLUS-0.9144/t/03_CPANPLUS-Internals-Source.t0000644000175000017500000002034312251417323017740 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Module::Load; use Test::More eval { load $ENV{CPANPLUS_SOURCE_ENGINE} if $ENV{CPANPLUS_SOURCE_ENGINE}; 1 } ? 'no_plan' : (skip_all => "SQLite engine not available"); use CPANPLUS::Error; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; use Data::Dumper; use File::Basename qw[dirname]; my $conf = gimme_conf(); $conf->set_conf( enable_custom_sources => 1 ); my $cb = CPANPLUS::Backend->new( $conf ); ### XXX temp # $conf->set_conf( verbose => 1 ); isa_ok($cb, "CPANPLUS::Internals" ); my $modname = TEST_CONF_MODULE; ### test lookups { my $mt = $cb->_module_tree; my $at = $cb->_author_tree; ### source files should be copied from the 'server' now for my $name (qw[auth mod] ) { my $file = File::Spec->catfile( $conf->get_conf('base'), $conf->_get_source($name) ); ok( (-e $file && -f _ && -s _), "$file exists" ); } ok( $at, "Authortree loaded successfully" ); ok( scalar keys %$at, " Authortree has items in it" ); ok( $mt, "Moduletree loaded successfully" ); ok( scalar keys %$mt, " Moduletree has items in it" ); my $auth = $at->{'EUNOXS'}; my $mod = $mt->{$modname}; isa_ok( $auth, 'CPANPLUS::Module::Author' ); isa_ok( $mod, 'CPANPLUS::Module' ); } ### save state tests SKIP: { skip "Save state tests for custom engine $ENV{CPANPLUS_SOURCE_ENGINE}", 7 if $ENV{CPANPLUS_SOURCE_ENGINE}; ok( 1, "Testing save state functionality" ); ### check we dont have a status set yet { my $mod = $cb->_module_tree->{$modname}; ok( !$mod->_status, " No status set yet in module object" ); ok( $mod->status, " Status now set" ); } ### now save this to disk { CPANPLUS::Error->flush; my $rv = $cb->save_state; ok( $rv, " State information saved" ); like( CPANPLUS::Error->stack_as_string, qr/Writing compiled source/, " Diagnostics confirmed" ); } ### now we rebuild the trees from disk and ### check if the module object has a status saved with it { CPANPLUS::Error->flush; ok( $cb->_build_trees( uptodate => 1, use_stored => 1), " Trees are rebuilt" ); like( CPANPLUS::Error->stack_as_string, qr/Retrieving/, " Diagnostics confirmed" ); my $mod = $cb->_module_tree->{$modname}; ok( $mod->status, " Status now set in module object" ); } } ### check custom sources ### XXX whitebox test SKIP: { ### first, find a file to serve as a source my $mod = $cb->_module_tree->{$modname}; my $package = File::Spec->rel2abs( File::Spec->catfile( $FindBin::Bin, TEST_CONF_CPAN_DIR, $mod->path, $mod->package, ) ); ok( $package, "Found file for custom source" ); ok( -e $package, " File '$package' exists" ); ### remote uri my $uri = $cb->_host_to_uri( scheme => 'file', host => '', path => File::Spec->catfile( dirname($package) ) ); my $expected_file = $cb->__custom_module_source_index_file( uri => $uri ); ok( $expected_file, "Sources should be written to '$uri'" ); skip( "Index file size too long (>260 chars). Can't write to disk", 28 ) if length $expected_file > 260 and ON_WIN32; ### local file ### 2 tests my $src_file = $cb->_add_custom_module_source( uri => $uri ); ok( $src_file, "Sources written to '$src_file'" ); ok( -e $src_file, " File exists" ); ### and write the file ### 5 tests { my $meth = '__write_custom_module_index'; can_ok( $cb, $meth ); my $rv = $cb->$meth( path => dirname( $package ), to => $src_file ); ok( $rv, " Sources written" ); is( $rv, $src_file, " Written to expected file" ); ok( -e $src_file, " Source file exists" ); ok( -s $src_file, " File has non-zero size" ); } ### let's see if we can find our custom files ### 3 tests { my $meth = '__list_custom_module_sources'; can_ok( $cb, $meth ); my %files = $cb->$meth; ok( scalar(keys(%files)), " Got list of sources" ); ### on VMS, we can't predict the case unfortunately ### so grep for it instead; my $found = map { my $src_re = quotemeta($src_file); $_ =~ /$src_re/i; } keys %files; ok( $found, " Found proper entry for $src_file" ); } ### now we can have it be loaded in ### 6 tests { my $meth = '__create_custom_module_entries'; can_ok( $cb, $meth ); ### now add our own sources ok( $cb->$meth, "Sources file loaded" ); my $add_name = TEST_CONF_INST_MODULE; my $add = $cb->_module_tree->{$add_name}; ok( $add, " Found added module" ); ok( $add->status->_fetch_from, " Full download path set" ); is( $add->author->cpanid, CUSTOM_AUTHOR_ID, " Attributed to custom author" ); ### since we replaced an existing module, there should be ### a message on the stack like( CPANPLUS::Error->stack_as_string, qr/overwrite module tree/i, " Addition message recorded" ); } ### test updating custom sources ### 3 tests { my $meth = '__update_custom_module_sources'; can_ok( $cb, $meth ); ### mark what time it is now, sleep 1 second for better measuring my $now = time; sleep 1; my $ok = $cb->$meth; ok( $ok, "Custom sources updated" ); cmp_ok( [stat $src_file]->[9], '>=', $now, " Timestamp on sourcefile updated" ); } ### now update it individually ### 3 tests { my $meth = '__update_custom_module_source'; can_ok( $cb, $meth ); ### mark what time it is now, sleep 1 second for better measuring my $now = time; sleep 1; my $ok = $cb->$meth( remote => $uri ); ok( $ok, "Custom source for '$uri' updated" ); cmp_ok( [stat $src_file]->[9], '>=', $now, " Timestamp on sourcefile updated" ); } ### now update using the higher level API, see if it's part of the update ### 3 tests { CPANPLUS::Error->flush; ### mark what time it is now, sleep 1 second for better measuring my $now = time; sleep 1; my $ok = $cb->_build_trees( uptodate => 0, use_stored => 0, ); ok( $ok, "All sources updated" ); cmp_ok( [stat $src_file]->[9], '>=', $now, " Timestamp on sourcefile updated" ); like( CPANPLUS::Error->stack_as_string, qr/Updating sources from/, " Update recorded in the log" ); } ### now remove the index file; ### 3 tests { my $meth = '_remove_custom_module_source'; can_ok( $cb, $meth ); my $file = $cb->$meth( uri => $uri ); ok( $file, "Index file removed" ); ok( ! -e $file, " File '$file' no longer on disk" ); } } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/06_CPANPLUS-Internals-Constants.t0000644000175000017500000000425612207704351020465 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use Cwd; use Config; use File::Basename; use CPANPLUS::Internals::Constants; use CPANPLUS::Module::Fake; use CPANPLUS::Module::Author::Fake; use CPANPLUS::Configure; use CPANPLUS::Backend; my $conf = gimme_conf(); my $cb = CPANPLUS::Backend->new( $conf ); my $f_auth = CPANPLUS::Module::Author::Fake->new( _id => $cb->_id ); ok( $f_auth, "Fake auth object created" ); ok( IS_AUTHOBJ->( $f_auth ), " IS_AUTHOBJ recognizes it" ); ok( IS_FAKE_AUTHOBJ->( $f_auth ), " IS_FAKE_AUTHOBJ recognizes it" ); my $f_mod = CPANPLUS::Module::Fake->new( module => TEST_CONF_INST_MODULE , path => 'some/where', package => 'Foo-Bar-1.2.tgz', _id => $cb->_id, ); ok( $f_mod, "Fake mod object created" ); ok( IS_MODOBJ->( $f_mod ), " IS_MODOBJ recognizes it" ); ok( IS_FAKE_MODOBJ->( $f_mod ), " IS_FAKE_MODOJB recognizes it" ); ok( IS_CONFOBJ->( conf => $conf ), "IS_CONFOBJ recognizes conf object" ); ok( FILE_EXISTS->( file => basename($0) ), "FILE_EXISTS finds file" ); ok( FILE_READABLE->( file => basename($0) ), "FILE_READABLE finds file" ); ok( DIR_EXISTS->( dir => cwd() ), "DIR_EXISTS finds dir" ); { no strict 'refs'; my $tmpl = { MAKEFILE_PL => 'Makefile.PL', BUILD_PL => 'Build.PL', BLIB => 'blib', MAKEFILE => do { ### On vms, it's a different name. See constants ### file for details (ON_VMS and $Config::Config{make} =~ /MM[S|K]/i) ? 'DESCRIP.MMS' : 'Makefile' }, }; while ( my($sub,$res) = each %$tmpl ) { is( &{$sub}->(), $res, "$sub returns proper result without args" ); my $long = File::Spec->catfile( cwd(), $res ); is( &{$sub}->( cwd() ), $long, "$sub returns proper result with args" ); } } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/10_CPANPLUS-Error.t0000644000175000017500000000676012207704351015642 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use Data::Dumper; use FileHandle; use CPANPLUS::Error; my $conf = gimme_conf(); my $map = { cp_msg => ["This is just a test message"], msg => ["This is just a test message"], cp_error => ["This is just a test error"], error => ["This is just a test error"], }; ### check if CPANPLUS::Error can do what we expect { for my $name ( keys %$map ) { can_ok('CPANPLUS::Error', $name); can_ok('main', $name); # did it get exported? } } ### make sure we start with an empty stack { CPANPLUS::Error->flush; is( scalar(()=CPANPLUS::Error->stack), 0, "Starting with empty stack" ); } ### global variables test ### { my $file = output_file(); ### this *has* to be set, as we're testing the contents of the file ### to see if it matches what's stored in the buffer. local $CPANPLUS::Error::MSG_FH = output_handle(); local $CPANPLUS::Error::ERROR_FH = output_handle(); ok( -e $file, "Output redirect file exists" ); ok( !-s $file, " Output file is empty" ); ### print a msg & error ### for my $name ( keys %$map ) { my $sub = __PACKAGE__->can( $name ); $sub->( $map->{$name}->[0], 1 ); } ### must close it for Win32 tests! close output_handle; ok( -s $file, " Output file now has size" ); my $fh = FileHandle->new( $file ); ok( $fh, "Opened output file for reading " ); my $contents = do { local $/; <$fh> }; my $string = CPANPLUS::Error->stack_as_string; my $trace = CPANPLUS::Error->stack_as_string(1); ok( $contents, " Got the file contents" ); ok( $string, "Got the error stack as string" ); for my $type ( keys %$map ) { my $tag = $type; $tag =~ s/.+?_//g; for my $str (@{ $map->{$type} } ) { like( $contents, qr/\U\Q$tag/, " Contents matches for '$type'" ); like( $contents, qr/\Q$str/, " Contents matches for '$type'" ); like( $string, qr/\U\Q$tag/, " String matches for '$type'" ); like( $string, qr/\Q$str/, " String matches for '$type'" ); like( $trace, qr/\U\Q$tag/, " Trace matches for '$type'" ); like( $trace, qr/\Q$str/, " Trace matches for '$type'" ); ### extra trace tests ### like( $trace, qr/\Q$str\E.*?\Q$str/s, " Trace holds proper traceback" ); like( $trace, qr/\Q$0/, " Trace holds program name" ); like( $trace, qr/line/, " Trace holds line number information" ); } } ### check the stack, flush it, check again ### is( scalar(()=CPANPLUS::Error->stack), scalar(keys(%$map)), "All items on stack" ); is( scalar(()=CPANPLUS::Error->flush), scalar(keys(%$map)), "All items flushed" ); is( scalar(()=CPANPLUS::Error->stack), 0, "No items on stack" ); } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/07_CPANPLUS-Internals-Extract.t0000644000175000017500000000140112207704351020111 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use CPANPLUS::Configure; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Data::Dumper; my $conf = gimme_conf(); my $cb = CPANPLUS::Backend->new( $conf ); ### XXX SOURCEFILES FIX my $mod = $cb->module_tree( TEST_CONF_MODULE ); isa_ok( $mod, 'CPANPLUS::Module' ); my $where = $mod->fetch; ok( $where, "Module fetched" ); my $dir = $cb->_extract( module => $mod ); ok( $dir, "Module extracted" ); ok( DIR_EXISTS->($dir), " Dir exists" ); # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/dummy-localmirror/0000755000175000017500000000000012251422462016305 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-localmirror/.hidden0000644000175000017500000000000012207704351017530 0ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/0000755000175000017500000000000012251422462014501 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/authors/0000755000175000017500000000000012251422462016166 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/authors/id/0000755000175000017500000000000012251422462016562 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBXS/0000755000175000017500000000000012251422462017333 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS0000644000175000017500000000101412207704351020600 0ustar bingosbingos0&&<<''; # this PGP-signed message is also valid perl -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 # CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) $cksum = { 'Foo-Bar-0.01.tar.gz' => { 'mtime' => '1999-05-13', 'md5' => '986e4316ac095d8a4d47d0d0dd2c408a', 'size' => 1541 }, }; __END__ -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.2.3 (GNU/Linux) iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 mAcaUP8yzmIvbpdn1cGUgpw= =rrmL -----END PGP SIGNATURE----- CPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme0000644000175000017500000000001012207704351022303 0ustar bingosbingosREADME CPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz0000644000175000017500000000300512207704351022262 0ustar bingosbingos8MBFoo-Bar-0.01.tarZOIWx6h"+\04n-ll2;+{cd=wv>}72}tȘO ӧYț3lZ\6[ȘV>{''0Pظ;e>Yrn gV~֢C[z+sˤ>$\X&&pPo'eeǡv9s>1w ˧6S"P4̅,3'>eOb?n\*hߴWcoyvvlMj 1aӫsJS,ln'gw9bNqQv&ѷک]dv}GHXP*AfpJUj֯s:n+$-+WxL :׀G! :dB`ߍ6ޜN<~.yW]nUexe_kV|րn^/Z0ٴG:,NPQb 8{@'"=UTEJ𤊻@S:;j 1pRv<W8{/Pw 45p#w2 }m@/:ʑ^?ȣwAqOͩ9p$Jqω|yhY RElOz4l:]Pq4MGLSʹ-`cE Jb0BC5Ival>FƺW} }?O}/miC67| Rspr-B㣹cj/\.ĊD+@hVˮZHxtc@*l:PxjUn >:B.^0VM4b# ZY / v߼cCVoT {;vRo\k|[h=_*z p un`oǎK|;Ex4"Y6+lf2z_ 4l(_M#hu,B DJE SKSY~ yR{GAUQлcO9՞bq*%ҡpAsolXܪ)~j?Sx\ZplUF>ɷL0K?P/DeW痁4뿖0𧖧#% 0 x2$?_9o=F 6eBpot;3#1>pHґvk5$#ՆB-2j<"CM { 'mtime' => '1999-05-13', 'md5' => '5cfed19e324ef8379d092807f10e5903', 'size' => 1118 }, 'Foo-Bar-0.01.meta' => { 'mtime' => '1999-05-13', 'size' => '389', 'md5' => '6ca49cb8414b093e56515b1b65ccf718', }, 'perl5.005_03.tar.gz' => { 'mtime' => '1999-05-13', 'md5' => '2b70961796a2ed7ca21fbf7e0c615643', 'size' => 119 }, 'Bundle-Foo-Bar-0.01.tar.gz' => { 'mtime' => '1999-05-13', 'md5' => '76f9c0eed0de9f533ed4d3922bac2f11', 'size' => 850 }, }; __END__ -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.2.3 (GNU/Linux) iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 mAcaUP8yzmIvbpdn1cGUgpw= =rrmL -----END PGP SIGNATURE----- CPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme0000644000175000017500000000001012207704351022553 0ustar bingosbingosREADME CPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta0000644000175000017500000000060512207704351022256 0ustar bingosbingos# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Foo-Bar version: 0.01 version_from: lib/Foo/Bar.pm installdirs: site requires: # for configure_requires support configure_requires: Cwd: 0.01 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.25 CPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz0000644000175000017500000000213612207704351022536 0ustar bingosbingos< GmoFy$T"$9BH$מt=E ^u墪~A1$NR摢xP;LlSs|棢mg[ukwz*1ނrInXa~eS[^>ﳿeuv;vFBilDlWwT؃Z.+c8MBr788!}B^zΨomBܶ^Ns!P(,S?`JSYXՁm߶L_n­xMV&뀜p a0hP-$7gWKs. Do7g%ʼn/8>g "A2i?"fK~cpu}~yBX0Scy4>wzI*UB' :czѮ|WM4`MZTȸLSڀR[DrN*5c Ե+:lXk}64,}A#߱rJ$]LԏYU8)WsB5“IDpou[{WG%6u|tV0A0|$@gKVzaTMpemDs;"ղ|?s[/o9:01j/·-&P 9FKU2I[1U2aD5 nYs5v[a@RFqekg$"'Lu.3fp&3h%s)nB )}%A91SWֹ234d21XvńvЭnW\XC>W& OEDU-$f~٩]OR~[@F%YgE;]`Ţ'2ǩK{w!d8d}Z6`]r^2U? l]3tOny|Qm[dzm<mhNb^0          {BePCPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBNOXS/0000755000175000017500000000000012251422462017570 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS0000644000175000017500000000101312207704351021034 0ustar bingosbingos0&&<<''; # this PGP-signed message is also valid perl -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 # CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) $cksum = { 'Foo-Bar-0.01.tar.gz' => { 'mtime' => '1999-05-13', 'md5' => '1f52c2e83140814f734c8674e8fae53f', 'size' => 867 }, }; __END__ -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.2.3 (GNU/Linux) iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 mAcaUP8yzmIvbpdn1cGUgpw= =rrmL -----END PGP SIGNATURE----- CPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme0000644000175000017500000000001012207704351022540 0ustar bingosbingosREADME CPANPLUS-0.9144/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz0000644000175000017500000000154312207704351022524 0ustar bingosbingos8MBFoo-Bar-0.01.tar[o0y8-Jr jtJP F$6ʥ]5&ju=K9>qrhjfP ˒ְiJISu %U-*dJSߵ[W$M_}֐n_7oX y``0v=JOHqd;v9kM/nYCcs?t*QudRdژybX2ukjUà&yFYjUƶ[iO!?w\\7a`rY7U/xioٿA-ҷGb!L Ol9?:=k{b3x4{GwOϏ:5 B3\FCp̸= udk|ڃ}PO0i8|vKi QM n6eX)‡DGK!r"5J@|겉xwAfT5eBlu^۞VqBdO\jaQٞHtę<,1$DuY)`BXG4֞Mky4 "xLq-&ߜ5n4V"NQ:Kv2#GFo Dx+CL^8`Oa4Vph CY}JfwQRkDr0 <7HǕgd?]c񟩩EO,          O kPCPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUXS/0000755000175000017500000000000012251422462017346 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS0000644000175000017500000000101412207704351020613 0ustar bingosbingos0&&<<''; # this PGP-signed message is also valid perl -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 # CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) $cksum = { 'Foo-Bar-0.01.tar.gz' => { 'mtime' => '1999-05-13', 'md5' => 'c7691a12e5faa70b3a0e83402d279bd6', 'size' => 1589 }, }; __END__ -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.2.3 (GNU/Linux) iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 mAcaUP8yzmIvbpdn1cGUgpw= =rrmL -----END PGP SIGNATURE----- CPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme0000644000175000017500000000001012207704351022316 0ustar bingosbingosREADME CPANPLUS-0.9144/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz0000644000175000017500000000306512207704351022303 0ustar bingosbingos 9MBFoo-Bar-0.01.tarZkOHWW\U@< V04*y( ]nMIba{RP#_6v;G'W`̣zP@TJ%u4+%s!g,:.MصˆM zϔaL$dBS h@]HՌN1𙤇03PmO%?u_~e/%+& )գ#? r=< l13&8S64&]M\Garlʶ]σcnr`( һ$>Ε! EB 3;ܯBGn<  W2/2Q%q A$U9ձ*$C$cJ*OVVisP6J:*bdiou _7cW_OH$dqB@tϱU~_,ifGcOYL0@'E;k/eЋ;]4YSz{{ΐFƆqk]x_^=G6MW `}$F!MԷ֥]%[v5$,8=Ilպo{s;-L>oY?o47)򝞺S?M4dx9;s9 KۆM!8{jw[Pob_zed翹 }!*A{;t1xC>Ab wjd[?]wq _oOLTA֢ZB4i%_%UXHJ<_e77PCPANPLUS-0.9144/t/dummy-CPAN/authors/01mailrc.txt.gz0000644000175000017500000000021112207704351020751 0ustar bingosbingos_E01mailrc.txtKL,Vp V%׊В̜b++T.RJ:秤*$$;V$%)q%B |"u;7?4'ʩ43'hpgj'hܟ]CPANPLUS-0.9144/t/dummy-CPAN/autobundle/0000755000175000017500000000000012251422462016643 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/autobundle/Snapshot.pm0000644000175000017500000000033612207704351021003 0ustar bingosbingospackage Snapshot; $VERSION = '0.01'; 1; __END__ =head1 NAME Snapshot - Snapshot of your installation at Wed Jan 2 17:46:24 2008 =head1 SYNOPSIS perl -MCPANPLUS -e "install Snapshot" =head1 CONTENTS Foo::Bar 0.01 CPANPLUS-0.9144/t/dummy-CPAN/modules/0000755000175000017500000000000012251422462016151 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-CPAN/modules/03modlist.data.gz0000644000175000017500000000110712207704351021241 0ustar bingosbingos1E03modlist.data]Sk09+.# $!u `[? de(-# &IlƠwzTȡ&L'JZ7Nmld9T͙\p~Yf"mn3{~hVfR l m|~~DSLLN3]3Ѵ+ Ygݲke$\v4-vPo~F[[ }MD/ =N#hP<' Lp=QpЦ:]k0_8^ۂE ZЮX=G-^mOO{>_SCPANPLUS-0.9144/t/dummy-CPAN/modules/02packages.details.txt.gz0000644000175000017500000000066512207704351022705 0ustar bingosbingos7p2J02packages.details.txtQo0w{RUL~)-mDŷ"#P~=ʴQQ`;Yd?Y4(!Dѩ`I&pN|́-Q'|ޡox|v1=[C~Dy#l.)`Un]o5 x7UO[Cntf[~=Fp>Dxi>ZBQg %L{r"pTo0!EK*٥7ܥF@J_AǢx7;ZQ١5wʚVŞ2,Di)[@YTK# ,B &-|X}el᜔R+)pWW<&g17KOU7`Upv~H<iDj81AHo^B32cO$}(~p!&b@q~lCPANPLUS-0.9144/t/21_CPANPLUS-Dist-No-Build.t0000644000175000017500000000757112207704351017066 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use Module::Loaded; use Object::Accessor; use CPANPLUS::Dist; use CPANPLUS::Backend; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; my $Conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $Conf ); my $Inst = INSTALLER_BUILD; ### set the config so that we will ignore the build installer, ### but prefer it anyway { Module::Loaded::mark_as_loaded( $Inst ); CPANPLUS::Dist->_ignore_dist_types( $Inst ); $Conf->set_conf( prefer_makefile => 0 ); } my $Mod = $CB->module_tree( 'Foo::Bar::MB::NOXS' ); ok( $Mod, "Module object retrieved" ); ok( not grep { $_ eq $Inst } CPANPLUS::Dist->dist_types, " $Inst installer not returned" ); ### fetch the file first { my $where = $Mod->fetch; ok( -e $where, " Tarball '$where' exists" ); } ### extract it, silence warnings/messages { my $where = $Mod->extract; ok( -e $where, " Tarball extracted to '$where'" ); } ### check the installer type { is( $Mod->status->installer_type, $Inst, "Proper installer type found: $Inst" ); my $href = $Mod->status->configure_requires; ok( scalar(keys(%$href)), " Dependencies recorded" ); ok( defined $href->{$Inst}, " Dependency on $Inst" ); cmp_ok( $href->{$Inst}, '>', 0, " Minimum version: $href->{$Inst}" ); my $err = CPANPLUS::Error->stack_as_string; like( $err, qr/$Inst/, " Message mentions $Inst" ); like( $err, qr/prerequisites list/, " Message mentions adding prerequisites" ); } ### now run the test, it should trigger the installation of the installer ### XXX whitebox test { no warnings 'redefine'; ### bootstrapping creates a call to $cb->module_tree('c::d::build')->install ### we need to intercept that call my $org_mt = CPANPLUS::Backend->can('module_tree'); local *CPANPLUS::Backend::module_tree = sub { my $self = shift; my $mod = shift; ### return a dummy object if this is the bootstrap call return CPANPLUS::Test::Module->new if $mod eq $Inst; ### otherwise do a regular call return $org_mt->( $self, $mod, @_ ); }; ### bootstrap install call will abort the ->create() call, so catch ### that here eval { $Mod->create( skiptest => 1) }; ok( $@, "Create call aborted at bootstrap phase" ); like( $@, qr/$Inst/, " Diagnostics confirmed" ); my $diag = CPANPLUS::Error->stack_as_string; like( $diag, qr/This module requires.*$Inst/, " Dependency on $Inst recorded" ); like( $diag, qr/Bootstrapping installer.*$Inst/, " Bootstrap notice recorded" ); like( $diag, qr/Installer '$Inst' successfully bootstrapped/, " Successful bootstrap recorded" ); } END { unless ( ON_CYGWIN ) { 1 while unlink output_file() } } ### place holder package to serve as a module object for C::D::Build { package CPANPLUS::Test::Module; sub new { return bless {} } sub install { ### at load time we ignored C::D::Build. Reset the ignore here ### so a 'rescan' after the 'install' picks up C::D::Build CPANPLUS::Dist->_reset_dist_ignore; return 1; } } ### test package for cpanplus::dist::build { package CPANPLUS::Dist::Build; use base 'CPANPLUS::Dist::Base'; ### shortcut out of the installation procedure sub new { die __PACKAGE__ }; sub format_available { 1 } sub init { 1 } sub prepare { 1 } sub create { 1 } sub install { 1 } } CPANPLUS-0.9144/t/04_CPANPLUS-Module.t0000644000175000017500000003037312207704351015776 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use CPANPLUS::Configure; use CPANPLUS::Backend; use CPANPLUS::Module::Fake; use CPANPLUS::Module::Author::Fake; use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Data::Dumper; use File::Spec; use File::Path (); my $Conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $Conf ); ### start with fresh sources ### ok( $CB->reload_indices( update_source => 0 ), "Rebuilding trees" ); my $AuthName = TEST_CONF_AUTHOR; my $Auth = $CB->author_tree( $AuthName ); my $ModName = TEST_CONF_MODULE; my $Mod = $CB->module_tree( $ModName ); my $CoreName = TEST_CONF_PREREQ; my $CoreMod = $CB->module_tree( $CoreName ); isa_ok( $Auth, 'CPANPLUS::Module::Author' ); isa_ok( $Mod, 'CPANPLUS::Module' ); isa_ok( $CoreMod, 'CPANPLUS::Module' ); ### author accessors ### is( $Auth->author, 'ExtUtils::MakeMaker No XS Code', "Author name: " . $Auth->author ); is( $Auth->cpanid, $AuthName, "Author CPANID: " . $Auth->cpanid ); is( $Auth->email, DEFAULT_EMAIL,"Author email: " . $Auth->email ); isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### module accessors ### { my %map = ( ### method ### result module => $ModName, name => $ModName, comment => undef, package => 'Foo-Bar-0.01.tar.gz', path => 'authors/id/EUNOXS', version => '0.01', dslip => ' ', description => undef, mtime => '', author => $Auth, ); my @acc = $Mod->accessors; ok( scalar(@acc), "Retrieved module accessors" ); ### remove private accessors is_deeply( [ sort keys %map ], [ sort grep { $_ !~ /^_/ } @acc ], " About to test all accessors" ); ### check all the accessors while( my($meth,$res) = each %map ) { is( $Mod->$meth, $res, " Mod->$meth: " . ($res || '') ); } ### check accessor objects ### isa_ok( $Mod->parent, 'CPANPLUS::Backend' ); isa_ok( $Mod->author, 'CPANPLUS::Module::Author' ); is( $Mod->author->author, $Auth->author, "Module eq Author" ); } ### convenience methods ### { ok( 1, "Convenience functions" ); is( $Mod->package_name, 'Foo-Bar', " Package name"); is( $Mod->package_version, '0.01', " Package version"); is( $Mod->package_extension, 'tar.gz', " Package extension"); ok( !$Mod->package_is_perl_core, " Package not core"); ok( !$Mod->module_is_supplied_with_perl_core, " Module not core" ); ok( !$Mod->is_bundle, " Package not bundle"); } ### clone & status tests { my $clone = $Mod->clone; ok( $clone, "Module cloned" ); isa_ok( $clone, 'CPANPLUS::Module' ); for my $acc ( $Mod->accessors ) { is( $clone->$acc, $Mod->$acc, " Clone->$acc matches Mod->$acc " ); } ### XXX whitebox test ok( !$clone->_status, "Status object empty on start" ); my $status = $clone->status; ok( $status, " Status object defined after query" ); is( $status, $clone->_status, " Object stored as expected" ); isa_ok( $status, 'Object::Accessor' ); } { ### extract + error test ### ok( !$Mod->extract(), "Cannot extract unfetched file" ); like( CPANPLUS::Error->stack_as_string, qr/You have not fetched/, " Error properly logged" ); } { ### fetch tests ### ### enable signature checks for checksums ### my $old = $Conf->get_conf('signature'); $Conf->set_conf(signature => 1); my $where = $Mod->fetch( force => 1 ); ok( $where, "Module fetched" ); ok( -f $where, " Module is a file" ); ok( -s $where, " Module has size" ); $Conf->set_conf( signature => $old ); } { ### extract tests ### my $dir = $Mod->extract( force => 1 ); ok( $dir, "Module extracted" ); ok( -d $dir, " Dir exsits" ); } { ### readme tests ### my $readme = $Mod->readme; ok( length $readme, "Readme found" ); is( $readme, $Mod->status->readme, " Readme stored in module object" ); } { ### checksums tests ### SKIP: { skip(q[You chose not to enable checksum verification], 5) unless $Conf->get_conf('md5'); my $cksum_file = $Mod->checksums; ok( $cksum_file, "Checksum file found" ); is( $cksum_file, $Mod->status->checksums, " File stored in module object" ); ok( -e $cksum_file, " File exists" ); ok( -s $cksum_file, " File has size" ); ### XXX test checksum_value if there's digest::md5 + config wants it ok( $Mod->status->checksum_ok, " Checksum is ok" ); ### check ttl code for checksums; fetching it now means the cache ### should kick in { CPANPLUS::Error->flush; ok( $Mod->checksums, " Checksums re-fetched" ); like( CPANPLUS::Error->stack_as_string, qr/Using cached file/, " Cached file used" ); } } } { ### installer type tests ### my $installer = $Mod->get_installer_type; ok( $installer, "Installer found" ); is( $installer, INSTALLER_MM, " Proper installer found" ); } { ### check signature tests ### SKIP: { skip(q[You chose not to enable signature checks], 1) unless $Conf->get_conf('signature'); ok( $Mod->check_signature, "Signature check OK" ); } } ### dslip & related { my $dslip = $Mod->dslip; ok( $dslip, "Got dslip information from $ModName ($dslip)" ); ### now find it for a submodule { my $submod = $CB->module_tree( TEST_CONF_MODULE_SUB ); ok( $submod, " Found submodule " . $submod->name ); ok( $submod->dslip, " Got dslip info (".$submod->dslip.")" ); is( $submod->dslip, $dslip, " It's identical to $ModName" ); } } SKIP: { ### details() test ### skip 'This no longer works', 1; my $href = { 'Support Level' => 'Developer', 'Package' => $Mod->package, 'Development Stage' => 'under construction but pre-alpha (not yet released)', 'Author' => sprintf("%s (%s)", $Auth->author, $Auth->email), 'Version on CPAN' => $Mod->version, 'Language Used' => 'Perl-only, no compiler needed, should be platform independent', 'Interface Style' => 'Object oriented using blessed references and/or inheritance', 'Public License' => 'Unknown', ### XXX we can't really know what you have installed ### #'Version Installed' => '0.06', }; my $res = $Mod->details; ### delete they key of which we don't know the value ### delete $res->{'Version Installed'}; is_deeply( $res, $href, "Details OK" ); } { ### contians() test ### ### XXX ->contains works based on package name. in our sourcefiles ### we use 4x the same package name for different modules. So use ### the only unique package name here, which is the one for the core mod my @list = $CoreMod->contains; ok( scalar(@list), "Found modules contained in this one" ); is_deeply( \@list, [$CoreMod], " Found all modules expected" ); } { ### testing distributions() ### my @mdists = $Mod->distributions; is( scalar @mdists, 1, "Distributions found via module" ); my @adists = $Auth->distributions; is( scalar @adists, 3, "Distributions found via author" ); } { ### test status->flush ### ok( $Mod->status->mk_flush, "Status flushed" ); ok(!$Mod->status->fetch," Fetch status empty" ); ok(!$Mod->status->extract, " Extract status empty" ); ok(!$Mod->status->checksums, " Checksums status empty" ); ok(!$Mod->status->readme, " Readme status empty" ); } { ### testing bundles ### my $bundle = $CB->module_tree('Bundle::Foo::Bar'); isa_ok( $bundle, 'CPANPLUS::Module' ); ok( $bundle->is_bundle, " It's a Bundle:: module" ); ok( $bundle->fetch, " Fetched the bundle" ); ok( $bundle->extract, " Extracted the bundle" ); my @objs = $bundle->bundle_modules; is( scalar(@objs), 5, " Found all prerequisites" ); for( @objs ) { isa_ok( $_, 'CPANPLUS::Module', " Prereq " . $_->module ); ok( defined $bundle->status->prereqs->{$_->module}, " Prereq was registered" ); } } { ### testing autobundles my $file = File::Spec->catfile( dummy_cpan_dir(), $Conf->_get_build('autobundle'), 'Snapshot.pm' ); my $uri = $CB->_host_to_uri( scheme => 'file', path => $file ); my $bundle = $CB->parse_module( module => $uri ); ok( -e $file, "Creating bundle from '$file'" ); ok( $bundle, " Object created" ); isa_ok( $bundle, 'CPANPLUS::Module', " Object" ); ok( $bundle->is_bundle, " Recognized as bundle" ); ok( $bundle->is_autobundle, " Recognized as autobundle" ); my $type = $bundle->get_installer_type; ok( $type, " Found installer type" ); is( $type, INSTALLER_AUTOBUNDLE, " Installer type is $type" ); my $where = $bundle->fetch; ok( $where, " Autobundle fetched" ); ok( -e $where, " File exists" ); my @list = $bundle->bundle_modules; ok( scalar(@list), " Prereqs found" ); is( scalar(@list), 1, " Right number of prereqs" ); isa_ok( $list[0], 'CPANPLUS::Module', " Object" ); ### skiptests to make sure we don't get any test header mismatches my $rv = $bundle->create( prereq_target => 'create', skiptest => 1 ); ok( $rv, " Tested prereqs" ); } ### test module from perl core ### { isa_ok( $CoreMod, 'CPANPLUS::Module', "Core module " . $CoreName ); ok( $CoreMod->package_is_perl_core, " Package found in perl core" ); ### check if it's core with 5.6.1 { local $] = '5.006001'; ok( $CoreMod->module_is_supplied_with_perl_core, " Module also found in perl core"); } ok( !$CoreMod->install, " Package not installed" ); like( CPANPLUS::Error->stack_as_string, qr/core Perl/, " Error properly logged" ); } ### test third-party modules SKIP: { skip "Module::ThirdParty not installed", 10 unless eval { require Module::ThirdParty; 1 }; ok( !$Mod->is_third_party, "Not a 3rd party module: ". $Mod->name ); my $fake = $CB->parse_module( module => 'LOCAL/SVN-Core-1.0' ); ok( $fake, "Created module object for ". $fake->name ); ok( $fake->is_third_party, " It is a 3rd party module" ); my $info = $fake->third_party_information; ok( $info, "Got 3rd party package information" ); isa_ok( $info, 'HASH' ); for my $item ( qw[name url author author_url] ) { ok( length($info->{$item}), " $item field is filled" ); } } ### testing EU::Installed methods in Dist::MM tests ### # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/15_CPANPLUS-Shell.t0000644000175000017500000001170112207704351015614 0ustar bingosbingos### the shell prints to STDOUT, so capture that here ### and we can check the output ### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } ### this lets us capture output from the default shell { no warnings 'redefine'; my $out; *CPANPLUS::Shell::Default::__print = sub { my $self = shift; $out .= "@_"; }; sub _out { $out } sub _reset_out { $out = '' } } use strict; use Test::More 'no_plan'; use CPANPLUS::Internals::Constants; ### in some subprocesses, the Term::ReadKey code will go ### balistic and die because it can't figure out terminal ### dimensions. If we add these env vars, it'll use them ### as a default and not die. Thanks to Slaven Rezic for ### reporting this. local $ENV{'COLUMNS'} = 80 unless $ENV{'COLUMNS'}; local $ENV{'LINES'} = 40 unless $ENV{'LINES'}; my $Conf = gimme_conf(); my $Class = 'CPANPLUS::Shell'; my $Default = SHELL_DEFAULT; my $TestMod = TEST_CONF_MODULE; my $TestAuth= TEST_CONF_AUTHOR; unless ( -t ) { ok('We are not on a terminal'); exit 0; } ### basic load tests use_ok( $Class, 'Default' ); is( $Class->which, SHELL_DEFAULT, "Default shell loaded" ); ### create an object my $Shell = $Class->new( $Conf ); ok( $Shell, " New object created" ); isa_ok( $Shell, $Default, " Object" ); ### method tests { ### uri to use for /cs tests my $cs_path = File::Spec->rel2abs( File::Spec->catfile( $FindBin::Bin, TEST_CONF_CPAN_DIR, ) ); my $cs_uri = $Shell->backend->_host_to_uri( scheme => 'file', host => '', path => $cs_path, ); my $base = $Conf->get_conf('base'); ### XXX have to keep the list ordered, as some methods only work as ### expected *after* others have run my @map = ( 'v' => qr/CPANPLUS/, '! $self->__print($$)' => qr/$$/, '?' => qr/\[General\]/, 'h' => qr/\[General\]/, 's' => qr/Unknown type/, 's conf' => qr/$Default/, 's program' => qr/sudo/, 's mirrors' => do { my $re = TEST_CONF_CPAN_DIR; qr/$re/ }, 's selfupdate' => qr/selfupdate/, 'b' => qr/autobundle/, "a $TestAuth" => qr/$TestAuth/, "m $TestMod" => qr/$TestMod/, "w" => qr/$TestMod/, "r 1" => qr/README/, "r $TestMod" => qr/README/, "f $TestMod" => qr/$TestAuth/, "d $TestMod" => qr/$TestMod/, ### XXX this one prints to stdout in a subprocess -- skipping this ### for now due to possible PERL_CORE issues #"t $TestMod" => qr/$TestMod.*tested successfully/i, "l $TestMod" => qr/$TestMod/, '! die $$; p' => qr/$$/, '/plugins' => qr/Available plugins:/i, '/? ?' => qr/usage/i, ### custom source plugin tests ### lower case path matching, as on VMS we can't predict case "/? cs" => qr|/cs|, "/cs --add $cs_uri" => qr/Added remote source/, "/cs --list" => do { my $re = quotemeta($cs_uri); qr/$re/i }, "/cs --contents $cs_uri" => qr/$TestAuth/i, "/cs --update" => qr/Updated remote sources/, "/cs --update $cs_uri" => qr/Updated remote sources/, ### --write leaves a file that we should clean up, so make ### sure it's in the path that we clean up already anyway "/cs --write $base" => qr/Wrote remote source index/, "/cs --remove $cs_uri" => qr/Removed remote source/, ); my $meth = 'dispatch_on_input'; can_ok( $Shell, $meth ); while( my($input,$out_re) = splice(@map, 0, 2) ) { ### empty output cache __PACKAGE__->_reset_out; CPANPLUS::Error->flush; ok( 1, "Testing '$input'" ); $Shell->$meth( input => $input ); my $out = __PACKAGE__->_out; ### XXX remove me #diag( $out ); ok( $out, " Output received" ); like( $out, $out_re, " Output matches '$out_re'" ); } } __END__ #### test separately, they have side effects 'q' => qr/^$/, # no output! 's save boxed' => do { my $re = CONFIG_BOXED; qr/$re/ }, ### this doens't write any output 'x --update_source' => qr/module tree/i, s edit s reconfigure 'c' => '_reports', 'i' => '_install', 'u' => '_uninstall', 'z' => '_shell', ### might not have any out of date modules... 'o' => '_uptodate', CPANPLUS-0.9144/t/dummy-perl/0000755000175000017500000000000012251422462014722 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/lib/0000755000175000017500000000000012251422462015470 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/lib/.hidden0000644000175000017500000000000012207704351016713 0ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/man/0000755000175000017500000000000012251422462015475 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/man/man3/0000755000175000017500000000000012251422462016333 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/man/man3/.hidden0000644000175000017500000000000012207704351017556 0ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/man/man1/0000755000175000017500000000000012251422462016331 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/man/man1/.hidden0000644000175000017500000000000012207704351017554 0ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/bin/0000755000175000017500000000000012251422462015472 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-perl/bin/.hidden0000644000175000017500000000000012207704351016715 0ustar bingosbingosCPANPLUS-0.9144/t/09_CPANPLUS-Internals-Search.t0000644000175000017500000000431212207704351017712 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use Data::Dumper; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; my $Conf = gimme_conf(); my $CB = CPANPLUS::Backend->new($Conf); my $ModName = TEST_CONF_MODULE; my $Mod = $CB->module_tree( $ModName ); ### search for modules ### for my $type ( CPANPLUS::Module->accessors() ) { ### don't muck around with references/objects ### or private identifiers next if ref $Mod->$type() or $type =~/^_/; my @aref = $CB->search( type => $type, allow => [$Mod->$type()], ); ok( scalar @aref, "Module found by '$type'" ); for( @aref ) { ok( IS_MODOBJ->($_)," Module isa module object" ); } } ### search for authors ### my $auth = $Mod->author; for my $type ( CPANPLUS::Module::Author->accessors() ) { ### don't muck around with references/objects ### or private identifiers next if ref $auth->$type() or $type =~/^_/; my @aref = $CB->search( type => $type, allow => [$auth->$type()], ); ok( @aref, "Author found by '$type'" ); for( @aref ) { ok( IS_AUTHOBJ->($_), " Author isa author object" ); } } { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= "@_"; }; { ### try search that will yield nothing ### ### XXX SOURCEFILES FIX my @list = $CB->search( type => 'module', allow => [$ModName.$$] ); is( scalar(@list), 0, "Valid search yields no results" ); is( $warning, '', " No warnings issued" ); } { ### try bogus arguments ### my @list = $CB->search( type => '', allow => ['foo'] ); is( scalar(@list), 0, "Broken search yields no results" ); like( $warning, qr/^Key 'type'.* is of invalid type for/, " Got a warning for wrong arguments" ); } } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/inc/0000755000175000017500000000000012251422462013400 5ustar bingosbingosCPANPLUS-0.9144/t/inc/conf.pl0000644000175000017500000002421312207704351014665 0ustar bingosbingos### On VMS, the ENV is not reset after the program terminates. ### So reset it here explicitly my ($old_env_path, $old_env_perl5lib); BEGIN { use FindBin; use File::Spec; ### paths to our own 'lib' and 'inc' dirs ### include them, relative from t/ my @paths = map { "$FindBin::Bin/$_" } qw[../lib inc]; ### absolute'ify the paths in @INC; my @rel2abs = map { File::Spec->rel2abs( $_ ) } grep { not File::Spec->file_name_is_absolute( $_ ) } @INC; ### use require to make devel::cover happy require lib; for ( @paths, @rel2abs ) { my $l = 'lib'; $l->import( $_ ) } use Config; ### and add them to the environment, so shellouts get them $old_env_perl5lib = $ENV{'PERL5LIB'}; $ENV{'PERL5LIB'} = join $Config{'path_sep'}, grep { defined } $ENV{'PERL5LIB'}, @paths, @rel2abs; ### add our own path to the front of $ENV{PATH}, so that cpanp-run-perl ### and friends get picked up $old_env_path = $ENV{PATH}; if ( $ENV{PERL_CORE} ) { $ENV{'PATH'} = join $Config{'path_sep'}, grep { defined } "$FindBin::Bin/../../../utils", $ENV{'PATH'}; } else { $ENV{'PATH'} = join $Config{'path_sep'}, grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'}; } ### Fix up the path to perl, as we're about to chdir ### but only under perlcore, or if the path contains delimiters, ### meaning it's relative, but not looked up in your $PATH $^X = File::Spec->rel2abs( $^X ) if $ENV{PERL_CORE} or ( $^X =~ m|[/\\]| ); ### chdir to our own test dir, so we know all files are relative ### to this point, no matter whether run from perlcore tests or ### regular CPAN installs chdir "$FindBin::Bin" if -d "$FindBin::Bin" } BEGIN { use IPC::Cmd; ### Win32 has issues with redirecting FD's properly in IPC::Run: ### Can't redirect fd #4 on Win32 at IPC/Run.pm line 2801 $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32'; $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32'; } ### Use a $^O comparison, as depending on module at this time ### may cause weird errors/warnings END { if ($^O eq 'VMS') { ### VMS environment variables modified by this test need to be put back ### path is "magic" on VMS, we can not tell if it really existed before ### this was run, because VMS will magically pretend that a PATH ### environment variable exists set to the current working directory $ENV{PATH} = $old_env_path; if (defined $old_env_perl5lib) { $ENV{PERL5LIB} = $old_env_perl5lib; } else { delete $ENV{PERL5LIB}; } } } use strict; use CPANPLUS::Configure; use CPANPLUS::Error (); use File::Path qw[rmtree]; use FileHandle; use File::Basename qw[basename]; { ### Force the ignoring of .po files for L::M::S $INC{'Locale::Maketext::Lexicon.pm'} = __FILE__; $Locale::Maketext::Lexicon::VERSION = 0; } my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE'; # prereq has to be in our package file && core! use constant TEST_CONF_PREREQ => 'Cwd'; use constant TEST_CONF_MODULE => 'Foo::Bar::EU::NOXS'; use constant TEST_CONF_MODULE_SUB => 'Foo::Bar::EU::NOXS::Sub'; use constant TEST_CONF_AUTHOR => 'EUNOXS'; use constant TEST_CONF_INST_MODULE => 'Foo::Bar'; use constant TEST_CONF_INVALID_MODULE => 'fnurk'; use constant TEST_CONF_MIRROR_DIR => 'dummy-localmirror'; use constant TEST_CONF_CPAN_DIR => 'dummy-CPAN'; use constant TEST_CONF_CPANPLUS_DIR => 'dummy-cpanplus'; use constant TEST_CONF_INSTALL_DIR => File::Spec->rel2abs( File::Spec->catdir( TEST_CONF_CPANPLUS_DIR, 'install' ) ); sub dummy_cpan_dir { ### VMS needs this in directory format for rel2abs my $test_dir = $^O eq 'VMS' ? File::Spec->catdir(TEST_CONF_CPAN_DIR) : TEST_CONF_CPAN_DIR; ### Convert to an absolute file specification my $abs_test_dir = File::Spec->rel2abs($test_dir); ### According to John M: the hosts path needs to be in UNIX format. ### File::Spec::Unix->rel2abs does not work at all on VMS $abs_test_dir = VMS::Filespec::unixify( $abs_test_dir ) if $^O eq 'VMS'; return $abs_test_dir; } sub gimme_conf { ### don't load any other configs than the heuristic one ### during tests. They might hold broken/incorrect data ### for our test suite. Bug [perl #43629] showed this. local $ENV{PERL5_CPANPLUS_HOME} = ''; my $conf = CPANPLUS::Configure->new( load_configs => 0 ); my $dummy_cpan = dummy_cpan_dir(); $conf->set_conf( hosts => [ { path => $dummy_cpan, scheme => 'file', } ], ); $conf->set_conf( base => File::Spec->rel2abs(TEST_CONF_CPANPLUS_DIR)); $conf->set_conf( dist_type => '' ); $conf->set_conf( signature => 0 ); $conf->set_conf( allow_unknown_prereqs => 1 ); # just to make sure, eh $conf->set_conf( verbose => 1 ) if $ENV{ $Env }; ### never use a pager in the test suite $conf->set_program( pager => '' ); $conf->set_conf( enable_custom_sources => 0 ); ### dmq tells us that we should run with /nologo ### if using nmake, as it's very noisy otherwise. { my $make = $conf->get_program('make'); if( $make and basename($make) =~ /^nmake/i ) { $conf->set_conf( makeflags => '/nologo' ); } } ### CPANPLUS::Config checks 3 specific scenarios first ### when looking for cpanp-run-perl: parallel to cpanp, ### parallel to CPANPLUS.pm, or installed into a custom ### prefix like /tmp/foo. Only *THEN* does it check the ### the path. ### If the perl core is extracted to a directory that has ### cpanp-run-perl installed the same amount of 'uplevels' ### as the /tmp/foo prefix, we'll pull in the wrong script ### by accident. ### Since we set the path to cpanp-run-perl explicitly ### at the top of this script, it's best to update the config ### ourselves with a path lookup, rather than rely on its ### heuristics. Thanks to David Wheeler, Josh Jore and Vincent ### Pit for helping to track this down. if( $ENV{PERL_CORE} ) { $conf->set_program( "perlwrapper" => IPC::Cmd::can_run('cpanp-run-perl') ); } $conf->set_conf( source_engine => $ENV{CPANPLUS_SOURCE_ENGINE} ) if $ENV{CPANPLUS_SOURCE_ENGINE}; _clean_test_dir( [ $conf->get_conf('base'), TEST_CONF_MIRROR_DIR, # TEST_INSTALL_DIR_LIB, # TEST_INSTALL_DIR_BIN, # TEST_INSTALL_DIR_MAN1, # TEST_INSTALL_DIR_MAN3, ], ( $ENV{PERL_CORE} ? 0 : 1 ) ); return $conf; }; { my $fh; my $file = ".".basename($0).".output"; sub output_handle { return $fh if $fh; $fh = FileHandle->new(">$file") or warn "Could not open output file '$file': $!"; $fh->autoflush(1); return $fh; } sub output_file { return $file } ### redirect output from msg() and error() output to file unless( $ENV{$Env} ) { print "# To run tests in verbose mode, set ". "\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE}; 1 while unlink $file; # just in case $CPANPLUS::Error::ERROR_FH = $CPANPLUS::Error::ERROR_FH = output_handle(); $CPANPLUS::Error::MSG_FH = $CPANPLUS::Error::MSG_FH = output_handle(); } } ### clean these files if we're under perl core END { if ( $ENV{PERL_CORE} ) { close output_handle(); 1 while unlink output_file(); _clean_test_dir( [ gimme_conf->get_conf('base'), TEST_CONF_MIRROR_DIR, # TEST_INSTALL_DIR_LIB, # TEST_INSTALL_DIR_BIN, # TEST_INSTALL_DIR_MAN1, # TEST_INSTALL_DIR_MAN3, ], 0 ); # DO NOT be verbose under perl core -- makes tests fail } } ### whenever we start a new script, we want to clean out our ### old files from the test '.cpanplus' dir.. sub _clean_test_dir { my $dirs = shift || []; my $verbose = shift || 0; for my $dir ( @$dirs ) { ### no point if it doesn't exist; next unless -d $dir; my $dh; opendir $dh, $dir or die "Could not open basedir '$dir': $!"; while( my $file = readdir $dh ) { next if $file =~ /^\./; # skip dot files my $path = File::Spec->catfile( $dir, $file ); ### directory, rmtree it if( -d $path ) { ### John Malmberg reports yet another VMS issue: ### A directory name on VMS in VMS format ends with .dir ### when it is referenced as a file. ### In UNIX format traditionally PERL on VMS does not remove the ### '.dir', however the VMS C library conversion routines do ### remove the '.dir' and the VMS C library routines can not ### handle the '.dir' being present on UNIX format filenames. ### So code doing the fixup has on VMS has to be able to handle ### both UNIX format names and VMS format names. ### XXX See http://www.xray.mpe.mpg.de/ ### mailing-lists/perl5-porters/2007-10/msg00064.html ### for details -- the below regex could use some touchups ### according to John. M. $file =~ s/\.dir$//i if $^O eq 'VMS'; my $dirpath = File::Spec->catdir( $dir, $file ); print "# Deleting directory '$dirpath'\n" if $verbose; eval { rmtree( $dirpath ) }; warn "Could not delete '$dirpath' while cleaning up '$dir'" if $@; ### regular file } else { print "# Deleting file '$path'\n" if $verbose; 1 while unlink $path; } } close $dh; } return 1; } 1; CPANPLUS-0.9144/t/dummy-cpanplus/0000755000175000017500000000000012251422462015605 5ustar bingosbingosCPANPLUS-0.9144/t/dummy-cpanplus/.hidden0000644000175000017500000000000012207704351017030 0ustar bingosbingosCPANPLUS-0.9144/t/19_CPANPLUS-Dist.t0000644000175000017500000003777712207704351015501 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } ### dummy class for testing dist api ### BEGIN { package CPANPLUS::Dist::_Test; use strict; use vars qw[$Available $Create $Install $Init $Prepare @ISA]; @ISA = qw[CPANPLUS::Dist]; $Available = 1; $Create = 1; $Install = 1; $Init = 1; $Prepare = 1; require CPANPLUS::Dist; CPANPLUS::Dist->_add_dist_types( __PACKAGE__ ); sub init { $_[0]->status->mk_accessors( qw[prepared created installed _prepare_args _install_args _create_args]); return $Init }; sub format_available { return $Available } sub prepare { return shift->status->prepared( $Prepare ) } sub create { return shift->status->created( $Create ) } sub install { return shift->status->installed( $Install ) } } use strict; use CPANPLUS::Configure; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Cwd; use Data::Dumper; use File::Basename (); use File::Spec (); use Module::Load::Conditional qw[check_install]; my $conf = gimme_conf(); my $cb = CPANPLUS::Backend->new( $conf ); ### obsolete #my $Format = '_test'; my $Module = 'CPANPLUS::Dist::_Test'; my $ModName = TEST_CONF_MODULE; my $ModPrereq = TEST_CONF_INST_MODULE; ### XXX this version doesn't exist, but we don't check for it either ### my $Prereq = { $ModPrereq => '1000' }; ### since it's in this file, not in its own module file, ### make M::L::C think it already was loaded $Module::Load::Conditional::CACHE->{$Module}->{usable} = 1; use_ok('CPANPLUS::Dist'); ### start with fresh sources ### ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); my $Mod = $cb->module_tree( $ModName ); ok( $Mod, "Got module object" ); ### straight forward dist build - prepare, create, install { my $dist = $Module->new( module => $Mod ); ok( $dist, "New dist object created" ); isa_ok( $dist, 'CPANPLUS::Dist' ); isa_ok( $dist, $Module ); my $status = $dist->status; ok( $status, "Status object found" ); isa_ok( $status, "Object::Accessor" ); ok( $dist->prepare, "Prepare call" ); ok( $dist->status->prepared," Status registered OK" ); ok( $dist->create, "Create call" ); ok( $dist->status->created, " Status registered OK" ); ok( $dist->install, "Install call" ); ok( $dist->status->installed, " Status registered OK" ); } ### check 'sanity check' option ### { local $CPANPLUS::Dist::_Test::Available = 0; ok( !$Module->format_available, "Format availability turned off" ); { $conf->_set_build('sanity_check' => 0); my $dist = $Module->new( module => $Mod ); ok( $dist, "Dist created with sanity check off" ); isa_ok( $dist, $Module ); } { $conf->_set_build('sanity_check' => 1); my $dist = $Module->new( module => $Mod ); ok( !$dist, "Dist not created with sanity check on" ); like( CPANPLUS::Error->stack_as_string, qr/Format '$Module' is not available/, " Error recorded as expected" ); } } ### undef the status hash, make sure it complains ### { local $CPANPLUS::Dist::_Test::Init = 0; my $dist = $Module->new( module => $Mod ); ok( !$dist, "No dist created by failed init" ); like( CPANPLUS::Error->stack_as_string, qr/Dist initialization of '$Module' failed for/s, " Error recorded as expected" ); } ### configure_requires tests { my $meta = META->( $Mod ); ok( $meta, "Reading 'configure_requires' from '$meta'" ); my $clone = $Mod->clone; ok( $clone, " Package cloned" ); ### set the new location to fetch from $clone->package( $meta ); my $file = $clone->fetch; ok( $file, " Meta file fetched" ); ok( -e $file, " File '$file' exits" ); my $dist = $Module->new( module => $Mod ); ok( $dist, " Dist object created" ); my $meth = 'find_configure_requires'; can_ok( $dist, $meth ); my $href = $dist->$meth( file => $file ); ok( $href, " '$meth' returned hashref" ); ok( scalar(keys(%$href)), " Contains entries" ); ok( $href->{ +TEST_CONF_PREREQ }, " Contains the right prereq" ); } ### test _resolve prereqs, in a somewhat simulated set of circumstances { my $old_prereq = $conf->get_conf('prereqs'); my $map = { 0 => { 'Previous install failed' => [ sub { $cb->module_tree($ModPrereq)->status->installed(0); 'install' }, sub { like( CPANPLUS::Error->stack_as_string, qr/failed to install before in this session/s, " Previous install failed recorded ok" ) }, ], "Set $Module->prepare to false" => [ sub { $CPANPLUS::Dist::_Test::Prepare = 0; 'install' }, sub { like( CPANPLUS::Error->stack_as_string, qr/Unable to create a new distribution object/s, " Dist creation failed recorded ok" ) }, sub { like( CPANPLUS::Error->stack_as_string, qr/Failed to install '$ModPrereq' as prerequisite/s, " Dist creation failed recorded ok" ) }, ], "Set $Module->create to false" => [ sub { $CPANPLUS::Dist::_Test::Create = 0; 'install' }, sub { like( CPANPLUS::Error->stack_as_string, qr/Unable to create a new distribution object/s, " Dist creation failed recorded ok" ) }, sub { like( CPANPLUS::Error->stack_as_string, qr/Failed to install '$ModPrereq' as prerequisite/s, " Dist creation failed recorded ok" ) }, ], "Set $Module->install to false" => [ sub { $CPANPLUS::Dist::_Test::Install = 0; 'install' }, sub { like( CPANPLUS::Error->stack_as_string, qr/Failed to install '$ModPrereq' as/s, " Dist installation failed recorded ok" ) }, ], 'Simple ignore' => [ sub { 'ignore' }, sub { ok( !$_[0]->status->prepared, " Module status says not prepared" ) }, sub { ok( !$_[0]->status->created, " Module status says not created" ) }, sub { ok( !$_[0]->status->installed, " Module status says not installed" ) }, ], 'Ignore from conf' => [ sub { $conf->set_conf(prereqs => PREREQ_IGNORE); '' }, sub { ok( !$_[0]->status->prepared, " Module status says not prepared" ) }, sub { ok( !$_[0]->status->created, " Module status says not created" ) }, sub { ok( !$_[0]->status->installed, " Module status says not installed" ) }, ### set the conf back ### sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, ], 'Perl binary version too low' => [ sub { $cb->module_tree( $ModName ) ->status->prereqs({ PERL_CORE, 10000000000 }); '' }, sub { like( CPANPLUS::Error->stack_as_string, qr/needs perl version/, " Perl version not high enough" ) }, ], }, 1 => { 'Simple create' => [ sub { 'create' }, sub { ok( $_[0]->status->prepared, " Module status says prepared" ) }, sub { ok( $_[0]->status->created, " Module status says created" ) }, sub { ok( !$_[0]->status->installed, " Module status says not installed" ) }, ], 'Simple install' => [ sub { 'install' }, sub { ok( $_[0]->status->prepared, " Module status says prepared" ) }, sub { ok( $_[0]->status->created, " Module status says created" ) }, sub { ok( $_[0]->status->installed, " Module status says installed" ) }, ], "Set dependency to be perl-core" => [ sub { $cb->module_tree( $ModPrereq )->package( 'perl-5.8.1.tar.gz' ); 'install' }, sub { like( CPANPLUS::Error->stack_as_string, qr/Prerequisite '$ModPrereq' is perl-core/s, " Dist installation failed recorded ok" ) }, ], 'Install from conf' => [ sub { $conf->set_conf(prereqs => PREREQ_INSTALL); '' }, sub { ok( $_[0]->status->prepared, " Module status says prepared" ) }, sub { ok( $_[0]->status->created, " Module status says created" ) }, sub { ok( $_[0]->status->installed, " Module status says installed" ) }, ], 'Create from conf' => [ sub { $conf->set_conf(prereqs => PREREQ_BUILD); '' }, sub { ok( $_[0]->status->prepared, " Module status says prepared" ) }, sub { ok( $_[0]->status->created, " Module status says created" ) }, sub { ok( !$_[0]->status->installed, " Module status says not installed" ) }, ### set the conf back ### sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, ], 'Ask from conf' => [ sub { $cb->_register_callback( name => 'install_prerequisite', code => sub {1} ); $conf->set_conf(prereqs => PREREQ_ASK); '' }, sub { ok( $_[0]->status->prepared, " Module status says prepared" ) }, sub { ok( $_[0]->status->created, " Module status says created" ) }, sub { ok( $_[0]->status->installed, " Module status says installed" ) }, ### set the conf back ### sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, ], 'Ask from conf, but decline' => [ sub { $cb->_register_callback( name => 'install_prerequisite', code => sub {0} ); $conf->set_conf( prereqs => PREREQ_ASK); '' }, sub { ok( !$_[0]->status->installed, " Module status says not installed" ) }, sub { like( CPANPLUS::Error->stack_as_string, qr/Will not install prerequisite '$ModPrereq' -- Note/, " Install skipped, recorded ok" ) }, ### set the conf back ### sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, ], "Set recursive dependency" => [ sub { $cb->_status->pending_prereqs({ $ModPrereq => 1 }); 'install' }, sub { like( CPANPLUS::Error->stack_as_string, qr/Recursive dependency detected/, " Recursive dependency recorded ok" ) }, ], 'Perl binary version sufficient' => [ sub { $cb->module_tree( $ModName ) ->status->prereqs({ PERL_CORE, 1 }); '' }, sub { unlike( CPANPLUS::Error->stack_as_string, qr/needs perl version/, " Perl version sufficient" ) }, ], }, }; for my $bool ( sort keys %$map ) { diag("Running ". ($bool?'success':'fail') . " tests") if @ARGV; my $href = $map->{$bool}; while ( my($txt,$aref) = each %$href ) { ### reset everything ### ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); $CPANPLUS::Dist::_Test::Available = 1; $CPANPLUS::Dist::_Test::Prepare = 1; $CPANPLUS::Dist::_Test::Create = 1; $CPANPLUS::Dist::_Test::Install = 1; CPANPLUS::Error->flush; $cb->_status->mk_flush; ### get a new dist from Text::Bastardize ### my $mod = $cb->module_tree( $ModName ); my $dist = $Module->new( module => $mod ); ### first sub returns target ### my $sub = shift @$aref; my $target = $sub->(); my $flag = $dist->_resolve_prereqs( format => $Module, force => 1, target => $target, prereqs => ($mod->status->prereqs || $Prereq) ); is( !!$flag, !!$bool, $txt ); ### any extra tests ### $_->($cb->module_tree($ModPrereq)) for @$aref; } } } ### prereq satisfied tests { my $map = { # version regex 0 => undef, 1 => undef, 2 => qr/have to resolve/, }; my $mod = CPANPLUS::Module::Fake->new( module => $$, package => $$, path => $$, version => 1 ); ok( $mod, "Fake module created" ); is( $mod->version, 1, " Version set correctly" ); my $dist = $Module->new( module => $Mod ); ok( $dist, "Dist object created" ); isa_ok( $dist, $Module ); ### scope it for the locals { local $^W; # quell sub redefined warnings; ### is_uptodate will need to return false for this test local *CPANPLUS::Module::Fake::is_uptodate = sub { return }; local *CPANPLUS::Module::Fake::is_uptodate = sub { return }; CPANPLUS::Error->flush; ### it's satisfied while( my($ver, $re) = each %$map ) { my $rv = $dist->prereq_satisfied( version => $ver, modobj => $mod ); ok( 1, "Testing ver: $ver" ); is( $rv, undef, " Return value as expected" ); if( $re ) { like( CPANPLUS::Error->stack_as_string, $re, " Error as expected" ); } CPANPLUS::Error->flush; } } } ### dist_types tests { can_ok( 'CPANPLUS::Dist', 'dist_types' ); SKIP: { skip "You do not have Module::Pluggable installed", 2 unless check_install( module => 'Module::Pluggable' ); my @types = CPANPLUS::Dist->dist_types; ok( scalar(@types), " Dist types found" ); ok( grep( /_Test/, @types), " Found our _Test dist type" ); } } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/031_CPANPLUS-Internals-Source-SQLite.t0000644000175000017500000000474112207704351021165 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Module::Load; use Test::More eval { load 'CPANPLUS::Internals::Source::SQLite'; 1 } ? 'no_plan' : (skip_all => "SQLite engine not available"); use Data::Dumper; use File::Basename qw[dirname]; use CPANPLUS::Error; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; my $conf = gimme_conf(); ### make sure we use the SQLite engine $conf->set_conf( source_engine => 'CPANPLUS::Internals::Source::SQLite' ); my $cb = CPANPLUS::Backend->new( $conf ); my $mod = TEST_CONF_MODULE; my $auth = TEST_CONF_AUTHOR; ok( $cb->reload_indices( update_source => 1 ), "Building trees" ); ok( $cb->__sqlite_dbh, " Got a DBH " ); ok( $cb->__sqlite_file, " Got a DB file" ); ### make sure we have trees and they're hashes { ok( $cb->author_tree, "Got author tree" ); isa_ok( $cb->author_tree, "HASH" ); ok( $cb->module_tree, "Got module tree" ); isa_ok( $cb->module_tree, "HASH" ); } ### save state, shouldn't work { CPANPLUS::Error->flush; my $rv = $cb->save_state; ok( !$rv, "Saving state not implemented" ); like( CPANPLUS::Error->stack_as_string, qr/not implemented/i, " Diagnostics confirmed" ); } ### test look ups { my %map = ( $auth => 'author_tree', $mod => 'module_tree', ); while( my($str, $meth) = each %map ) { ok( $str, "Trying to retrieve $str" ); ok( $cb->$meth( $str ), " Got $str object via ->$meth" ); ok( $cb->$meth->{$str}, " Got author object via ->{ $str }" ); ok( exists $cb->$meth->{ $str }, " Testing exists() " ); ok( not(exists( $cb->$meth->{ $$ } )), " And non-exists() " ); cmp_ok( scalar(keys(%{ $cb->$meth })), ">", 1, " Got keys()" ); cmp_ok( scalar(keys(%{ $cb->$meth })), '==', scalar(keys(%{ $cb->$meth })), " Keys == Values" ); while( my($key,$val) = each %{ $cb->$meth } ) { ok( $key, " Retrieved $key via each()" ); ok( $val, " And value" ); ok( ref $val, " Value is a ref: $val" ); can_ok( $val, '_id' ); } } } CPANPLUS-0.9144/t/30_CPANPLUS-Internals-Selfupdate.t0000644000175000017500000001422612207704351020600 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Data::Dumper; my $conf = gimme_conf(); $conf->set_conf( verbose => 0 ); my $Class = 'CPANPLUS::Selfupdate'; my $ModClass = "CPANPLUS::Selfupdate::Module"; my $CB = CPANPLUS::Backend->new( $conf ); my $Acc = 'selfupdate_object'; my $Conf = $Class->_get_config; my $Dep = TEST_CONF_PREREQ; # has to be in our package file && core! my $Feat = 'some_feature'; my $Prereq = { $Dep => 0 }; ### test the object { ok( $CB, "New backend object created" ); can_ok( $CB, $Acc ); ok( $Conf, "Got configuration hash" ); my $su = $CB->$Acc; ok( $su, "Selfupdate object retrieved" ); isa_ok( $su, $Class ); } ### check specifically if our bundled shells dont trigger a ### dependency (see #26077). ### do this _before_ changing the built in conf! { my $meth = 'modules_for_feature'; my $type = 'shell'; my $cobj = $CB->configure_object; my $cur = $cobj->get_conf( $type ); for my $shell ( SHELL_DEFAULT, SHELL_CLASSIC ) { ok( $cobj->set_conf( $type => $shell ), "Testing dependencies for '$shell'" ); my $rv = $CB->$Acc->$meth( $type => 1); ok( !$rv, " No dependencies for '$shell' -- bundled" ); } for my $shell ( 'CPANPLUS::Test::Shell' ) { ok( $cobj->set_conf( $type => $shell ), "Testing dependencies for '$shell'" ); my $rv = $CB->$Acc->$meth( $type => 1 ); ok( $rv, " Got prereq hash" ); isa_ok( $rv, 'HASH', " Return value" ); is_deeply( $rv, { $shell => '0.0' }, " With the proper entries" ); } } ### test the feature list { ### start with defining our OWN type of config, as not all mentioned ### modules will be present in our bundled package files. ### XXX WHITEBOX TEST!!!! { delete $Conf->{$_} for keys %$Conf; $Conf->{'dependencies'} = $Prereq; $Conf->{'core'} = $Prereq; $Conf->{'features'}->{$Feat} = [ $Prereq, sub { 1 } ]; } is_deeply( $Conf, $Class->_get_config, "Config updated successfully" ); my @cat = $CB->$Acc->list_categories; ok( scalar(@cat), "Category list returned" ); my @feat = $CB->$Acc->list_features; ok( scalar(@feat), "Features list returned" ); ### test if we get modules for each feature for my $feat (@feat) { my $meth = 'modules_for_feature'; my @mods = $CB->$Acc->$meth( $feat ); ok( $feat, "Testing feature '$feat'" ); ok( scalar( @mods ), " Module list returned" ); my $acc = 'is_installed_version_sufficient'; for my $mod (@mods) { isa_ok( $mod, "CPANPLUS::Module" ); isa_ok( $mod, $ModClass ); can_ok( $mod, $acc ); ok( $mod->$acc, " Module uptodate" ); } ### check if we can get a hashref { my $href = $CB->$Acc->$meth( $feat, 1 ); ok( $href, "Got result as hash" ); isa_ok( $href, 'HASH' ); is_deeply( $href, $Prereq, " With the proper entries" ); } } ### see if we can get a list of modules to be updated { my $cat = 'core'; my $meth = 'list_modules_to_update'; ### XXX just test the mechanics, make sure is_uptodate ### returns false ### declare twice because warnings are hateful ### declare in a block to quelch 'sub redefined' warnings. { local *CPANPLUS::Selfupdate::Module::is_uptodate = sub { return }; } local *CPANPLUS::Selfupdate::Module::is_uptodate = sub { return }; my %list = $CB->$Acc->$meth( update => $cat, latest => 1 ); cmp_ok( scalar(keys(%list)), '==', 1, "Got modules for '$cat' from '$meth'" ); my $aref = $list{$cat}; ok( $aref, " Got module list" ); cmp_ok( scalar(@$aref), '==', 1, " With right amount of modules" ); isa_ok( $aref->[0], $ModClass ); is( $aref->[0]->name, $Dep, " With the right name ($Dep)" ); } ### find enabled features { my $meth = 'list_enabled_features'; can_ok( $Class, $meth ); my @list = $CB->$Acc->$meth; ok( scalar(@list), "Retrieved enabled features" ); is_deeply( [$Feat], \@list, " Proper features found" ); } ### find dependencies/core modules for my $meth ( qw[list_core_dependencies list_core_modules] ) { can_ok( $Class, $meth ); my @list = $CB->$Acc->$meth; ok( scalar(@list), "Retrieved modules" ); is( scalar(@list), 1, " 1 Found" ); isa_ok( $list[0], $ModClass ); is( $list[0]->name, $Dep, " Correct module found" ); ### check if we can get a hashref { my $href = $CB->$Acc->$meth( 1 ); ok( $href, "Got result as hash" ); isa_ok( $href, 'HASH' ); is_deeply( $href, $Prereq, " With the proper entries" ); } } ### now selfupdate ourselves { ### XXX just test the mechanics, make sure install returns true ### declare twice because warnings are hateful ### declare in a block to quelch 'sub redefined' warnings. { local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; } local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; my $meth = 'selfupdate'; can_ok( $Class, $meth ); ok( $CB->$Acc->$meth( update => 'all'), " Selfupdate successful" ); } } CPANPLUS-0.9144/t/01_CPANPLUS-Configure.t0000644000175000017500000000777012207704351016474 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use Test::More 'no_plan'; use Data::Dumper; use strict; use CPANPLUS::Internals::Constants; my $Config_pm = 'CPANPLUS/Config.pm'; ### DO NOT FLUSH TILL THE END!!! we depend on all warnings being logged.. for my $mod (qw[CPANPLUS::Configure]) { use_ok($mod) or diag qq[Can't load $mod]; } my $c = CPANPLUS::Configure->new(); isa_ok($c, 'CPANPLUS::Configure'); my $r = $c->conf; isa_ok( $r, 'CPANPLUS::Config' ); ### EU::AI compatibility test ### { my $base = $c->_get_build('base'); ok( defined($base), "Base retrieved by old compat API"); is( $base, $c->get_conf('base'), " Value as expected" ); } for my $cat ( $r->ls_accessors ) { ### what field can they take? ### my @options = $c->options( type => $cat ); ### copy for use on the config object itself my $accessor = $cat; my $prepend = ($cat =~ s/^_//) ? '_' : ''; my $getmeth = $prepend . 'get_'. $cat; my $setmeth = $prepend . 'set_'. $cat; my $addmeth = $prepend . 'add_'. $cat; ok( scalar(@options), "Possible options obtained" ); ### test adding keys too ### { my $add_key = 'test_key'; my $add_val = [1..3]; my $found = grep { $add_key eq $_ } @options; ok( !$found, "Key '$add_key' not yet defined" ); ok( $c->$addmeth( $add_key => $add_val ), " $addmeth('$add_key' => VAL)" ); ### this one now also exists ### push @options, $add_key } ### poke in the object, get the actual hashref out ### my %hash = map { $_ => $r->$accessor->$_ } $r->$accessor->ls_accessors; while( my ($key,$val) = each %hash ) { my $is = $c->$getmeth($key); is_deeply( $val, $is, "deep check for '$key'" ); ok( $c->$setmeth($key => 1 ), " $setmeth('$key' => 1)" ); is( $c->$getmeth($key), 1, " $getmeth('$key')" ); ok( $c->$setmeth($key => $val), " $setmeth('$key' => ORGVAL)" ); } ### now check if we found all the keys with options or not ### delete $hash{$_} for @options; ok( !(scalar keys %hash), "All possible keys found" ); } ### see if we can save the config ### { my $dir = File::Spec->rel2abs('dummy-cpanplus'); my $pm = 'CPANPLUS::Config::Test' . $$; my $file = $c->save( $pm, $dir ); ok( $file, "Config $pm saved" ); ok( -e $file, " File exists" ); ok( -s $file, " File has size" ); ### include our dummy dir when re-scanning { local @INC = ( $dir, @INC ); ok( $c->init( rescan => 1 ), "Reran ->init()" ); } ### make sure this file is now loaded ### XXX can't trust bloody dir separators on Win32 in %INC, ### so rather than an exact match, do a grep... my ($found) = grep /\bTest$$/, values %INC; ok( $found, " Found $file in \%INC" ); ok( -e $file, " File exists" ); 1 while unlink $file; ok(!-e $file, " File removed" ); } { my $env = ENV_CPANPLUS_CONFIG; local $ENV{$env} = $$; my $ok = $c->init; my $stack = CPANPLUS::Error->stack_as_string; ok( $ok, "Reran init again" ); like( $stack, qr/Specifying a config file in your environment/, " Warning logged" ); } { CPANPLUS::Error->flush; { ### try a bogus method call my $x = $c->flubber('foo'); my $err = CPANPLUS::Error->stack_as_string; is ($x, undef, "Bogus method call returns undef"); like($err, "/flubber/", " Bogus method call recognized"); } CPANPLUS::Error->flush; } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/08_CPANPLUS-Backend.t0000644000175000017500000002642012207704351016102 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use File::Basename 'dirname'; use Data::Dumper; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; my $conf = gimme_conf(); my $Class = 'CPANPLUS::Backend'; ### D::C has troubles with the 'use_ok' -- it finds the wrong paths. ### for now, do a 'use' instead #use_ok( $Class ) or diag "$Class not found"; use CPANPLUS::Backend; my $cb = $Class->new( $conf ); isa_ok( $cb, $Class ); my $mt = $cb->module_tree; my $at = $cb->author_tree; ok( scalar keys %$mt, "Module tree has entries" ); ok( scalar keys %$at, "Author tree has entries" ); ### module_tree tests ### my $Name = TEST_CONF_MODULE; my $mod = $cb->module_tree($Name); ### XXX SOURCEFILES FIX { my @mods = $cb->module_tree($Name,$Name); my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE ); ok( IS_MODOBJ->(mod => $mod), "Module object found" ); is( scalar(@mods), 2, " Module list found" ); ok( IS_MODOBJ->(mod => $mods[0]), " ISA module object" ); ok( !IS_MODOBJ->(mod => $none), " Bogus module detected"); } ### author_tree tests ### { my @auths = $cb->author_tree( $mod->author->cpanid, $mod->author->cpanid ); my $none = $cb->author_tree( 'fnurk' ); ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" ); is( scalar(@auths), 2, " Author list found" ); ok( IS_AUTHOBJ->( author => $auths[0] )," ISA author object" ); is( $mod->author, $auths[0], " Objects are identical" ); ok( !IS_AUTHOBJ->( author => $none ), " Bogus author detected" ); } my $conf_obj = $cb->configure_object; ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); ### parse_module tests ### { my @map = ( $Name => [ $mod->author->cpanid, # author $mod->package_name, # package name $mod->version, # version ], $mod => [ $mod->author->cpanid, $mod->package_name, $mod->version, ], 'Foo-Bar-EU-NOXS' => [ $mod->author->cpanid, $mod->package_name, $mod->version, ], 'Foo-Bar-EU-NOXS-0.01' => [ $mod->author->cpanid, $mod->package_name, '0.01', ], 'EUNOXS/Foo-Bar-EU-NOXS' => [ 'EUNOXS', $mod->package_name, $mod->version, ], 'EUNOXS/Foo-Bar-EU-NOXS-0.01' => [ 'EUNOXS', $mod->package_name, '0.01', ], ### existing module, no extension given ### this used to create a modobj with no package extension 'EUNOXS/Foo-Bar-0.02' => [ 'EUNOXS', 'Foo-Bar', '0.02', ], 'Foo-Bar-EU-NOXS-0.09' => [ $mod->author->cpanid, $mod->package_name, '0.09', ], 'MBXS/Foo-Bar-EU-NOXS-0.01' => [ 'MBXS', $mod->package_name, '0.01', ], 'EUNOXS/Foo-Bar-EU-NOXS-0.09' => [ 'EUNOXS', $mod->package_name, '0.09', ], 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' => [ 'EUNOXS', $mod->package_name, '0.09', ], 'FROO/Flub-Flob-1.1.zip' => [ 'FROO', 'Flub-Flob', '1.1', ], 'G/GO/GOYALI/SMS_API_3_01.tar.gz' => [ 'GOYALI', 'SMS_API', '3_01', ], 'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ 'EYCK', 'Net-Lite-FTP', '0.091', ], 'EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ 'EYCK', 'Net-Lite-FTP', '0.091', ], 'M/MA/MAXDB/DBD-MaxDB-7.5.0.24a' => [ 'MAXDB', 'DBD-MaxDB', '7.5.0.24a', ], 'EUNOXS/perl5.005_03.tar.gz' => [ 'EUNOXS', 'perl', '5.005_03', ], 'FROO/Flub-Flub-v1.1.0.tbz' => [ 'FROO', 'Flub-Flub', 'v1.1.0', ], 'FROO/Flub-Flub-1.1_2.tbz' => [ 'FROO', 'Flub-Flub', '1.1_2', ], 'LDS/CGI.pm-3.27.tar.gz' => [ 'LDS', 'CGI', '3.27', ], 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' => [ 'FROO', 'Text-Tabs+Wrap', '2006.1117', ], 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9' => [ 'JETTERO', 'Crypt-PBC', '0.7.20.0-0.4.9' , ], 'GRICHTER/HTML-Embperl-1.2.1.tar.gz' => [ 'GRICHTER', 'HTML-Embperl', '1.2.1', ], 'KANE/File-Fetch-0.15_03' => [ 'KANE', 'File-Fetch', '0.15_03', ], 'AUSCHUTZ/IO-Stty-.02.tar.gz' => [ 'AUSCHUTZ', 'IO-Stty', '.02', ], '.' => [ 'CPANPLUS', 't', '', ], 'Foo/Bar.pm' => [ $mod->author->cpanid, # author $mod->package_name, # package name $mod->version, # version ], ); while ( my($guess, $attr) = splice @map, 0, 2 ) { my( $author, $pkg_name, $version ) = @$attr; ok( $guess, "Attempting to parse $guess" ); my $obj = $cb->parse_module( module => $guess ); ok( $obj, " Result returned" ); ok( IS_MODOBJ->( mod => $obj ), " parse_module success by '$guess'" ); is( $obj->version, $version, " Proper version found: $version" ); is( $obj->package_version, $version, " Found in package_version as well" ); ### VMS doesn't preserve case, so match them after normalizing case is( uc($obj->package_name), uc($pkg_name), " Proper package_name found: $pkg_name" ); unlike( $obj->package_name, qr/\d/, " No digits in package name" ); { my $ext = $obj->package_extension; ok( $ext, " Has extension as well: $ext" ); } like( $obj->author->cpanid, "/$author/i", " Proper author found: $author"); like( $obj->path, "/$author/i", " Proper path found: " . $obj->path ); } ### test for things that look like real modules, but aren't ### { my @map = ( [ $Name . $$ => [ [qr/does not contain an author/,"Missing author part detected"], [qr/Cannot find .+? in the module tree/,"Unable to find module"] ] ], [ {}, => [ [ qr/module string from reference/,"Unable to parse ref"] ] ], ); for my $entry ( @map ) { my($mod,$aref) = @$entry; my $none = $cb->parse_module( module => $mod ); ok( !IS_MODOBJ->(mod => $none), "Non-existent module detected" ); ok( !IS_FAKE_MODOBJ->(mod => $none), "Non-existent fake module detected" ); my $str = CPANPLUS::Error->stack_as_string; for my $pair (@$aref) { my($re,$diag) = @$pair; like( $str, $re," $diag" ); } } } ### test parsing of arbitrary URI for my $guess ( qw[ http://foo/bar.gz http://a/b/c/d/e/f/g/h/i/j flub://floo ] ) { my $obj = $cb->parse_module( module => $guess ); ok( IS_FAKE_MODOBJ->(mod => $obj), "parse_module success by '$guess'" ); is( $obj->status->_fetch_from, $guess, " Fetch from set ok" ); } } ### RV tests ### { my $method = 'readme'; my %args = ( modules => [$Name] ); my $rv = $cb->$method( %args ); ok( IS_RVOBJ->( $rv ), "Got an RV object" ); ok( $rv->ok, " Overall OK" ); cmp_ok( $rv, '==', 1, " Overload OK" ); is( $rv->function, $method, " Function stored OK" ); is_deeply( $rv->args, \%args, " Arguments stored OK" ); is( $rv->rv->{$Name}, $mod->readme, " RV as expected" ); } ### reload_indices tests ### { my $file = File::Spec->catfile( $conf->get_conf('base'), $conf->_get_source('mod'), ); ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); my $age = -M $file; ### make sure we are 'newer' on faster machines with a sleep.. ### apparently Win32's FAT isn't granual enough on intervals ### < 2 seconds, so it may give the same answer before and after ### the sleep, causing the test to fail. so sleep atleast 2 seconds. sleep 2; ok( $cb->reload_indices( update_source => 1 ), "Rebuilding and refetching trees" ); cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); } ### flush tests ### { for my $cache( qw[methods hosts modules lib all] ) { ok( $cb->flush($cache), "Cache $cache flushed ok" ); } } ### installed tests ### { ok( scalar($cb->installed), "Found list of installed modules" ); } ### autobudle tests ### { my $where = $cb->autobundle; ok( $where, "Autobundle written" ); ok( -s $where, " File has size" ); } ### local_mirror tests ### { ### turn off md5 checks for the 'fake' packages we have my $old_md5 = $conf->get_conf('md5'); $conf->set_conf( md5 => 0 ); ### otherwise 'status->fetch' might be undef! ### my $rv = $cb->local_mirror( path => 'dummy-localmirror' ); ok( $rv, "Local mirror created" ); for my $mod ( values %{ $cb->module_tree } ) { my $name = $mod->module; my $cksum = File::Spec->catfile( dirname($mod->status->fetch), CHECKSUMS ); ok( -e $mod->status->fetch, " Module '$name' fetched" ); ok( -s _, " Module '$name' has size" ); ok( -e $cksum, " Checksum fetched for '$name'" ); ok( -s _, " Checksum for '$name' has size" ); } $conf->set_conf( md5 => $old_md5 ); } ### check ENV variable { ### process id { my $name = 'PERL5_CPANPLUS_IS_RUNNING'; ok( $ENV{$name}, "Env var '$name' set" ); is( $ENV{$name}, $$, " Set to current process id" ); } ### Version { my $name = 'PERL5_CPANPLUS_IS_VERSION'; ok( $ENV{$name}, "Env var '$name' set" ); ### version.pm formats ->VERSION output... *sigh* is( $ENV{$name}, $Class->VERSION, " Set to current process version" ); } } __END__ # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/00_CPANPLUS-Internals-Utils.t0000644000175000017500000001265212207704351017602 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; ### make sure to keep the plan -- this is the only test ### supported for 'older' T::H (pre 2.28) -- see Makefile.PL for details use Test::More tests => 48; use Cwd; use Data::Dumper; use File::Spec; use File::Basename; use CPANPLUS::Error; use CPANPLUS::Internals::Utils; # File::Spec and Cwd might return different values for a # symlinked directory, so we need to be careful. sub paths_are_same { my($have, $want, $name) = @_; $have = _resolve_symlinks($have); $want = _resolve_symlinks($want); my $builder = Test::More->builder; return $builder->like( $have, qr/\Q$want/i, $name ); } # Resolve any symlinks in a path sub _resolve_symlinks { my $path = shift; my($vol, $dirs, $file) = File::Spec->splitpath($path); my $resolved = File::Spec->catpath( $vol, "", "" ); for my $dir (File::Spec->splitdir($dirs)) { # Resolve the next part of the path my $next = File::Spec->catdir( $resolved, $dir ); $next = eval { readlink $next } || $next; # If its absolute, use it. # Otherwise tack it onto the end of the previous path. $resolved = File::Spec->file_name_is_absolute($next) ? $next : File::Spec->catdir( $resolved, $next ); } return File::Spec->catfile($resolved, $file); } my $Cwd = File::Spec->rel2abs(cwd()); my $Class = 'CPANPLUS::Internals::Utils'; my $Dir = 'foo'; my $Move = 'bar'; my $File = 'zot'; rmdir $Move if -d $Move; rmdir $Dir if -d $Dir; ### test _mdkir ### { ok( $Class->_mkdir( dir => $Dir), "Created dir '$Dir'" ); ok( -d $Dir, " '$Dir' is a dir" ); } ### test _chdir ### { ok( $Class->_chdir( dir => $Dir), "Chdir to '$Dir'" ); my $abs = File::Spec->rel2abs(File::Spec->catdir($Cwd,$Dir)); paths_are_same( File::Spec->rel2abs(cwd()), $abs, " Cwd() is '$Dir'"); ok( $Class->_chdir( dir => $Cwd), "Chdir back to '$Cwd'" ); paths_are_same( File::Spec->rel2abs(cwd()), $Cwd, " Cwd() is '$Cwd'" ); } ### test _move ### { ok( $Class->_move( file => $Dir, to => $Move ), "Move from '$Dir' to '$Move'" ); ok( -d $Move, " Dir '$Move' exists" ); ok( !-d $Dir, " Dir '$Dir' no longer exists" ); { local $CPANPLUS::Error::ERROR_FH = output_handle(); ### now try to move it somewhere it can't ### ok( !$Class->_move( file => $Move, to => 'inc' ), " Impossible move detected" ); like( CPANPLUS::Error->stack_as_string, qr/Failed to move/, " Expected error found" ); } } ### test _rmdir ### { ok( -d $Move, "Dir '$Move' exists" ); ok( $Class->_rmdir( dir => $Move ), " Deleted dir '$Move'" ); ok(!-d $Move, " Dir '$Move' no longer exists" ); } ### _get_file_contents tests ### { my $contents = $Class->_get_file_contents( file => basename($0) ); ok( $contents, "Got file contents" ); like( $contents, qr/BEGIN/, " Proper contents found" ); like( $contents, qr/CPANPLUS/, " Proper contents found" ); } ### _perl_version tests ### { my $version = $Class->_perl_version( perl => $^X ); ok( $version, "Perl version found" ); like( $version, qr/\d.\d+.\d+/, " Looks like a proper version" ); } ### _version_to_number tests ### { my $map = { '1' => '1', '1.2' => '1.2', '.2' => '.2', 'foo' => '0.0', 'a.1' => '0.0', '1.2.3' => '1.002003', 'v1.2.3' => '1.002003', 'v1.5' => '1.005000', '1.5-a' => '1.500', }; while( my($try,$expect) = each %$map ) { my $ver = $Class->_version_to_number( version => $try ); ok( $ver, "Version returned" ); is( $ver, $expect, " Value as expected" ); } } ### _whoami tests ### { sub foo { my $me = $Class->_whoami; ok( $me, "_whoami returned a result" ); is( $me, 'foo', " Value as expected" ); } foo(); } ### _mode_plus_w tests ### { open my $fh, ">$File" or die "Could not open $File for writing: $!"; close $fh; ### remove perms ok( -e $File, "File '$File' created" ); ok( chmod( 000, $File ), " File permissions set to 000" ); ok( $Class->_mode_plus_w( file => $File ), " File permissions set to +w" ); ok( -w $File, " File is writable" ); 1 while unlink $File; ok( !-e $File, " File removed" ); } ### uri encode/decode tests { my $org = 'file://foo/bar'; my $enc = $Class->_uri_encode( uri => $org ); ok( $enc, "String '$org' encoded" ); like( $enc, qr/%/, " Contents as expected" ); my $dec = $Class->_uri_decode( uri => $enc ); ok( $dec, "String '$enc' decoded" ); is( $dec, $org, " Decoded properly" ); } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/20_CPANPLUS-Dist-MM.t0000644000175000017500000003653312207704351015765 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use CPANPLUS::Configure; use CPANPLUS::Backend; use CPANPLUS::Dist; use CPANPLUS::Dist::MM; use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Cwd; use Config; use Data::Dumper; use File::Basename (); use File::Spec (); my $conf = gimme_conf(); my $cb = CPANPLUS::Backend->new( $conf ); my $File = 'Bar.pm'; ### if we need sudo that's no guarantee we can actually run it ### so set $noperms if sudo is required, as that may mean tests ### fail if you're not allowed to execute sudo. This resolves ### #29904: make test should not use sudo my $noperms = $conf->get_program('sudo') || #you need sudo $conf->get_conf('makemakerflags') || #you set some funky flags not -w $Config{installsitelib}; #cant write to install target #$IPC::Cmd::DEBUG = $Verbose; ### Make sure we get the _EUMM_NOXS_ version my $ModName = TEST_CONF_MODULE; ### This is the module name that gets /installed/ my $InstName = TEST_CONF_INST_MODULE; ### don't start sending test reports now... ### $cb->_callbacks->send_test_report( sub { 0 } ); $conf->set_conf( cpantest => 0 ); ### Redirect errors to file ### *STDERR = output_handle() unless $conf->get_conf('verbose'); ### dont uncomment this, it screws up where STDOUT goes and makes ### test::harness create test counter mismatches #*STDOUT = output_handle() unless @ARGV; ### for the same test-output counter mismatch, we disable verbose ### mode $conf->set_conf( allow_build_interactivity => 0 ); ### start with fresh sources ### ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); ### we might need this Some Day when we're going to install into ### our own sandbox dir.. but for now, no dice due to EU::I bug # $conf->set_program( sudo => '' ); # $conf->set_conf( makemakerflags => TEST_INSTALL_EU_MM_FLAGS ); ### set alternate install dir ### ### XXX rather pointless, since we can't uninstall them, due to a bug ### in EU::Installed (6871). And therefor we can't test uninstall() or any of ### the EU::Installed functions. So, let's just install into sitelib... =/ #my $prefix = File::Spec->rel2abs( File::Spec->catdir(cwd(),'dummy-perl') ); #my $rv = $cb->configure_object->set_conf( makemakerflags => "PREFIX=$prefix" ); #ok( $rv, "Alternate install path set" ); my $Mod = $cb->module_tree( $ModName ); my $InstMod = $cb->module_tree( $InstName ); ok( $Mod, "Loaded object for: " . $Mod->name ); ok( $Mod, "Loaded object for: " . $InstMod->name ); ### format_available tests ### { ok( CPANPLUS::Dist::MM->format_available, "Format is available" ); ### whitebox test! { local $^W; local *CPANPLUS::Dist::MM::can_load = sub { 0 }; ok(!CPANPLUS::Dist::MM->format_available, " Making format unavailable" ); } ### test if the error got logged ok ### like( CPANPLUS::Error->stack_as_string, qr/You do not have .+?'CPANPLUS::Dist::MM' not available/s, " Format failure logged" ); ### flush the stack ### CPANPLUS::Error->flush; } ok( $Mod->fetch, "Fetching module to ".$Mod->status->fetch ); ok( $Mod->extract, "Extracting module to ".$Mod->status->extract ); ### test target => 'init' { my $dist = $Mod->dist( target => TARGET_INIT ); ok( $dist, "Dist created with target => " . TARGET_INIT ); ok( !$dist->status->prepared, " Prepare was not run" ); } ok( $Mod->test, "Testing module" ); ok( $Mod->status->dist_cpan->status->test, " Test success registered as status" ); ok( $Mod->status->dist_cpan->status->prepared, " Prepared status registered" ); ok( $Mod->status->dist_cpan->status->created, " Created status registered" ); is( $Mod->status->dist_cpan->status->distdir, $Mod->status->extract, " Distdir status registered properly" ); ### test the convenience methods ok( $Mod->prepare, "Preparing module" ); ok( $Mod->create, "Creating module" ); ok( $Mod->dist, "Building distribution" ); ok( $Mod->status->dist_cpan, " Dist registered as status" ); isa_ok( $Mod->status->dist_cpan, "CPANPLUS::Dist::MM" ); ### flush the lib cache ### otherwise, cpanplus thinks the module's already installed ### since the blib is already in @INC $cb->_flush( list => [qw|lib|] ); SKIP: { skip(q[No install tests under core perl], 10) if $ENV{PERL_CORE}; skip(q[Possibly no permission to install, skipping], 10) if $noperms; ### we now say 'no perms' if sudo is configured, as per #29904 #diag(q[Note: 'sudo' might ask for your password to do the install test]) # if $conf->get_program('sudo'); ### make sure no options are set in PERL5_MM_OPT, as they might ### change the installation target and therefor will 1. mess up ### the tests and 2. leave an installed copy of our test module ### lying around. This addresses bug #29716: 20_CPANPLUS-Dist-MM.t ### fails (and leaves test files installed) when EUMM options ### include INSTALL_BASE { local $ENV{'PERL5_MM_OPT'}; local $ENV{'PERL_MM_OPT'}; ### add the new dir to the configuration too, so eu::installed tests ### work as they should $conf->set_conf( lib => [ TEST_CONF_INSTALL_DIR ] ); ok( $Mod->install( force => 1, makemakerflags => 'PREFIX='.TEST_CONF_INSTALL_DIR, ), "Installing module" ); } ok( $Mod->status->installed," Module installed according to status" ); SKIP: { ### EU::Installed tests ### ### EU::I sometimes fails. See: ### #43292: ~/CPANPLUS-0.85_04 fails t/20_CPANPLUS-Dist-MM.t ### #46890: ExtUtils::Installed + EU::MM PREFIX= don't always work ### well together skip( "ExtUtils::Installed issue #46890 prevents these tests from running reliably", 8 ); skip( "Old perl on cygwin detected " . "-- tests will fail due to known bugs", 8 ) if ON_OLD_CYGWIN; ### might need it Later when EU::I is fixed.. #local @INC = ( TEST_INSTALL_DIR_LIB, @INC ); { ### validate my @missing = $InstMod->validate; is_deeply( \@missing, [], "No missing files" ); } { ### files my @files = $InstMod->files; ### number of files may vary from OS to OS ok( scalar(@files), "All files accounted for" ); ok( grep( /$File/, @files), " Found the module" ); ### XXX does this work on all OSs? #ok( grep( /man/, @files ), # " Found the manpage" ); } { ### packlist my ($obj) = $InstMod->packlist; isa_ok( $obj, "ExtUtils::Packlist" ); } { ### directory_tree my @dirs = $InstMod->directory_tree; ok( scalar(@dirs), "Directory tree obtained" ); my $found; for my $dir (@dirs) { ok( -d $dir, " Directory exists" ); my $file = File::Spec->catfile( $dir, $File ); $found = $file if -e $file; } ok( -e $found, " Module found" ); } SKIP: { skip("Probably no permissions to uninstall", 1) if $noperms; ok( $InstMod->uninstall,"Uninstalling module" ); } } } ### test exceptions in Dist::MM->create ### { ok( $Mod->status->mk_flush, "Old status info flushed" ); my $dist = INSTALLER_MM->new( module => $Mod ); ok( $dist, "New dist object made" ); ok(!$dist->prepare, " Dist->prepare failed" ); like( CPANPLUS::Error->stack_as_string, qr/No dir found to operate on/, " Failure logged" ); ### manually set the extract dir, $Mod->status->extract($0); ok(!$dist->create, " Dist->create failed" ); like( CPANPLUS::Error->stack_as_string, qr/not successfully prepared/s, " Failure logged" ); ### pretend we've been prepared ### $dist->status->prepared(1); ok(!$dist->create, " Dist->create failed" ); like( CPANPLUS::Error->stack_as_string, qr/Could not chdir/s, " Failure logged" ); } ### writemakefile.pl tests ### { ### remove old status info ok( $Mod->status->mk_flush, "Old status info flushed" ); ok( $Mod->fetch, "Module fetched again" ); ok( $Mod->extract, "Module extracted again" ); ### cheat and add fake prereqs ### my $prereq = TEST_CONF_PREREQ; $Mod->status->prereqs( { $prereq => 0 } ); my $makefile_pl = MAKEFILE_PL->( $Mod->status->extract ); my $makefile = MAKEFILE->( $Mod->status->extract ); my $dist = $Mod->dist; ok( $dist, "Dist object built" ); ### check for a makefile.pl and 'write' one ok( -s $makefile_pl, " Makefile.PL present" ); ok( $dist->write_makefile_pl( force => 0 ), " Makefile.PL written" ); like( CPANPLUS::Error->stack_as_string, qr/Already created/, " Prior existence noted" ); ### ok, unlink the makefile.pl, now really write one 1 while unlink $makefile; ### must do '1 while' for VMS { my $unlink_sts = unlink($makefile_pl); 1 while unlink $makefile_pl; ok( $unlink_sts, "Deleting Makefile.PL"); } sleep 5 if ON_WIN32; ok( !-s $makefile_pl, " Makefile.PL deleted" ); ok( !-s $makefile, " Makefile deleted" ); ok($dist->write_makefile_pl," Makefile.PL written" ); ### see if we wrote anything sensible my $fh = OPEN_FILE->( $makefile_pl ); ok( $fh, "Makefile.PL open for read" ); my $str = do { local $/; <$fh> }; like( $str, qr/### Auto-generated .+ by CPANPLUS ###/, " Autogeneration noted" ); like( $str, '/'. $Mod->module .'/', " Contains module name" ); like( $str, '/'. quotemeta($Mod->version) . '/', " Contains version" ); like( $str, '/'. $Mod->author->author .'/', " Contains author" ); like( $str, '/PREREQ_PM/', " Contains prereqs" ); like( $str, qr/$prereq.+0/, " Contains prereqs" ); close $fh; ### seems ok, now delete it again and go via install() ### to see if it picks up on the missing makefile.pl and ### does the right thing ### must do '1 while' for VMS { my $unlink_sts = unlink($makefile_pl); 1 while unlink $makefile_pl; ok( $unlink_sts, "Deleting Makefile.PL"); } ok( !-s $makefile_pl, " Makefile.PL deleted" ); ok( $dist->status->mk_flush,"Dist status flushed" ); ok( $dist->prepare, " Dist->prepare run again" ); ok( $dist->create, " Dist->create run again" ); ok( -s $makefile_pl, " Makefile.PL present" ); like( CPANPLUS::Error->stack_as_string, qr/attempting to generate one/, " Makefile.PL generation attempt logged" ); ### now let's throw away the makefile.pl, flush the status and not ### write a makefile.pl { local $^W; local *CPANPLUS::Dist::MM::write_makefile_pl = sub { 1 }; 1 while unlink $makefile_pl; 1 while unlink $makefile; ok(!-s $makefile_pl, "Makefile.PL deleted" ); ok(!-s $makefile, "Makefile deleted" ); ok( $dist->status->mk_flush,"Dist status flushed" ); ok(!$dist->prepare, " Dist->prepare failed" ); like( CPANPLUS::Error->stack_as_string, qr/Could not find 'Makefile.PL'/i, " Missing Makefile.PL noted" ); is( $dist->status->makefile, 0, " Did not manage to create Makefile" ); } ### now let's write a makefile.pl that just does 'die' { local $^W; local *CPANPLUS::Dist::MM::write_makefile_pl = __PACKAGE__->_custom_makefile_pl_sub( "exit 1;" ); ### there's no makefile.pl now, since the previous test failed ### to create one #ok( -e $makefile_pl, "Makefile.PL exists" ); #ok( unlink($makefile_pl), " Deleting Makefile.PL"); ok(!-s $makefile_pl, "Makefile.PL deleted" ); ok( $dist->status->mk_flush,"Dist status flushed" ); ok(!$dist->prepare, " Dist->prepare failed" ); like( CPANPLUS::Error->stack_as_string, qr/Could not run/s, " Logged failed 'perl Makefile.PL'" ); is( $dist->status->makefile, 0, " Did not manage to create Makefile" ); } ### clean up afterwards ### ### must do '1 while' for VMS { my $unlink_sts = unlink($makefile_pl); 1 while unlink $makefile_pl; ok( $unlink_sts, "Deleting Makefile.PL"); } $dist->status->mk_flush; } ### test ENV setting in Makefile.PL { ### use print() not die() -- we're redirecting STDERR in tests! my $env = ENV_CPANPLUS_IS_EXECUTING; my $sub = __PACKAGE__->_custom_makefile_pl_sub( "print qq[ENV=\$ENV{$env}\n]; exit 1;" ); my $clone = $Mod->clone; $clone->status->fetch( $Mod->status->fetch ); ok( $clone, 'Testing ENV settings $dist->prepare' ); ok( $clone->extract, ' Files extracted' ); ok( $clone->prepare, ' $mod->prepare worked first time' ); my $dist = $clone->status->dist; my $makefile_pl = MAKEFILE_PL->( $clone->status->extract ); ok( $sub->($dist), " Custom Makefile.PL written" ); ok( -e $makefile_pl, " File exists" ); ### clear errors CPANPLUS::Error->flush; my $rv = $dist->prepare( force => 1, verbose => 0 ); ok( !$rv, ' $dist->prepare failed' ); SKIP: { skip( "Can't test ENV{$env} -- no buffers available", 1 ) unless IPC::Cmd->can_capture_buffer; my $re = quotemeta( $makefile_pl ); like( CPANPLUS::Error->stack_as_string, qr/ENV=$re/, " \$ENV $env set correctly during execution"); } ### and the ENV var should no longer be set now ok( !$ENV{$env}, " ENV var now unset" ); } sub _custom_makefile_pl_sub { my $pkg = shift; my $txt = shift or return; return sub { my $dist = shift; my $self = $dist->parent; my $fh = OPEN_FILE->( MAKEFILE_PL->($self->status->extract), '>' ); print $fh $txt; close $fh; return 1; } } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/05_CPANPLUS-Internals-Fetch.t0000644000175000017500000000651112207704351017535 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use CPANPLUS::Backend; use Test::More 'no_plan'; use Data::Dumper; use File::Spec; use Cwd; use File::Basename; use CPANPLUS::Internals::Constants; my $conf = gimme_conf(); my $cb = CPANPLUS::Backend->new( $conf ); isa_ok($cb, "CPANPLUS::Internals" ); my $mod = $cb->module_tree( TEST_CONF_MODULE ); isa_ok( $mod, 'CPANPLUS::Module' ); ### fail host tests ### { my $host = {}; my $rv = $cb->_add_fail_host( host => $host ); ok( $rv, "Failed host added " ); ok(!$cb->_host_ok( host => $host), " Host registered as failed" ); ok( $cb->_host_ok( host => {} ), " Fresh host unregistered" ); } ### refetch, even if it's there already ### { my $where = $cb->_fetch( module => $mod, force => 1 ); ok( $where, "File downloaded to '$where'" ); ok( -s $where, " File exists" ); unlink $where; ok(!-e $where, " File removed" ); } ### try to fetch something that doesn't exist ### { ### set up a bogus host first ### my $hosts = $conf->get_conf('hosts'); my $fail = { scheme => 'file', path => "$0/$0" }; unshift @$hosts, $fail; $conf->set_conf( hosts => $hosts ); ### the fallback host will get it ### my $where = $cb->_fetch( module => $mod, force => 1, verbose => 0 ); ok($where, "File downloaded to '$where'" ); ok( -s $where, " File exists" ); ### but the error should be recorded ### like( CPANPLUS::Error->stack_as_string, qr/Fetching of .*? failed/s, " Error recorded appropriately" ); ### host marked as bad? ### ok(!$cb->_host_ok( host => $fail ), " Failed host logged properly" ); ### restore the hosts ### shift @$hosts; $conf->set_conf( hosts => $hosts ); } ### try and fetch a URI { my $base = basename($0); ### do an ON_UNIX test, cygwin will fail tests otherwise (#14553) ### create a file URI. Make sure to split it by LOCAL rules ### and JOIN by unix rules, so we get a proper file uri ### otherwise, we might break win32. See bug #18702 my $cwd = cwd(); my $in_file = $^O eq 'VMS' ? VMS::Filespec::unixify( File::Spec->catfile($cwd, $base) ) : File::Spec::Unix->catfile( File::Spec::Unix->catdir( File::Spec->splitdir( $cwd ) ), $base ); my $target = CREATE_FILE_URI->($in_file); my $fake = $cb->parse_module( module => $target ); ok( IS_FAKE_MODOBJ->(mod => $fake), "Fake module created from $0" ); is( $fake->status->_fetch_from, $target, " Fetch from set ok" ); my $where = $fake->fetch; ok( $where, " $target fetched ok" ); ok( -s $where, " $where exists" ); like( $where, '/'. UNKNOWN_DL_LOCATION .'/', " Saved to proper location" ); like( $where, qr/$base$/, " Saved with proper name" ); } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/032_CPANPLUS-Internals-Source-via-sqlite.t0000644000175000017500000000044412207704351022077 0ustar bingosbingosuse strict; use FindBin; use Module::Load; local $ENV{CPANPLUS_SOURCE_ENGINE} = 'CPANPLUS::Internals::Source::SQLite'; my $old = select STDERR; $|++; select $old; $|++; my $rv = do("$FindBin::Bin/03_CPANPLUS-Internals-Source.t") or do { die $@ if $@; die $! if $!; }; CPANPLUS-0.9144/t/02_CPANPLUS-Internals.t0000644000175000017500000001221312207704351016477 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use CPANPLUS::Configure; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; use Module::Load::Conditional qw[can_load]; use Data::Dumper; my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() ); isa_ok($cb, 'CPANPLUS::Internals'); is($cb->_id, $cb->_last_id, "Comparing ID's"); ### delete/store/retrieve id tests ### { my $del = $cb->_remove_id( $cb->_id ); ok( $del, "ID deleted" ); isa_ok( $del, "CPANPLUS::Internals" ); is( $del, $cb, " Deleted ID matches last object" ); my $id = $cb->_store_id( $del ); ok( $id, "ID stored" ); is( $id, $cb->_id, " Stored proper ID" ); my $obj = $cb->_retrieve_id( $id ); ok( $obj, "Object retrieved from ID" ); isa_ok( $obj, 'CPANPLUS::Internals' ); is( $obj->_id, $id, " Retrieved ID properly" ); my @obs = $cb->_return_all_objects(); ok( scalar(@obs), "Returned objects" ); is( scalar(@obs), 1, " Proper amount of objects found" ); is( $obs[0]->_id, $id, " Proper ID found on object" ); my $lid = $cb->_last_id; ok( $lid, "Found last registered ID" ); is( $lid, $id, " ID matches last object" ); my $iid = $cb->_inc_id; ok( $iid, "Incremented ID" ); is( $iid, $id+1, " ID matched last ID + 1" ); } ### host ok test ### { my $host = $cb->configure_object->get_conf('hosts')->[0]; is( $cb->_host_ok( host => $host ), 1, "Host ok" ); is( $cb->_add_fail_host(host => $host), 1, " Host now marked as bad" ); is( $cb->_host_ok( host => $host ), 0, " Host still bad" ); ok( $cb->_flush( list => ['hosts'] ), " Hosts flushed" ); is( $cb->_host_ok( host => $host ), 1, " Host now ok again" ); } ### flush loads test { my $mod = 'Benchmark'; my $file = $mod . '.pm'; ### XXX whitebox test -- mark this module as unloadable $Module::Load::Conditional::CACHE->{$mod}->{usable} = 0; ok( !can_load( modules => { $mod => 0 }, verbose => 0 ), "'$mod' not loaded" ); ok( $cb->flush('load'), " 'load' cache flushed" ); ok( can_load( modules => { $mod => 0 }, verbose => 0 ), " '$mod' loaded" ); } ### add to inc path tests { my $meth = '_add_to_includepath'; can_ok( $cb, $meth ); my $p5lib = $ENV{PERL5LIB} || ''; my $inc = "@INC"; ok( $cb->$meth( directories => [$$] ), " CB->$meth( $$ )" ); my $new_p5lib = $ENV{PERL5LIB}; my $new_inc = "@INC"; isnt( $p5lib, $new_p5lib, " PERL5LIB is now: $new_p5lib" ); like( $new_p5lib, qr/$$/, " Matches $$" ); isnt( $inc, $new_inc, ' @INC is expanded with: ' . $$ ); like( $new_inc, qr/$$/, " Matches $$" ); ok( $cb->$meth( directories => [$$] ), " CB->$meth( $$ ) again" ); is( "@INC", $new_inc, ' @INC unchanged' ); is( $new_p5lib, $ENV{PERL5LIB}, " PERL5LIB unchanged" ); } ### callback registering tests ### { my $callback_map = { ### name default value install_prerequisite => 1, # install prereqs when 'ask' is set? edit_test_report => 0, # edit the prepared test report? send_test_report => 1, # send the test report? munge_test_report => $$, # munge the test report filter_prereqs => $$, # limit prereqs proceed_on_test_failure => 0, # continue on failed 'make test'? munge_dist_metafile => $$, # munge the metailfe }; for my $callback ( keys %$callback_map ) { { my $rv = $callback_map->{$callback}; is( $rv, $cb->_callbacks->$callback->( $0, $$ ), "Default callback '$callback' called" ); like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s, " Default handler warning recorded" ); CPANPLUS::Error->flush; } ### try to register the callback my $ok = $cb->_register_callback( name => $callback, code => sub { return $callback } ); ok( $ok, "Registered callback '$callback' ok" ); my $sub = $cb->_callbacks->$callback; ok( $sub, " Retrieved callback" ); ok( IS_CODEREF->($sub), " Callback is a sub" ); my $rv = $sub->(); ok( $rv, " Callback called ok" ); is( $rv, $callback, " Got expected return value" ); } } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/40_CPANPLUS-Internals-Report.t0000644000175000017500000004606312207704351017764 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants::Report; my $send_tests = 55; my $query_tests = 8; my $total_tests = $send_tests + $query_tests; use Test::More 'no_plan'; use Module::Load::Conditional qw[can_load]; use FileHandle; use Data::Dumper; use constant NOBODY => 'nobody@xs4all.nl'; my $conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $conf ); my $ModName = TEST_CONF_MODULE; my $ModPrereq = TEST_CONF_PREREQ; ### pick a high number, but not ~0 as possibly ~0 is unsigned, and we cause ### an overflow, as happens to version.pm 0.7203 among others. ### ANOTHER bug in version.pm, this time for 64bit: ### https://rt.cpan.org/Ticket/Display.html?id=45241 ### so just use a 'big number'(tm) and go from there. my $HighVersion = 1234567890; my $Mod = $CB->module_tree($ModName); my $int_ver = $CPANPLUS::Internals::VERSION; ### explicitly enable testing if possible ### $CB->configure_object->set_conf(cpantest =>1) if $ARGV[0]; my $map = { all_ok => { buffer => '', # output from build process failed => 0, # indicate failure match => [qw|/PASS/|], # list of regexes for the output check => 0, # check if callbacks got called? }, skipped_test => { buffer => '', failed => 0, match => ['/PASS/', '/tests for this module were skipped during this build/', ], check => 0, skiptests => 1, # did we skip the tests? }, missing_prereq => { buffer => missing_prereq_buffer(), failed => 1, match => ['/The comments above are created mechanically/', '/computer-generated error report/', '/Below is the error stack from stage/', '/test suite seem to fail without these modules/', '/floo/', '/FAIL/', '/make test/', ], check => 1, }, missing_tests => { buffer => missing_tests_buffer(), failed => 1, match => ['/The comments above are created mechanically/', '/computer-generated error report/', '/Below is the error stack from stage/', '/RECOMMENDATIONS/', '/UNKNOWN/', '/make test/', ], check => 0, }, perl_version_too_low_mm => { buffer => perl_version_too_low_buffer_mm(), failed => 1, match => ['/This distribution has been tested/', '/http://testers.cpan.org/', '/NA/', ], check => 0, }, perl_version_too_low_build1 => { buffer => perl_version_too_low_buffer_build(1), failed => 1, match => ['/This distribution has been tested/', '/http://testers.cpan.org/', '/NA/', ], check => 0, }, perl_version_too_low_build2 => { buffer => perl_version_too_low_buffer_build(2), failed => 1, match => ['/This distribution has been tested/', '/http://testers.cpan.org/', '/NA/', ], check => 0, }, prereq_versions_too_low => { ### set the prereq version incredibly high pre_hook => sub { my $mod = shift; my $clone = $mod->clone; $clone->status->prereqs({ $ModPrereq => $HighVersion }); return $clone; }, failed => 1, match => ['/This distribution has been tested/', '/http://testers.cpan.org/', '/NA/', ], check => 0, }, prereq_not_on_cpan => { pre_hook => sub { my $mod = shift; my $clone = $mod->clone; $clone->status->prereqs( { TEST_CONF_INVALID_MODULE, 0 } ); return $clone; }, failed => 1, match => ['/This distribution has been tested/', '/http://testers.cpan.org/', '/NA/', ], check => 0, }, prereq_not_on_cpan_but_core => { pre_hook => sub { my $mod = shift; my $clone = $mod->clone; $clone->status->prereqs( { TEST_CONF_PREREQ, 0 } ); return $clone; }, failed => 1, match => ['/This distribution has been tested/', '/http://testers.cpan.org/', '/UNKNOWN/', ], check => 0, }, }; ### test config settings { for my $opt ( qw[cpantest cpantest_mx] ) { my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; my $org = $conf->get_conf( $opt ); ok( $conf->set_conf( $opt => $$ ), "Setting option $opt to $$" ); is( $conf->get_conf( $opt ), $$, " Retrieved properly" ); ok( $conf->set_conf( $opt => $org ), " Option $opt set back to original" ); ok( !$warnings, " No warnings" ); } } ### test constants ### { { my $to = CPAN_MAIL_ACCOUNT->('foo'); is( $to, 'foo@cpan.org', "Got proper mail account" ); } { ok(RELEVANT_TEST_RESULT->($Mod),"Test is relevant" ); ### test non-relevant tests ### my $cp = $Mod->clone; $cp->module( ($^O eq 'beos' ? 'MSDOS' : 'Be') . '::' . $cp->module ); ok(!RELEVANT_TEST_RESULT->($cp),"Test is irrelevant"); } { my $support = "it works!"; my @support = ( "No support for OS", "OS unsupported", "os unsupported", ); ok(!UNSUPPORTED_OS->($support), "OS supported"); ok( UNSUPPORTED_OS->($_), "OS not supported") for(@support); } { ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_mm() ), "Perl version too low" ); ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(1) ), "Perl version too low" ); ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(2) ), "Perl version too low" ); ok(!PERL_VERSION_TOO_LOW->('foo'), " Perl version adequate" ); } { my $tests = "test.pl"; my @none = ( "No tests defined for Foo extension.", "'No tests defined for Foo::Bar extension.'", "'No tests defined.'", ); ok(!NO_TESTS_DEFINED->($tests), "Tests defined"); ok( NO_TESTS_DEFINED->($_), "No tests defined") for(@none); } { my $fail = 'MAKE TEST'; my $unknown = 'foo'; is( TEST_FAIL_STAGE->($fail), lc $fail, "Proper test fail stage found" ); is( TEST_FAIL_STAGE->($unknown), 'fetch', "Proper test fail stage found" ); } ### test missing prereqs { my $str = q[Can't locate Foo/Bar.pm in @INC]; ### standard test { my @list = MISSING_PREREQS_LIST->( $str ); is( scalar(@list), 1, " List of missing prereqs found" ); is( $list[0], 'Foo::Bar', " Proper prereq found" ); } ### multiple mentions of same prereq { my @list = MISSING_PREREQS_LIST->( $str . $str ); is( scalar(@list), 1, " 1 result for multiple mentions" ); is( $list[0], 'Foo::Bar', " Proper prereq found" ); } } { # cp version, author my $header = REPORT_MESSAGE_HEADER->($int_ver,'foo'); ok( $header, "Test header generated" ); like( $header, qr/Dear foo,/, " Proper content found" ); like( $header, qr/puter-gen/, " Proper content found" ); like( $header, qr/CPANPLUS,/, " Proper content found" ); like( $header, qr/ments may/, " Proper content found" ); } { # stage, buffer my $header = REPORT_MESSAGE_FAIL_HEADER->('test','buffer'); ok( $header, "Test header generated" ); like( $header, qr/uploading/, " Proper content found" ); like( $header, qr/RESULTS:/, " Proper content found" ); like( $header, qr/stack/, " Proper content found" ); like( $header, qr/buffer/, " Proper content found" ); } { my $prereqs = REPORT_MISSING_PREREQS->('foo','bar@example.com','Foo::Bar'); ok( $prereqs, "Test output generated" ); like( $prereqs, qr/'foo \(bar\@example\.com\)'/, " Proper content found" ); like( $prereqs, qr/Foo::Bar/, " Proper content found" ); like( $prereqs, qr/prerequisi/, " Proper content found" ); like( $prereqs, qr/PREREQ_PM/, " Proper content found" ); } { my $prereqs = REPORT_MISSING_PREREQS->(undef,undef,'Foo::Bar'); ok( $prereqs, "Test output generated" ); like( $prereqs, qr/Your Name/, " Proper content found" ); like( $prereqs, qr/Foo::Bar/, " Proper content found" ); like( $prereqs, qr/prerequisi/, " Proper content found" ); like( $prereqs, qr/PREREQ_PM/, " Proper content found" ); } { my $missing = REPORT_MISSING_TESTS->(); ok( $missing, "Missing test string generated" ); like( $missing, qr/tests/, " Proper content found" ); like( $missing, qr/Test::More/, " Proper content found" ); } { my $missing = REPORT_MESSAGE_FOOTER->(); ok( $missing, "Message footer string generated" ); like( $missing, qr/NOTE/, " Proper content found" ); like( $missing, qr/identical/, " Proper content found" ); like( $missing, qr/mistaken/, " Proper content found" ); like( $missing, qr/appreciate/, " Proper content found" ); like( $missing, qr/Additional/, " Proper content found" ); } { my @libs = MISSING_EXTLIBS_LIST->("No library found for -lfoo\nNo library found for -lbar"); ok( @libs, "Missing external libraries found" ); my @list = qw(foo bar); is_deeply( \@libs, \@list, " Proper content found" ); } { my $clone = $Mod->clone; my $prereqs = { $ModPrereq => $HighVersion }; $clone->status->prereqs( $prereqs ); my $str = REPORT_LOADED_PREREQS->( $clone ); like($str, qr/PREREQUISITES:/, "Listed loaded prerequisites" ); like($str, qr/\! $ModPrereq\s+\S+\s+\S+/, " Proper content found" ); } { my $clone = $Mod->clone; my $str = REPORT_TOOLCHAIN_VERSIONS->( $clone ); like($str, qr/toolchain/, "Correct message in report" ); use Cwd; like($str, qr/Cwd\s+\Q$Cwd::VERSION\E/, "Cwd has correct version in report" ); } } ### callback tests { ### as reported in bug 13086, this callback returned the wrong item ### from the list: ### $self->_callbacks->munge_test_report->($Mod, $message, $grade); my $rv = $CB->_callbacks->munge_test_report->( 1..4 ); is( $rv, 2, "Default 'munge_test_report' callback OK" ); } ### test creating test reports ### SKIP: { skip "You have chosen not to enable test reporting", $total_tests, unless $CB->configure_object->get_conf('cpantest'); skip "No report send & query modules installed", $total_tests unless $CB->_have_query_report_modules(verbose => 0); SKIP: { my $mod = $CB->module_tree( TEST_CONF_PREREQ ); # is released to CPAN ok( $mod, "Module retrieved" ); ### so we're not pinned down to this specific version of perl my @list = $mod->fetch_report( all_versions => 1 ); skip "Possibly no net connection, or server down", 7 unless @list; my $href = $list[0]; ok( scalar(@list), "Fetched test report" ); is( ref $href, ref {}, " Return value has hashrefs" ); ok( $href->{grade}, " Has a grade" ); ### XXX use constants for grades? like( $href->{grade}, qr/pass|fail|unknown|na/i, " Grade as expected" ); my $pkg_name = $mod->package_name; ok( $href->{dist}, " Has a dist" ); like( $href->{dist}, qr/$pkg_name/, " Dist as expected" ); ok( $href->{platform}, " Has a platform" ); } skip "No report sending modules installed", $send_tests unless $CB->_have_send_report_modules(verbose => 0); for my $type ( keys %$map ) { ### never enter the editor for test reports ### but check if the callback actually gets called; my $called_edit; my $called_send; $CB->_register_callback( name => 'edit_test_report', code => sub { $called_edit++; 0 } ); $CB->_register_callback( name => 'send_test_report', code => sub { $called_send++; 1 } ); ### reset from earlier tests $CB->_register_callback( name => 'munge_test_report', code => sub { return $_[1] } ); my $mod = $map->{$type}->{'pre_hook'} ? $map->{$type}->{'pre_hook'}->( $Mod ) : $Mod; my $file = do { ### so T::R does not try to resolve our maildomain, which can ### lead to large timeouts for *every* invocation in T::R < 1.51_01 ### see: http://code.google.com/p/test-reporter/issues/detail?id=15 local $ENV{MAILDOMAIN} ||= 'example.com'; $CB->_send_report( module => $mod, buffer => $map->{$type}{'buffer'}, failed => $map->{$type}{'failed'}, tests_skipped => ($map->{$type}{'skiptests'} ? 1 : 0), save => 1, ); }; ok( $file, "Type '$type' written to file" ); ok( -e $file, " File exists" ); my $fh = FileHandle->new($file); ok( $fh, " Opened file for reading" ); my $in = do { local $/; <$fh> }; ok( $in, " File has contents" ); for my $regex ( @{$map->{$type}->{match}} ) { like( $in, $regex, " File contains expected contents" ); } ### check if our registered callback got called ### if( $map->{$type}->{check} ) { ok( $called_edit, " Callback to edit was called" ); ok( $called_send, " Callback to send was called" ); } #unlink $file; ### T::R tests don't even try to mail, let's not try and be smarter ### ourselves # { ### use a dummy 'editor' and see if the editor # ### invocation doesn't break things # $conf->set_program( editor => "$^X -le1" ); # $CB->_callbacks->edit_test_report( sub { 1 } ); # # ### XXX whitebox test!!! Might change =/ # ### this makes test::reporter not ask for what editor to use # ### XXX stupid lousy perl warnings; # local $Test::Reporter::MacApp = 1; # local $Test::Reporter::MacApp = 1; # # ### now try and mail the report to a /dev/null'd mailbox # my $ok = $CB->_send_report( # module => $Mod, # buffer => $map->{$type}->{'buffer'}, # failed => $map->{$type}->{'failed'}, # address => NOBODY, # ); # ok( $ok, " Mailed report to NOBODY" ); # } } } sub missing_prereq_buffer { return q[ MAKE TEST: Can't locate floo.pm in @INC (@INC contains: /Users/kane/sources/p4/other/archive-extract/lib /Users/kane/sources/p4/other/file-fetch/lib /Users/kane/sources/p4/other/archive-tar-new/lib /Users/kane/sources/p4/other/carp-trace/lib /Users/kane/sources/p4/other/log-message/lib /Users/kane/sources/p4/other/module-load/lib /Users/kane/sources/p4/other/params-check/lib /Users/kane/sources/p4/other/qmail-checkpassword/lib /Users/kane/sources/p4/other/module-load-conditional/lib /Users/kane/sources/p4/other/term-ui/lib /Users/kane/sources/p4/other/ipc-cmd/lib /Users/kane/sources/p4/other/config-auto/lib /Users/kane/sources/NSA /Users/kane/sources/NSA/misc /Users/kane/sources/NSA/test /Users/kane/sources/beheer/perl /opt/lib/perl5/5.8.3/darwin-2level /opt/lib/perl5/5.8.3 /opt/lib/perl5/site_perl/5.8.3/darwin-2level /opt/lib/perl5/site_perl/5.8.3 /opt/lib/perl5/site_perl .). BEGIN failed--compilation aborted. ]; } sub missing_tests_buffer { return q[ cp lib/Acme/POE/Knee.pm blib/lib/Acme/POE/Knee.pm cp demo_race.pl blib/lib/Acme/POE/demo_race.pl cp demo_simple.pl blib/lib/Acme/POE/demo_simple.pl MAKE TEST: No tests defined for Acme::POE::Knee extension. ]; } sub perl_version_too_low_buffer_mm { return q[ Running [/usr/bin/perl5.8.1 Makefile.PL ]... Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1. BEGIN failed--compilation aborted at Makefile.PL line 1. [ERROR] Could not run '/usr/bin/perl5.8.1 Makefile.PL': Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1. BEGIN failed--compilation aborted at Makefile.PL line 1. -- cannot continue ]; } sub perl_version_too_low_buffer_build { my $type = shift; return q[ ERROR: perl: Version 5.006001 is installed, but we need version >= 5.008001 ERROR: version: Prerequisite version isn't installed ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions of the modules indicated above before proceeding with this installation. ] if($type == 1); return q[ ERROR: Version 5.006001 of perl is installed, but we need version >= 5.008001 ERROR: version: Prerequisite version isn't installed ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions of the modules indicated above before proceeding with this installation. ] if($type == 2); } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/t/25_CPANPLUS.t0000644000175000017500000000462512207704351014557 0ustar bingosbingos### make sure we can find our conf.pl file BEGIN { use FindBin; require "$FindBin::Bin/inc/conf.pl"; } use strict; use Test::More 'no_plan'; use CPANPLUS::Error; use CPANPLUS::Backend; my $Class = 'CPANPLUS'; my $ModName = TEST_CONF_MODULE; my $Conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $Conf ); ### so we get an object with *our* configuration no warnings 'redefine'; local *CPANPLUS::Backend::new = sub { $CB }; use_ok( $Class ); ### install / get / fetch tests for my $meth ( qw[fetch get install] ) { my $sub = $Class->can( $meth ); ok( $sub, "$Class->can( $meth )" ); my %map = ( 0 => qr/failed/, 1 => qr/successful/, ); ok( 1, "Trying '$meth' in different configurations" ); while( my($rv, $re) = each %map ) { ### don't actually install, just test logic no warnings 'redefine'; local *CPANPLUS::Module::install = sub { $rv }; local *CPANPLUS::Module::fetch = sub { $rv }; CPANPLUS::Error->flush; my $ok = $sub->( $ModName ); is( $ok, $rv, " Expected RV: $rv" ); like( CPANPLUS::Error->stack_as_string, $re, " With expected diagnostic" ); } ### does not take objects / references { CPANPLUS::Error->flush; my $ok = $sub->( [] ); ok( !$ok, "'$meth' with reference does not work" ); like( CPANPLUS::Error->stack_as_string, qr/object/, " Error as expected"); } ### requires argument { CPANPLUS::Error->flush; my $ok = $sub->( ); ok( !$ok, "'$meth' without argument does not work" ); like( CPANPLUS::Error->stack_as_string, qr/No module specified/, " Error as expected"); } } ### shell tests { my $meth = 'shell'; my $sub = $Class->can( $meth ); ok( $sub, "$Class->can( $meth )" ); { ### test package for shell() method package CPANPLUS::Shell::Test; ### ->shell() looks in %INC use Module::Loaded qw[mark_as_loaded]; mark_as_loaded( __PACKAGE__ ); sub new { bless {}, __PACKAGE__ }; sub shell { $$ }; } my $rv = $sub->( 'Test' ); ok( $rv, " Shell started" ); is( $rv, $$, " Proper shell called" ); } CPANPLUS-0.9144/lib/0000755000175000017500000000000012251422462013132 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/0000755000175000017500000000000012251422462014357 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Config.pm0000644000175000017500000005633412251421370016132 0ustar bingosbingospackage CPANPLUS::Config; use strict; use warnings; use base 'Object::Accessor'; use base 'CPANPLUS::Internals::Utils'; use Config; use File::Spec; use Module::Load; use CPANPLUS; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use File::Basename qw[dirname]; use IPC::Cmd qw[can_run]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use Module::Load::Conditional qw[check_install]; use version; use vars qw[$VERSION]; $VERSION = "0.9144"; =pod =head1 NAME CPANPLUS::Config - configuration defaults and heuristics for CPANPLUS =head1 SYNOPSIS ### conf object via CPANPLUS::Backend; $cb = CPANPLUS::Backend->new; $conf = $cb->configure_object; ### or as a standalone object $conf = CPANPLUS::Configure->new; ### values in 'conf' section $verbose = $conf->get_conf( 'verbose' ); $conf->set_conf( verbose => 1 ); ### values in 'program' section $editor = $conf->get_program( 'editor' ); $conf->set_program( editor => '/bin/vi' ); =head1 DESCRIPTION This module contains defaults and heuristics for configuration information for CPANPLUS. To change any of these values, please see the documentation in C. Below you'll find a list of configuration types and keys, and their meaning. =head1 CONFIGURATION =cut ### BAH! you can't have POD interleaved with a hash ### declaration.. so declare every entry separately :( my $Conf = { '_fetch' => { 'blacklist' => [ 'ftp' ], }, ### _source, _build and _mirror are supposed to be static ### no changes should be needed unless pause/cpan changes '_source' => { 'hosts' => 'MIRRORED.BY', 'auth' => '01mailrc.txt.gz', 'stored' => 'sourcefiles', 'dslip' => '03modlist.data.gz', 'update' => '86400', 'mod' => '02packages.details.txt.gz', 'custom_index' => 'packages.txt', }, '_build' => { 'plugins' => 'plugins', 'moddir' => 'build', 'startdir' => '', 'distdir' => 'dist', 'autobundle' => 'autobundle', 'autobundle_prefix' => 'Snapshot', 'autdir' => 'authors', 'install_log_dir' => 'install-logs', 'custom_sources' => 'custom-sources', 'sanity_check' => 1, }, '_mirror' => { 'base' => 'authors/id/', 'auth' => 'authors/01mailrc.txt.gz', 'dslip' => 'modules/03modlist.data.gz', 'mod' => 'modules/02packages.details.txt.gz' }, }; =head2 Section 'conf' =over 4 =item hosts An array ref containing hosts entries to be queried for packages. An example entry would like this: { 'scheme' => 'ftp', 'path' => '/pub/CPAN/', 'host' => 'ftp.cpan.org' }, =cut ### default host list $Conf->{'conf'}->{'hosts'} = [ { 'scheme' => 'ftp', 'path' => '/pub/CPAN/', 'host' => 'ftp.cpan.org' }, { 'scheme' => 'http', 'path' => '/', 'host' => 'www.cpan.org' }, { 'scheme' => 'ftp', 'path' => '/', 'host' => 'cpan.hexten.net' }, { 'scheme' => 'ftp', 'path' => '/CPAN/', 'host' => 'cpan.cpantesters.org' }, { 'scheme' => 'ftp', 'path' => '/pub/languages/perl/CPAN/', 'host' => 'ftp.funet.fi' } ]; =item allow_build_interactivity Boolean flag to indicate whether 'perl Makefile.PL' and similar are run interactively or not. Defaults to 'true'. =cut $Conf->{'conf'}->{'allow_build_interactivity'} = 1; =item allow_unknown_prereqs Boolean flag to indicate that unresolvable prereqs are acceptable. If C then only warnings will be issued (the behaviour before 0.9114) when a module is unresolvable from any our sources (CPAN and/or C). If C then an unresolvable prereq will fail during the C stage of distribution installation. Defaults to C. =cut $Conf->{'conf'}->{'allow_unknown_prereqs'} = 1; =item base The directory CPANPLUS keeps all its build and state information in. Defaults to ~/.cpanplus. If L is available, that will be used to work out your C directory. This may be overridden by setting the C environment variable, see L for more details. =cut $Conf->{'conf'}->{'base'} = File::Spec->catdir( __PACKAGE__->_home_dir, DOT_CPANPLUS ); =item buildflags Any flags to be passed to 'perl Build.PL'. See C for details. Defaults to an empty string. =cut $Conf->{'conf'}->{'buildflags'} = ''; =item cpantest Boolean flag to indicate whether or not to mail test results of module installations to C. Defaults to 'false'. =cut $Conf->{'conf'}->{'cpantest'} = 0; =item cpantest_mx String holding an explicit mailserver to use when sending out emails for C. An empty string will use your system settings. Defaults to an empty string. =cut $Conf->{'conf'}->{'cpantest_mx'} = ''; =item debug Boolean flag to enable or disable extensive debugging information. Defaults to 'false'. =cut $Conf->{'conf'}->{'debug'} = 0; =item dist_type Default distribution type to use when building packages. See C or C for details. An empty string will not use any package building software. Defaults to an empty string. =cut $Conf->{'conf'}->{'dist_type'} = ''; =item email Email address to use for anonymous ftp access and as C address when sending emails. Defaults to an C address. =cut $Conf->{'conf'}->{'email'} = DEFAULT_EMAIL; =item enable_custom_sources Boolean flag indicating whether custom sources should be enabled or not. See the C in C for details on how to use them. Defaults to C =cut ### this addresses #32248 which requests a possibility to ### turn off custom sources $Conf->{'conf'}->{'enable_custom_sources'} = 1; =item extractdir String containing the directory where fetched archives should be extracted. An empty string will use a directory under your C directory. Defaults to an empty string. =cut $Conf->{'conf'}->{'extractdir'} = ''; =item fetchdir String containing the directory where fetched archives should be stored. An empty string will use a directory under your C directory. Defaults to an empty string. =cut $Conf->{'conf'}->{'fetchdir'} = ''; =item flush Boolean indicating whether build failures, cache dirs etc should be flushed after every operation or not. Defaults to 'true'. =cut $Conf->{'conf'}->{'flush'} = 1; =item force Boolean indicating whether files should be forcefully overwritten if they exist, modules should be installed when they fail tests, etc. Defaults to 'false'. =cut $Conf->{'conf'}->{'force'} = 0; =item histfile A string containing the history filename of the CPANPLUS readline instance. =cut $Conf->{'conf'}->{'histfile'} = File::Spec->catdir( __PACKAGE__->_home_dir, DOT_CPANPLUS, 'history' ); =item lib An array ref holding directories to be added to C<@INC> when CPANPLUS starts up. Defaults to an empty array reference. =cut $Conf->{'conf'}->{'lib'} = []; =item makeflags A string holding flags that will be passed to the C program when invoked. Defaults to an empty string. =cut $Conf->{'conf'}->{'makeflags'} = ''; =item makemakerflags A string holding flags that will be passed to C when invoked. Defaults to an empty string. =cut $Conf->{'conf'}->{'makemakerflags'} = ''; =item md5 A boolean indicating whether or not sha256 checks should be done when an archive is fetched. Defaults to 'true' if you have C installed, 'false' otherwise. =cut $Conf->{'conf'}->{'md5'} = ( check_install( module => 'Digest::SHA' ) ? 1 : 0 ); =item no_update A boolean indicating whether or not C' source files should be updated or not. Defaults to 'false'. =cut $Conf->{'conf'}->{'no_update'} = 0; =item passive A boolean indicating whether or not to use passive ftp connections. Defaults to 'true'. =cut $Conf->{'conf'}->{'passive'} = 1; =item prefer_bin A boolean indicating whether or not to prefer command line programs over perl modules. Defaults to 'false' unless you do not have C installed (as that would mean we could not extract C<.tar.gz> files) =cut ### if we don't have c::zlib, we'll need to use /bin/tar or we ### can not extract any files. Good time to change the default $Conf->{'conf'}->{'prefer_bin'} = (eval {require Compress::Zlib; 1} ? 0 : 1 ); =item prefer_makefile A boolean indicating whether or not prefer a C over a C file if both are present. Defaults to 'true', unless the perl version is at least 5.10.1 or appropriate versions of L and L are available. =cut $Conf->{'conf'}->{'prefer_makefile'} = ( $] >= 5.010001 or ( check_install( module => 'Module::Build', version => '0.32' ) and check_install( module => INSTALLER_BUILD, version => '0.60' ) ) ? 0 : 1 ); =item prereqs A digit indicating what to do when a package you are installing has a prerequisite. Options are: 0 Do not install 1 Install 2 Ask 3 Ignore (dangerous, install will probably fail!) The default is to ask. =cut $Conf->{'conf'}->{'prereqs'} = PREREQ_ASK; =item shell A string holding the shell class you wish to start up when starting C in interactive mode. Defaults to C, the default CPANPLUS shell. =cut $Conf->{'conf'}->{'shell'} = 'CPANPLUS::Shell::Default'; =item show_startup_tip A boolean indicating whether or not to show start up tips in the interactive shell. Defaults to 'true'. =cut $Conf->{'conf'}->{'show_startup_tip'} = 1; =item signature A boolean indicating whether or not check signatures if packages are signed. Defaults to 'true' if you have C or C installed, 'false' otherwise. =cut $Conf->{'conf'}->{'signature'} = do { check_install( module => 'Module::Signature', version => '0.06' ) and ( can_run('gpg') || check_install(module => 'Crypt::OpenPGP') ); } ? 1 : 0; =item skiptest A boolean indicating whether or not to skip tests when installing modules. Defaults to 'false'. =cut $Conf->{'conf'}->{'skiptest'} = 0; =item storable A boolean indicating whether or not to use C to write compiled source file information to disk. This makes for faster startup and look up times, but takes extra diskspace. Defaults to 'true' if you have C installed and 'false' if you don't. =cut $Conf->{'conf'}->{'storable'} = ( check_install( module => 'Storable' ) ? 1 : 0 ); =item timeout Digit indicating the time before a fetch request times out (in seconds). Defaults to 300. =cut $Conf->{'conf'}->{'timeout'} = 300; =item verbose A boolean indicating whether or not C runs in verbose mode. Defaults to 'true' if you have the environment variable C set to true, 'false' otherwise. It is recommended you run with verbose enabled, but it is disabled for historical reasons. =cut $Conf->{'conf'}->{'verbose'} = $ENV{PERL5_CPANPLUS_VERBOSE} || 0; =item write_install_log A boolean indicating whether or not to write install logs after installing a module using the interactive shell. Defaults to 'true'. =cut $Conf->{'conf'}->{'write_install_logs'} = 1; =item source_engine Class to use as the source engine, which is generally a subclass of C. Default to C. =cut $Conf->{'conf'}->{'source_engine'} = DEFAULT_SOURCE_ENGINE; =item cpantest_reporter_args A hashref of key => value pairs that are passed to the constructor of C. If you'd want to enable TLS for example, you'd set it to: { transport => 'Net::SMTP::TLS', transport_args => [ User => 'Joe', Password => '123' ], } =cut $Conf->{'conf'}->{'cpantest_reporter_args'} = {}; =back =head2 Section 'program' =cut ### Paths get stripped of whitespace on win32 in the constructor ### sudo gets emptied if there's no need for it in the constructor =over 4 =item editor A string holding the path to your editor of choice. Defaults to your $ENV{EDITOR}, $ENV{VISUAL}, 'vi' or 'pico' programs, in that order. =cut $Conf->{'program'}->{'editor'} = do { $ENV{'EDITOR'} || $ENV{'VISUAL'} || can_run('vi') || can_run('pico') }; =item make A string holding the path to your C binary. Looks for the C program used to build perl or failing that, a C in your path. =cut $Conf->{'program'}->{'make'} = can_run($Config{'make'}) || can_run('make'); =item pager A string holding the path to your pager of choice. Defaults to your $ENV{PAGER}, 'less' or 'more' programs, in that order. =cut $Conf->{'program'}->{'pager'} = $ENV{'PAGER'} || can_run('less') || can_run('more'); ### no one uses this feature anyway, and it's only working for EU::MM ### and not for module::build #'perl' => '', =item shell A string holding the path to your login shell of choice. Defaults to your $ENV{SHELL} setting, or $ENV{COMSPEC} on Windows. =cut $Conf->{'program'}->{'shell'} = $^O eq 'MSWin32' ? $ENV{COMSPEC} : $ENV{SHELL}; =item sudo A string holding the path to your C binary if your install path requires super user permissions. Looks for C in your path, or remains empty if you do not require super user permissions to install. =cut $Conf->{'program'}->{'sudo'} = do { ### let's assume you don't need sudo, ### unless one of the below criteria tells us otherwise my $sudo = undef; ### you're a normal user, you might need sudo if( $> ) { ### check for all install dirs! ### you have write permissions to the installdir, ### you don't need sudo if( -w $Config{'installsitelib'} && -w $Config{'installsitebin'} ) { ### installsiteman3dir is a 5.8'ism.. don't check ### it on 5.6.x... if( defined $Config{'installsiteman3dir'} ) { $sudo = -w $Config{'installsiteman3dir'} ? undef : can_run('sudo'); } else { $sudo = undef; } ### you have PERL_MM_OPT set to some alternate ### install place. You probably have write permissions ### to that } elsif ( $ENV{'PERL_MM_OPT'} and $ENV{'PERL_MM_OPT'} =~ /INSTALL|LIB|PREFIX/ ) { $sudo = undef; ### you probably don't have write permissions } else { $sudo = can_run('sudo'); } } ### and return the value $sudo; }; =item perlwrapper B A string holding the path to the C utility bundled with CPANPLUS, which is used to enable autoflushing in spawned processes. =cut ### perlwrapper that allows us to turn on autoflushing $Conf->{'program'}->{'perlwrapper'} = sub { my $name = 'cpanp-run-perl'; my @bins = do{ require Config; my $ver = $Config::Config{version}; ### if we are running with 'versiononly' enabled, ### all binaries will have the perlversion appended ### ie, cpanp will become cpanp5.9.5 ### so prefer the versioned binary in that case $Config::Config{versiononly} ? ($name.$ver, $name) : ($name, $name.$ver); }; ### patch from Steve Hay Fri 29 Jun 2007 14:26:02 GMT+02:00 ### Msg-Id: <4684FA5A.7030506@uk.radan.com> ### look for files with a ".bat" extension as well on Win32 @bins = map { $_, "$_.bat" } @bins if $^O eq 'MSWin32'; my $path; BIN: for my $bin (@bins) { ### parallel to your cpanp/cpanp-boxed my $maybe = File::Spec->rel2abs( File::Spec->catfile( dirname($0), $bin ) ); $path = $maybe and last BIN if -f $maybe; ### parallel to your CPANPLUS.pm: ### $INC{cpanplus}/../bin/cpanp-run-perl $maybe = File::Spec->rel2abs( File::Spec->catfile( dirname($INC{'CPANPLUS.pm'}), '..', # lib dir 'bin', # bin dir $bin, # script ) ); $path = $maybe and last BIN if -f $maybe; ### you installed CPANPLUS in a custom prefix, ### so go parallel to /that/. PREFIX=/tmp/cp ### would put cpanp-run-perl in /tmp/cp/bin and ### CPANPLUS.pm in ### /tmp/cp/lib/perl5/site_perl/5.8.8 $maybe = File::Spec->rel2abs( File::Spec->catfile( dirname( $INC{'CPANPLUS.pm'} ), '..', '..', '..', '..', # 4x updir 'bin', # bin dir $bin, # script ) ); $path = $maybe and last BIN if -f $maybe; ### in your path -- take this one last, the ### previous two assume extracted tarballs ### or user installs ### note that we don't use 'can_run' as it's ### not an executable, just a wrapper... ### prefer anything that's found in the path parallel to your $^X for my $dir (File::Spec->rel2abs( dirname($^X) ), split(/\Q$Config::Config{path_sep}\E/, $ENV{PATH}), File::Spec->curdir, ) { ### On VMS the path could be in UNIX format, and we ### currently need it to be in VMS format $dir = VMS::Filespec::vmspath($dir) if ON_VMS; $maybe = File::Spec->catfile( $dir, $bin ); $path = $maybe and last BIN if -f $maybe; } } ### we should have a $path by now ideally, if so return it return $path if defined $path; ### CPANPLUS::Dist::MM doesn't require this anymore ### but CPANPLUS::Dist::Build might if it is less than 0.60 my $cpdb = check_install( module => INSTALLER_BUILD ); return '' unless $cpdb and eval { version->parse($cpdb->{version}) < version->parse('0.60') }; ### if not, warn about it and give sensible default. ### XXX try to be a no-op instead then.. ### cross your fingers... ### pass '-P' to perl: "run program through C ### preprocessor before compilation" ### XXX using -P actually changes the way some Makefile.PLs ### are executed, so don't do that... --kane error(loc( "Could not find the '%1' binary in your path". "--this may be a problem.\n". "Please locate this program and set ". "your '%2' config entry to its path.\n". "From the default shell, you can do this by typing:\n\n". " %3\n". " %4\n", $name, 'perlwrapper', 's program perlwrapper FULL_PATH_TO_CPANP_RUN_PERL', 's save' )); return ''; }->(); =back =cut sub new { my $class = shift; my $obj = $class->SUPER::new; $obj->mk_accessors( keys %$Conf ); for my $acc ( keys %$Conf ) { my $subobj = Object::Accessor->new; $subobj->mk_accessors( keys %{$Conf->{$acc}} ); ### read in all the settings from the sub accessors; for my $subacc ( $subobj->ls_accessors ) { $subobj->$subacc( $Conf->{$acc}->{$subacc} ); } ### now store it in the parent object $obj->$acc( $subobj ); } $obj->_clean_up_paths; ### shut up IPC::Cmd warning about not finding IPC::Run on win32 $IPC::Cmd::WARN = 0; return $obj; } sub _clean_up_paths { my $self = shift; ### clean up paths if we are on win32 if( $^O eq 'MSWin32' ) { for my $pgm ( $self->program->ls_accessors ) { my $path = $self->program->$pgm; ### paths with whitespace needs to be shortened ### for shell outs. if ($path and $path =~ /\s+/) { my($prog, $args); ### patch from Steve Hay, 13th of June 2007 ### msg-id: <467012A4.6060705@uk.radan.com> ### windows directories are not allowed to end with ### a space, so any occurrence of '\w\s+/\w+' means ### we're dealing with arguments, not directory ### names. if ($path =~ /^(.*?)(\s+\/.*$)/) { ($prog, $args) = ($1, $2); ### otherwise, there are no arguments } else { ($prog, $args) = ($path, ''); } $prog = Win32::GetShortPathName( $prog ); $self->program->$pgm( $prog . $args ); } } } return 1; } 1; =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Backend.pm0000644000175000017500000011662212251421370016251 0ustar bingosbingospackage CPANPLUS::Backend; use strict; use CPANPLUS::Error; use CPANPLUS::Configure; use CPANPLUS::Internals; use CPANPLUS::Internals::Constants; use CPANPLUS::Module; use CPANPLUS::Module::Author; use CPANPLUS::Backend::RV; use FileHandle; use File::Spec (); use File::Spec::Unix (); use File::Basename (); use Params::Check qw[check]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; $Params::Check::VERBOSE = 1; use vars qw[@ISA $VERSION]; @ISA = qw[CPANPLUS::Internals]; $VERSION = "0.9144"; ### mark that we're running under CPANPLUS to spawned processes $ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$; ### XXX version.pm MAY format this version, if it's in use... :( ### so for consistency, just call ->VERSION ourselves as well. $ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION; =pod =head1 NAME CPANPLUS::Backend - programmer's interface to CPANPLUS =head1 SYNOPSIS my $cb = CPANPLUS::Backend->new; my $conf = $cb->configure_object; my $author = $cb->author_tree('KANE'); my $mod = $cb->module_tree('Some::Module'); my $mod = $cb->parse_module( module => 'Some::Module' ); my @objs = $cb->search( type => TYPE, allow => [...] ); $cb->flush('all'); $cb->reload_indices; $cb->local_mirror; =head1 DESCRIPTION This module provides the programmer's interface to the C libraries. =head1 ENVIRONMENT When C is loaded, which is necessary for just about every operation, the environment variable C is set to the current process id. Additionally, the environment variable C will be set to the version of C. This information might be useful somehow to spawned processes. =head1 METHODS =head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) This method returns a new C object. This also initialises the config corresponding to this object. You have two choices in this: =over 4 =item Provide a valid C object This will be used verbatim. =item No arguments Your default config will be loaded and used. =back New will return a C object on success and die on failure. =cut sub new { my $class = shift; my $conf; if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) { $conf = shift; } else { $conf = CPANPLUS::Configure->new() or return; } my $self = $class->SUPER::_init( _conf => $conf ); return $self; } =pod =head2 $href = $cb->module_tree( [@modules_names_list] ) Returns a reference to the CPANPLUS module tree. If you give it any arguments, they will be treated as module names and C will try to look up these module names and return the corresponding module objects instead. See L for the operations you can perform on a module object. =cut sub module_tree { my $self = shift; my $modtree = $self->_module_tree; if( @_ ) { my @rv; for my $name ( grep { defined } @_) { ### From John Malmberg: This is failing on VMS ### because ODS-2 does not retain the case of ### filenames that are created. ### The problem is the filename is being converted ### to a module name and then looked up in the ### %$modtree hash. ### ### As a fix, we do a search on VMS instead -- ### more cpu cycles, but it gets around the case ### problem --kane my ($modobj) = do { ON_VMS ? $self->search( type => 'module', allow => [qr/^$name$/i], ) : $modtree->{$name} }; push @rv, $modobj || ''; } return @rv == 1 ? $rv[0] : @rv; } else { return $modtree; } } =pod =head2 $href = $cb->author_tree( [@author_names_list] ) Returns a reference to the CPANPLUS author tree. If you give it any arguments, they will be treated as author names and C will try to look up these author names and return the corresponding author objects instead. See L for the operations you can perform on an author object. =cut sub author_tree { my $self = shift; my $authtree = $self->_author_tree; if( @_ ) { my @rv; for my $name (@_) { push @rv, $authtree->{$name} || ''; } return @rv == 1 ? $rv[0] : @rv; } else { return $authtree; } } =pod =head2 $conf = $cb->configure_object; Returns a copy of the C object. See L for operations you can perform on a configure object. =cut sub configure_object { return shift->_conf() }; =head2 $su = $cb->selfupdate_object; Returns a copy of the C object. See the L manpage for the operations you can perform on the selfupdate object. =cut sub selfupdate_object { return shift->_selfupdate() }; =pod =head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] ) C enables you to search for either module or author objects, based on their data. The C you can specify is any of the accessors specified in C or C. C will determine by the C you specified whether to search by author object or module object. You have to specify an array reference of regular expressions or strings to match against. The rules used for this array ref are the same as in C, so read that manpage for details. The search is an C search, meaning that if C of the criteria match, the search is considered to be successful. You can specify the result of a previous search as C to limit the new search to these module or author objects, rather than the entire module or author tree. This is how you do C searches. Returns a list of module or author objects on success and false on failure. See L for the operations you can perform on a module object. See L for the operations you can perform on an author object. =cut sub search { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my ($type); my $args = do { local $Params::Check::NO_DUPLICATES = 0; local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { type => { required => 1, allow => [CPANPLUS::Module->accessors(), CPANPLUS::Module::Author->accessors()], store => \$type }, allow => { required => 1, default => [ ], strict_type => 1 }, }; check( $tmpl, \%hash ) } or return; ### figure out whether it was an author or a module search ### when ambiguous, it'll be an author search. my $aref; if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) { $aref = $self->_search_author_tree( %$args ); } else { $aref = $self->_search_module_tree( %$args ); } return @$aref if $aref; return; } =pod =head2 $backend_rv = $cb->fetch( modules => \@mods ) Fetches a list of modules. C<@mods> can be a list of distribution names, module names or module objects--basically anything that L can understand. See the equivalent method in C for details on other options you can pass. Since this is a multi-module method call, the return value is implemented as a C object. Please consult that module's documentation on how to interpret the return value. =head2 $backend_rv = $cb->extract( modules => \@mods ) Extracts a list of modules. C<@mods> can be a list of distribution names, module names or module objects--basically anything that L can understand. See the equivalent method in C for details on other options you can pass. Since this is a multi-module method call, the return value is implemented as a C object. Please consult that module's documentation on how to interpret the return value. =head2 $backend_rv = $cb->install( modules => \@mods ) Installs a list of modules. C<@mods> can be a list of distribution names, module names or module objects--basically anything that L can understand. See the equivalent method in C for details on other options you can pass. Since this is a multi-module method call, the return value is implemented as a C object. Please consult that module's documentation on how to interpret the return value. =head2 $backend_rv = $cb->readme( modules => \@mods ) Fetches the readme for a list of modules. C<@mods> can be a list of distribution names, module names or module objects--basically anything that L can understand. See the equivalent method in C for details on other options you can pass. Since this is a multi-module method call, the return value is implemented as a C object. Please consult that module's documentation on how to interpret the return value. =head2 $backend_rv = $cb->files( modules => \@mods ) Returns a list of files used by these modules if they are installed. C<@mods> can be a list of distribution names, module names or module objects--basically anything that L can understand. See the equivalent method in C for details on other options you can pass. Since this is a multi-module method call, the return value is implemented as a C object. Please consult that module's documentation on how to interpret the return value. =head2 $backend_rv = $cb->distributions( modules => \@mods ) Returns a list of module objects representing all releases for this module on success. C<@mods> can be a list of distribution names, module names or module objects, basically anything that L can understand. See the equivalent method in C for details on other options you can pass. Since this is a multi-module method call, the return value is implemented as a C object. Please consult that module's documentation on how to interpret the return value. =cut ### XXX add direcotry_tree, packlist etc? or maybe remove files? ### for my $func (qw[fetch extract install readme files distributions]) { no strict 'refs'; *$func = sub { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my ($mods); my $args = do { local $Params::Check::NO_DUPLICATES = 1; local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { default => [], strict_type => 1, required => 1, store => \$mods }, }; check( $tmpl, \%hash ); } or return; ### make them all into module objects ### my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods; my $flag; my $href; while( my($name,$obj) = each %mods ) { $href->{$name} = IS_MODOBJ->( mod => $obj ) ? $obj->$func( %$args ) : undef; $flag++ unless $href->{$name}; } return CPANPLUS::Backend::RV->new( function => $func, ok => ( !$flag ? 1 : 0 ), rv => $href, args => \%hash, ); } } =pod =head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH ) C tries to find a C object that matches your query. Here's a list of examples you could give to C; =over 4 =item Text::Bastardize =item Text-Bastardize =item Text/Bastardize.pm =item Text-Bastardize-1.06 =item AYRNIEU/Text-Bastardize =item AYRNIEU/Text-Bastardize-1.06 =item AYRNIEU/Text-Bastardize-1.06.tar.gz =item http://example.com/Text-Bastardize-1.06.tar.gz =item file:///tmp/Text-Bastardize-1.06.tar.gz =item /tmp/Text-Bastardize-1.06 =item ./Text-Bastardize-1.06 =item . =back These items would all come up with a C object for C. The ones marked explicitly as being version 1.06 would give back a C object of that version. Even if the version on CPAN is currently higher. The last three are examples of PATH resolution. In the first, we supply an absolute path to the unwrapped distribution. In the second the distribution is relative to the current working directory. In the third, we will use the current working directory. If C is unable to actually find the module you are looking for in its module tree, but you supplied it with an author, module and version part in a distribution name or URI, it will create a fake C object for you, that you can use just like the real thing. See L for the operations you can perform on a module object. If even this fancy guessing doesn't enable C to create a fake module object for you to use, it will warn about an error and return false. =cut sub parse_module { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my $mod; my $tmpl = { module => { required => 1, store => \$mod }, }; my $args = check( $tmpl, \%hash ) or return; return $mod if IS_MODOBJ->( module => $mod ); ### ok, so it's not a module object, but a ref nonetheless? ### what are you smoking? if( ref $mod ) { error(loc("Can not parse module string from reference '%1'", $mod )); return; } ### check only for allowed characters in a module name unless( $mod =~ /[^\w:]/ ) { ### perhaps we can find it in the module tree? my $maybe = $self->module_tree($mod); return $maybe if IS_MODOBJ->( module => $maybe ); } ### Special case arbitrary file paths such as '.' etc. if ( $mod and -d File::Spec->rel2abs($mod) ) { my $dir = File::Spec->rel2abs($mod); my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) ); ### fix paths on VMS if (ON_VMS) { $dir = VMS::Filespec::unixify($dir); $parent = VMS::Filespec::unixify($parent); } my $dist = $mod = File::Basename::basename($dir); $dist .= '-0' unless $dist =~ /\-[0-9._]+$/; $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; my $modobj = CPANPLUS::Module::Fake->new( module => $mod, version => 0, package => $dist, path => $parent, author => CPANPLUS::Module::Author::Fake->new ); ### better guess for the version $modobj->version( $modobj->package_version ) if defined $modobj->package_version; ### better guess at module name, if possible if ( my $pkgname = $modobj->package_name ) { $pkgname =~ s/-/::/g; ### no sense replacing it unless we changed something $modobj->module( $pkgname ) if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; } $modobj->status->fetch( $parent ); $modobj->status->extract( $dir ); $modobj->get_installer_type; return $modobj; } ### ok, so it looks like a distribution then? my @parts = split '/', $mod; my $dist = pop @parts; ### ah, it's a URL if( $mod =~ m|\w+://.+| ) { my $modobj = CPANPLUS::Module::Fake->new( module => $dist, version => 0, package => $dist, path => File::Spec::Unix->catdir( $conf->_get_mirror('base'), UNKNOWN_DL_LOCATION ), author => CPANPLUS::Module::Author::Fake->new ); ### set the fetch_from accessor so we know to by pass the ### usual mirrors $modobj->status->_fetch_from( $mod ); ### better guess for the version $modobj->version( $modobj->package_version ) if defined $modobj->package_version; ### better guess at module name, if possible if ( my $pkgname = $modobj->package_name ) { $pkgname =~ s/-/::/g; ### no sense replacing it unless we changed something $modobj->module( $pkgname ) if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; } return $modobj; } # Stolen from cpanminus to support 'Module/Install.pm' # type input if ( ( my $tmpmod = $mod ) =~ s/\.pm$//i ) { my ($volume, $dirs, $file) = File::Spec->splitpath( $tmpmod ); $tmpmod = join '::', grep { $_ } File::Spec->splitdir( $dirs ), $file; ### perhaps we can find it in the module tree? my $maybe = $self->module_tree( $tmpmod ); return $maybe if IS_MODOBJ->( module => $maybe ); } ### perhaps we can find it's a third party module? { my $modobj = CPANPLUS::Module::Fake->new( module => $mod, version => 0, package => $dist, path => File::Spec::Unix->catdir( $conf->_get_mirror('base'), UNKNOWN_DL_LOCATION ), author => CPANPLUS::Module::Author::Fake->new ); if( $modobj->is_third_party ) { my $info = $modobj->third_party_information; $modobj->author->author( $info->{author} ); $modobj->author->email( $info->{author_url} ); $modobj->description( $info->{url} ); return $modobj; } } unless( $dist ) { error( loc("%1 is not a proper distribution name!", $mod) ); return; } ### there's wonky uris out there, like this: ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091 ### compensate for that my $author; ### you probably have an A/AB/ABC/....../Dist.tgz type uri if( (defined $parts[0] and length $parts[0] == 1) and (defined $parts[1] and length $parts[1] == 2) and $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i ) { splice @parts, 0, 2; # remove the first 2 entries from the list $author = shift @parts; # this is the actual author name then ### we''ll assume a ABC/..../Dist.tgz } else { $author = shift @parts || ''; } my($pkg, $version, $ext, $full) = $self->_split_package_string( package => $dist ); ### translate a distribution into a module name ### my $guess = $pkg; $guess =~ s/-/::/g if $guess; my $maybe = $self->module_tree( $guess ); if( IS_MODOBJ->( module => $maybe ) ) { ### maybe you asked for a package instead if ( $maybe->package eq $mod ) { return $maybe; ### perhaps an outdated version instead? } elsif ( $version ) { my $auth_obj; my $path; ### did you give us an author part? ### if( $author ) { $auth_obj = CPANPLUS::Module::Author::Fake->new( _id => $maybe->_id, cpanid => uc $author, author => uc $author, ); $path = File::Spec::Unix->catdir( $conf->_get_mirror('base'), substr(uc $author, 0, 1), substr(uc $author, 0, 2), uc $author, @parts, #possible sub dirs ); } else { $auth_obj = $maybe->author; $path = $maybe->path; } if( $maybe->package_name eq $pkg ) { my $modobj = CPANPLUS::Module::Fake->new( module => $maybe->module, version => $version, ### no extension? use the extension the original package ### had instead package => do { $ext ? $full : $full .'.'. $maybe->package_extension }, path => $path, author => $auth_obj, _id => $maybe->_id ); return $modobj; ### you asked for a specific version? ### assume our $maybe is the one you wanted, ### and fix up the version.. } else { my $modobj = $maybe->clone; $modobj->version( $version ); $modobj->package( $maybe->package_name .'-'. $version .'.'. $maybe->package_extension ); ### you wanted a specific author, but it's not the one ### from the module tree? we'll fix it up if( $author and $author ne $modobj->author->cpanid ) { $modobj->author( $auth_obj ); $modobj->path( $path ); } return $modobj; } ### you didn't care about a version, so just return the object then } elsif ( !$version ) { return $maybe; } ### ok, so we can't find it, and it's not an outdated dist either ### perhaps we can fake one based on the author name and so on } elsif ( $author and $version ) { ### be extra friendly and pad the .tar.gz suffix where needed ### it's just a guess of course, but most dists are .tar.gz $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; ### XXX duplication from above for generating author obj + path... my $modobj = CPANPLUS::Module::Fake->new( module => $guess, version => $version, package => $dist, author => CPANPLUS::Module::Author::Fake->new( author => uc $author, cpanid => uc $author, _id => $self->_id, ), path => File::Spec::Unix->catdir( $conf->_get_mirror('base'), substr(uc $author, 0, 1), substr(uc $author, 0, 2), uc $author, @parts, #possible subdirs ), _id => $self->_id, ); return $modobj; ### face it, we have /no/ idea what he or she wants... ### let's start putting the blame somewhere } else { # Lets not give up too easily. There is one last chance # http://perlmonks.org/?node_id=805957 # This should catch edge-cases where the package name # is unrelated to the modules it contains. my ($modobj) = grep { $_->package_name eq $mod } $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], ); return $modobj if IS_MODOBJ->( module => $modobj ); unless( $author ) { error( loc( "'%1' does not contain an author part", $mod ) ); } error( loc( "Cannot find '%1' in the module tree", $mod ) ); } return; } =pod =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] ); This method reloads the source files. If C is set to true, this will fetch new source files from your CPAN mirror. Otherwise, C will do its usual cache checking and only update them if they are out of date. By default, C will be false. The verbose setting defaults to what you have specified in your config file. Returns true on success and false on failure. =cut sub reload_indices { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $tmpl = { update_source => { default => 0, allow => [qr/^\d$/] }, verbose => { default => $conf->get_conf('verbose') }, }; my $args = check( $tmpl, \%hash ) or return; ### make a call to the internal _module_tree, so it triggers cache ### file age my $uptodate = $self->_check_trees( %$args ); return 1 if $self->_build_trees( uptodate => $uptodate, use_stored => 0, verbose => $conf->get_conf('verbose'), ); error( loc( "Error rebuilding source trees!" ) ); return; } =pod =head2 $bool = $cb->flush(CACHE_NAME) This method allows flushing of caches. There are several things which can be flushed: =over 4 =item * C The return status of methods which have been attempted, such as different ways of fetching files. It is recommended that automatic flushing be used instead. =item * C The return status of URIs which have been attempted, such as different hosts of fetching files. It is recommended that automatic flushing be used instead. =item * C Information about modules such as prerequisites and whether installation succeeded, failed, or was not attempted. =item * C This resets PERL5LIB, which is changed to ensure that while installing modules they are in our @INC. =item * C This resets the cache of modules we've attempted to load, but failed. This enables you to load them again after a failed load, if they somehow have become available. =item * C Flush all of the aforementioned caches. =back Returns true on success and false on failure. =cut sub flush { my $self = shift; my $type = shift or return; my $cache = { methods => [ qw( methods load ) ], hosts => [ qw( hosts ) ], modules => [ qw( modules lib) ], lib => [ qw( lib ) ], load => [ qw( load ) ], all => [ qw( hosts lib modules methods load ) ], }; my $aref = $cache->{$type} or ( error( loc("No such cache '%1'", $type) ), return ); return $self->_flush( list => $aref ); } =pod =head2 @mods = $cb->installed() Returns a list of module objects of all your installed modules. If an error occurs, it will return false. See L for the operations you can perform on a module object. =cut sub installed { my $self = shift; my $aref = $self->_all_installed; return @$aref if $aref; return; } =pod =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] ) Creates a local mirror of CPAN, of only the most recent sources in a location you specify. If you set this location equal to a custom host in your C you can use your local mirror to install from. It takes the following arguments: =over 4 =item path The location where to create the local mirror. =item index_files Enable/disable fetching of index files. You can disable fetching of the index files if you don't plan to use the local mirror as your primary site, or if you'd like up-to-date index files be fetched from elsewhere. Defaults to true. =item force Forces refetching of packages, even if they are there already. Defaults to whatever setting you have in your C. =item verbose Prints more messages about what its doing. Defaults to whatever setting you have in your C. =back Returns true on success and false on error. =cut sub local_mirror { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($path, $index, $force, $verbose); my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, index_files => { default => 1, store => \$index }, force => { default => $conf->get_conf('force'), store => \$force }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; check( $tmpl, \%hash ) or return; unless( -d $path ) { $self->_mkdir( dir => $path ) or( error( loc( "Could not create '%1', giving up", $path ) ), return ); } elsif ( ! -w _ ) { error( loc( "Could not write to '%1', giving up", $path ) ); return; } my $flag; AUTHOR: { for my $auth ( sort { $a->cpanid cmp $b->cpanid } values %{$self->author_tree} ) { MODULE: { my $i; for my $mod ( $auth->modules ) { my $fetchdir = File::Spec->catdir( $path, $mod->path ); my %opts = ( verbose => $verbose, force => $force, fetchdir => $fetchdir, ); ### only do this the for the first module ### unless( $i++ ) { $mod->_get_checksums_file( %opts ) or ( error( loc( "Could not fetch %1 file, " . "skipping author '%2'", CHECKSUMS, $auth->cpanid ) ), $flag++, next AUTHOR ); } $mod->fetch( %opts ) or( error( loc( "Could not fetch '%1'", $mod->module ) ), $flag++, next MODULE ); } } } } if( $index ) { for my $name (qw[auth dslip mod]) { $self->_update_source( name => $name, verbose => $verbose, path => $path, ) or ( $flag++, next ); } } return !$flag; } =pod =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL]) Writes out a snapshot of your current installation in C bundle style. This can then be used to install the same modules for a different or on a different machine by issuing the following commands: ### using the default shell: CPAN Terminal> i file://path/to/Snapshot_XXYY.pm ### using the API $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); $modobj->install; It will, by default, write to an 'autobundle' directory under your cpanplus homedirectory, but you can override that by supplying a C argument. It will return the location of the output file on success and false on failure. =cut sub autobundle { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($path,$force,$verbose); my $tmpl = { force => { default => $conf->get_conf('force'), store => \$force }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, path => { default => File::Spec->catdir( $conf->get_conf('base'), $self->_perl_version( perl => $^X ), $conf->_get_build('distdir'), $conf->_get_build('autobundle') ), store => \$path }, }; check($tmpl, \%hash) or return; unless( -d $path ) { $self->_mkdir( dir => $path ) or( error(loc("Could not create directory '%1'", $path ) ), return ); } my $name; my $file; { ### default filename for the bundle ### my($year,$month,$day) = (localtime)[5,4,3]; $year += 1900; $month++; my $ext = 0; my $prefix = $conf->_get_build('autobundle_prefix'); my $format = "${prefix}_%04d_%02d_%02d_%02d"; BLOCK: { $name = sprintf( $format, $year, $month, $day, $ext); $file = File::Spec->catfile( $path, $name . '.pm' ); -f $file ? ++$ext && redo BLOCK : last BLOCK; } } my $fh; unless( $fh = FileHandle->new( ">$file" ) ) { error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); return; } ### make sure we load the module tree *before* doing this, as it ### starts to chdir all over the place $self->module_tree; my $string = join "\n\n", map { join ' ', $_->module, ($_->installed_version(verbose => 0) || 'undef') } sort { $a->module cmp $b->module } $self->installed; my $now = scalar localtime; my $head = '=head1'; my $pkg = __PACKAGE__; my $version = $self->VERSION; my $perl_v = join '', `$^X -V`; print $fh <save_state Explicit command to save memory state to disk. This can be used to save information to disk about where a module was extracted, the result of C, etc. This will then be re-loaded into memory when a new session starts. The capability of saving state to disk depends on the source engine being used (See C for the option to choose your source engine). The default storage engine supports this option. Most users will not need this command, but it can handy for automated systems like setting up CPAN smoke testers. The method will return true if it managed to save the state to disk, or false if it did not. =cut sub save_state { my $self = shift; return $self->_save_state( @_ ); } ### XXX these wrappers are not individually tested! only the underlying ### code through source.t and indirectly through he CustomSource plugin. =pod =head1 CUSTOM MODULE SOURCES Besides the sources as provided by the general C mirrors, it's possible to add your own sources list to your C index. The methodology behind this works much like C. The methods below show you how to make use of this functionality. Also note that most of these methods are available through the default shell plugin command C, making them available as shortcuts through the shell and via the commandline. =head2 %files = $cb->list_custom_sources Returns a mapping of registered custom sources and their local indices as follows: /full/path/to/local/index => http://remote/source Note that any file starting with an C<#> is being ignored. =cut sub list_custom_sources { return shift->__list_custom_module_sources( @_ ); } =head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] ); Adds an C to your own sources list and mirrors its index. See the documentation on C<< $cb->update_custom_source >> on how this is done. Returns the full path to the local index on success, or false on failure. Note that when adding a new C, the change to the in-memory tree is not saved until you rebuild or save the tree to disk again. You can do this using the C<< $cb->reload_indices >> method. =cut sub add_custom_source { return shift->_add_custom_module_source( @_ ); } =head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] ); Removes an C from your own sources list and removes its index. To find out what Cs you have as part of your own sources list, use the C<< $cb->list_custom_sources >> method. Returns the full path to the deleted local index file on success, or false on failure. =cut ### XXX do clever dispatching based on arg number? sub remove_custom_source { return shift->_remove_custom_module_source( @_ ); } =head2 $bool = $cb->update_custom_source( [remote => URI] ); Updates the indexes for all your custom sources. It does this by fetching a file called C in the root of the custom sources's C. If you provide the C argument, it will only update the index for that specific C. Here's an example of how custom sources would resolve into index files: file:///path/to/sources => file:///path/to/sources/packages.txt http://example.com/sources => http://example.com/sources/packages.txt ftp://example.com/sources => ftp://example.com/sources/packages.txt The file C simply holds a list of packages that can be found under the root of the C. This file can be automatically generated for you when the remote source is a C. For C, C, and similar, the administrator of that repository should run the method C<< $cb->write_custom_source_index >> on the repository to allow remote users to index it. For details, see the C<< $cb->write_custom_source_index >> method below. All packages that are added via this mechanism will be attributed to the author with C C. You can use this id to search for all added packages. =cut sub update_custom_source { my $self = shift; ### if it mentions /remote/, the request is to update a single uri, ### not all the ones we have, so dispatch appropriately my $rv = grep( /remote/i, @_) ? $self->__update_custom_module_source( @_ ) : $self->__update_custom_module_sources( @_ ); return $rv; } =head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] ); Writes the index for a custom repository root. Most users will not have to worry about this, but administrators of a repository will need to make sure their indexes are up to date. The index will be written to a file called C in your repository root, which you can specify with the C argument. You can override this location by specifying the C argument, but in normal operation, that should not be required. Once the index file is written, users can then add the C pointing to the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details. =cut sub write_custom_source_index { return shift->__write_custom_module_index( @_ ); } 1; =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: __END__ todo: sub dist { # not sure about this one -- probably already done enough in Module.pm sub reports { # in Module.pm, wrapper here CPANPLUS-0.9144/lib/CPANPLUS/Selfupdate.pm0000644000175000017500000004076112251421370017016 0ustar bingosbingospackage CPANPLUS::Selfupdate; use strict; use Params::Check qw[check]; use IPC::Cmd qw[can_run]; use CPANPLUS::Error qw[error msg]; use Module::Load::Conditional qw[check_install]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use CPANPLUS::Internals::Constants; use vars qw[$VERSION]; $VERSION = "0.9144"; $Params::Check::VERBOSE = 1; =head1 NAME CPANPLUS::Selfupdate - self-updating for CPANPLUS =head1 SYNOPSIS $su = $cb->selfupdate_object; @feats = $su->list_features; @feats = $su->list_enabled_features; @mods = map { $su->modules_for_feature( $_ ) } @feats; @mods = $su->list_core_dependencies; @mods = $su->list_core_modules; for ( @mods ) { print $_->name " should be version " . $_->version_required; print "Installed version is not uptodate!" unless $_->is_installed_version_sufficient; } $ok = $su->selfupdate( update => 'all', latest => 0 ); =cut ### a config has describing our deps etc { my $Modules = { dependencies => { 'File::Fetch' => '0.15_02', # lynx & 404 handling 'File::Spec' => '0.82', 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open 'Locale::Maketext::Simple' => '0.01', 'Log::Message' => '0.01', 'Module::Load' => '0.10', 'Module::Load::Conditional' => '0.50', # returns dir for loaded # modules 'version' => '0.77', # needed for M::L::C # addresses #24630 and # #24675 # Address ~0 overflow issue 'Params::Check' => '0.36', 'Package::Constants' => '0.01', 'Term::UI' => '0.18', # option parsing 'Test::Harness' => '2.62', # due to bug #19505 # only 2.58 and 2.60 are bad 'Test::More' => '0.47', # to run our tests 'Archive::Extract' => '0.16', # ./Dir bug fix 'Archive::Tar' => '1.23', 'IO::Zlib' => '1.04', # needed for Archive::Tar 'Object::Accessor' => '0.44', # mk_aliases support 'Module::CoreList' => '2.22', # deprecated core modules 'Module::Pluggable' => '2.4', 'Module::Loaded' => '0.01', 'Parse::CPAN::Meta' => '1.4200', # config_requires support 'ExtUtils::Install' => '1.42', # uninstall outside @INC ( check_install( module => 'CPANPLUS::Dist::Build' ) && !check_install( module => 'CPANPLUS::Dist::Build', version => '0.60' ) ? ( 'CPANPLUS::Dist::Build' => '0.60' ) : () ), }, features => { # config_key_name => [ # sub { } to list module key/value pairs # sub { } to check if feature is enabled # ] prefer_makefile => [ sub { my $cb = shift; $cb->configure_object->get_conf('prefer_makefile') ? { } : { 'CPANPLUS::Dist::Build' => '0.60' }; }, sub { return 1 }, # always enabled ], cpantest => [ { 'Test::Reporter' => '1.34', 'Parse::CPAN::Meta' => '1.4200' }, sub { my $cb = shift; return $cb->configure_object->get_conf('cpantest'); }, ], dist_type => [ sub { my $cb = shift; my $dist = $cb->configure_object->get_conf('dist_type'); return { $dist => '0.0' } if $dist; return; }, sub { my $cb = shift; return $cb->configure_object->get_conf('dist_type'); }, ], md5 => [ { 'Digest::SHA' => '0.0', }, sub { my $cb = shift; return $cb->configure_object->get_conf('md5'); }, ], shell => [ sub { my $cb = shift; my $dist = $cb->configure_object->get_conf('shell'); ### we bundle these shells, so don't bother having a dep ### on them... If we don't do this, CPAN.pm actually detects ### a recursive dependency and breaks (see #26077). ### This is not an issue for CPANPLUS itself, it handles ### it smartly. return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC; return { $dist => '0.0' } if $dist; return; }, sub { return 1 }, ], signature => [ sub { my $cb = shift; return { 'Module::Signature' => '0.06', } if can_run('gpg'); ### leave this out -- Crypt::OpenPGP is fairly ### painful to install, and broken on some platforms ### so we'll just always fall back to gpg. It may ### issue a warning or 2, but that's about it. ### this change due to this ticket: #26914 # and $cb->configure_object->get_conf('prefer_bin'); return { 'Crypt::OpenPGP' => '0.0', 'Module::Signature' => '0.06', }; }, sub { my $cb = shift; return $cb->configure_object->get_conf('signature'); }, ], storable => [ { 'Storable' => '0.0' }, sub { my $cb = shift; return $cb->configure_object->get_conf('storable'); }, ], sqlite_backend => [ { 'DBIx::Simple' => '0.0', 'DBD::SQLite' => '0.0', }, sub { my $cb = shift; my $conf = $cb->configure_object; return $conf->get_conf('source_engine') eq 'CPANPLUS::Internals::Source::SQLite' }, ], }, core => { 'CPANPLUS' => '0.0', }, }; sub _get_config { return $Modules } } =head1 METHODS =head2 $self = CPANPLUS::Selfupdate->new( $backend_object ); Sets up a new selfupdate object. Called automatically when a new backend object is created. =cut sub new { my $class = shift; my $cb = shift or return; return bless sub { $cb }, $class; } { ### cache to find the relevant modules my $cache = { core => sub { my $self = shift; core => [ $self->list_core_modules ] }, dependencies => sub { my $self = shift; dependencies => [ $self->list_core_dependencies ] }, enabled_features => sub { my $self = shift; map { $_ => [ $self->modules_for_feature( $_ ) ] } $self->list_enabled_features }, features => sub { my $self = shift; map { $_ => [ $self->modules_for_feature( $_ ) ] } $self->list_features }, ### make sure to do 'core' first, in case ### we are out of date ourselves all => [ qw|core dependencies enabled_features| ], }; =head2 @cat = $self->list_categories Returns a list of categories that the C method accepts. See C for details. =cut sub list_categories { return sort keys %$cache } =head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] ) List which modules C would upgrade. You can update either the core (CPANPLUS itself), the core dependencies, all features you have currently turned on, or all features available, or everything. The C option determines whether it should update to the latest version on CPAN, or if the minimal required version for CPANPLUS is good enough. Returns a hash of feature names and lists of module objects to be upgraded based on the category you provided. For example: %list = $self->list_modules_to_update( update => 'core' ); Would return: ( core => [ $module_object_for_cpanplus ] ); =cut sub list_modules_to_update { my $self = shift; my $cb = $self->(); my $conf = $cb->configure_object; my %hash = @_; my($type, $latest); my $tmpl = { update => { required => 1, store => \$type, allow => [ keys %$cache ], }, latest => { default => 0, store => \$latest, allow => BOOLEANS }, }; { local $Params::Check::ALLOW_UNKNOWN = 1; check( $tmpl, \%hash ) or return; } my $ref = $cache->{$type}; ### a list of ( feature1 => \@mods, feature2 => \@mods, etc ) my %list = UNIVERSAL::isa( $ref, 'ARRAY' ) ? map { $cache->{$_}->( $self ) } @$ref : $ref->( $self ); ### filter based on whether we need the latest ones or not for my $aref ( values %list ) { $aref = [ $latest ? grep { !$_->is_uptodate } @$aref : grep { !$_->is_installed_version_sufficient } @$aref ]; } return %list; } =head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] ) Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself), the core dependencies, all features you have currently turned on, or all features available, or everything. The C option determines whether it should update to the latest version on CPAN, or if the minimal required version for CPANPLUS is good enough. Returns true on success, false on error. =cut sub selfupdate { my $self = shift; my $cb = $self->(); my $conf = $cb->configure_object; my %hash = @_; my $force; my $tmpl = { force => { default => $conf->get_conf('force'), store => \$force }, }; { local $Params::Check::ALLOW_UNKNOWN = 1; check( $tmpl, \%hash ) or return; } my %list = $self->list_modules_to_update( %hash ) or return; ### just the modules please my @mods = map { @$_ } values %list; my $flag; for my $mod ( @mods ) { unless( $mod->install( force => $force ) ) { $flag++; error(loc("Failed to update module '%1'", $mod->name)); } } return if $flag; return 1; } } =head2 @features = $self->list_features Returns a list of features that are supported by CPANPLUS. =cut sub list_features { my $self = shift; return keys %{ $self->_get_config->{'features'} }; } =head2 @features = $self->list_enabled_features Returns a list of features that are enabled in your current CPANPLUS installation. =cut sub list_enabled_features { my $self = shift; my $cb = $self->(); my @enabled; for my $feat ( $self->list_features ) { my $ref = $self->_get_config->{'features'}->{$feat}->[1]; push @enabled, $feat if $ref->($cb); } return @enabled; } =head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] ) Returns a list of C objects which represent the modules required to support this feature. For a list of features, call the C method. If the C argument is provided, no module objects are returned, but a hashref where the keys are names of the modules, and values are their minimum versions. =cut sub modules_for_feature { my $self = shift; my $feature = shift or return; my $as_hash = shift || 0; my $cb = $self->(); unless( exists $self->_get_config->{'features'}->{$feature} ) { error(loc("Unknown feature '%1'", $feature)); return; } my $ref = $self->_get_config->{'features'}->{$feature}->[0]; ### it's either a list of modules/versions or a subroutine that ### returns a list of modules/versions my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb ); return unless $href; # nothing needed for the feature? return $href if $as_hash; return $self->_hashref_to_module( $href ); } =head2 @mods = $self->list_core_dependencies( [AS_HASH] ) Returns a list of C objects which represent the modules that comprise the core dependencies of CPANPLUS. If the C argument is provided, no module objects are returned, but a hashref where the keys are names of the modules, and values are their minimum versions. =cut sub list_core_dependencies { my $self = shift; my $as_hash = shift || 0; my $cb = $self->(); my $href = $self->_get_config->{'dependencies'}; return $href if $as_hash; return $self->_hashref_to_module( $href ); } =head2 @mods = $self->list_core_modules( [AS_HASH] ) Returns a list of C objects which represent the modules that comprise the core of CPANPLUS. If the C argument is provided, no module objects are returned, but a hashref where the keys are names of the modules, and values are their minimum versions. =cut sub list_core_modules { my $self = shift; my $as_hash = shift || 0; my $cb = $self->(); my $href = $self->_get_config->{'core'}; return $href if $as_hash; return $self->_hashref_to_module( $href ); } sub _hashref_to_module { my $self = shift; my $cb = $self->(); my $href = shift or return; return map { CPANPLUS::Selfupdate::Module->new( $cb->module_tree($_) => $href->{$_} ) } keys %$href; } =head1 CPANPLUS::Selfupdate::Module C extends C objects by providing accessors to aid in selfupdating CPANPLUS. These objects are returned by all methods of C that return module objects. =cut { package CPANPLUS::Selfupdate::Module; use base 'CPANPLUS::Module'; ### stores module name -> cpanplus required version ### XXX only can deal with 1 pair! my %Cache = (); my $Acc = 'version_required'; sub new { my $class = shift; my $mod = shift or return; my $ver = shift; return unless defined $ver; my $obj = $mod->clone; # clone the module object bless $obj, $class; # rebless it to our class $obj->$Acc( $ver ); return $obj; } =head2 $version = $mod->version_required Returns the version of this module required for CPANPLUS. =cut sub version_required { my $self = shift; $Cache{ $self->name } = shift() if @_; return $Cache{ $self->name }; } =head2 $bool = $mod->is_installed_version_sufficient Returns true if the installed version of this module is sufficient for CPANPLUS, or false if it is not. =cut sub is_installed_version_sufficient { my $self = shift; return $self->is_uptodate( version => $self->$Acc ); } } 1; =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Shell/0000755000175000017500000000000012251422462015426 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Shell/Classic.pm0000644000175000017500000010342412251421370017346 0ustar bingosbingos################################################## ### CPANPLUS/Shell/Classic.pm ### ### Backwards compatible shell for CPAN++ ### ### Written 08-04-2002 by Jos Boumans ### ################################################## package CPANPLUS::Shell::Classic; use strict; use CPANPLUS::Error; use CPANPLUS::Backend; use CPANPLUS::Configure::Setup; use CPANPLUS::Internals::Constants; use Cwd; use IPC::Cmd; use Term::UI; use Data::Dumper; use Term::ReadLine; use Module::Load qw[load]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; $Params::Check::VERBOSE = 1; $Params::Check::ALLOW_UNKNOWN = 1; BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; $VERSION = "0.9144"; } load CPANPLUS::Shell; ### our command set ### my $map = { a => '_author', b => '_bundle', d => '_distribution', 'm' => '_module', i => '_find_all', r => '_uptodate', u => '_not_supported', ls => '_ls', get => '_fetch', make => '_install', test => '_install', install => '_install', clean => '_not_supported', look => '_shell', readme => '_readme', h => '_help', '?' => '_help', o => '_set_conf', reload => '_reload', autobundle => '_autobundle', '!' => '_bang', #'q' => '_quit', # done it the loop itself }; ### the shell object, scoped to the file ### my $Shell; my $Brand = 'cpan'; my $Prompt = $Brand . '> '; sub new { my $class = shift; my $cb = new CPANPLUS::Backend; my $self = $class->SUPER::_init( brand => $Brand, term => Term::ReadLine->new( $Brand ), prompt => $Prompt, backend => $cb, format => "%5s %-50s %8s %-10s\n", ); ### make it available package wide ### $Shell = $self; ### enable verbose, it's the cpan.pm way $cb->configure_object->set_conf( verbose => 1 ); ### register install callback ### $cb->_register_callback( name => 'install_prerequisite', code => \&__ask_about_install, ); ### register test report callback ### $cb->_register_callback( name => 'edit_test_report', code => \&__ask_about_test_report, ); if (my $histfile = $self->configure_object->get_conf( 'histfile' )) { my $term = $self->term; if ($term->can('AddHistory')) { if (open my $fh, '<', $histfile) { local $/ = "\n"; while (my $line = <$fh>) { chomp($line); $term->AddHistory($line); } close($fh); } } } return $self; } sub shell { my $self = shift; my $term = $self->term; $self->_show_banner; $self->_input_loop && print "\n"; $self->_quit; } sub _input_loop { my $self = shift; my $term = $self->term; my $cb = $self->backend; my $normal_quit = 0; while ( defined (my $input = eval { $term->readline($self->prompt) } ) or $self->_signals->{INT}{count} == 1 ) { ### re-initiate all signal handlers while (my ($sig, $entry) = each %{$self->_signals} ) { $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); } last if $self->_dispatch_on_input( input => $input ); ### flush the lib cache ### $cb->_flush( list => [qw|lib load|] ); } continue { $self->_signals->{INT}{count}-- if $self->_signals->{INT}{count}; # clear the sigint count } return 1; } sub _dispatch_on_input { my $self = shift; my $conf = $self->backend->configure_object(); my $term = $self->term; my %hash = @_; my $string; my $tmpl = { input => { required => 1, store => \$string } }; check( $tmpl, \%hash ) or return; ### the original force setting; my $force_store = $conf->get_conf( 'force' ); ### parse the input: the first part before the space ### is the command, followed by arguments. ### see the usage below my $key; PARSE_INPUT: { $string =~ s|^\s*([\w\?\!]+)\s*||; chomp $string; $key = lc($1); } ### you prefixed the input with 'force' ### that means we set the force flag, and ### reparse the input... ### YAY goto block :) if( $key eq 'force' ) { $conf->set_conf( force => 1 ); goto PARSE_INPUT; } ### you want to quit return 1 if $key =~ /^q/; my $method = $map->{$key}; unless( $self->can( $method ) ) { print "Unknown command '$key'. Type ? for help.\n"; return; } ### dispatch the method call eval { $self->$method( command => $key, result => [ split /\s+/, $string ], input => $string ); }; warn $@ if $@; return; } ### displays quit message sub _quit { my $self = shift; my $term = $self->term; if ($term->can('GetHistory')) { my @history = $term->GetHistory; my $histfile = $self->configure_object->get_conf('histfile'); if (open my $fh, '>', $histfile) { foreach my $line (@history) { print {$fh} "$line\n"; } close($fh); } else { warn "Cannot open history file '$histfile' - $!"; } } ### well, that's what CPAN.pm says... print "Lockfile removed\n"; } sub _not_supported { my $self = shift; my %hash = @_; my $cmd; my $tmpl = { command => { required => 1, store => \$cmd } }; check( $tmpl, \%hash ) or return; print "Sorry, the command '$cmd' is not supported\n"; return; } sub _fetch { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $input); my $tmpl = { result => { store => \$aref, default => [] }, input => { default => 'all', store => \$input }, }; check( $tmpl, \%hash ) or return; for my $mod (@$aref) { my $obj; unless( $obj = $cb->module_tree($mod) ) { print "Warning: Cannot get $input, don't know what it is\n"; print "Try the command\n\n"; print "\ti /$mod/\n\n"; print "to find objects with matching identifiers.\n"; next; } $obj->fetch && $obj->extract; } return $aref; } sub _install { my $self = shift; my $cb = $self->backend; my %hash = @_; my $mapping = { make => { target => TARGET_CREATE, skiptest => 1 }, test => { target => TARGET_CREATE }, install => { target => TARGET_INSTALL }, }; my($aref,$cmd); my $tmpl = { result => { store => \$aref, default => [] }, command => { required => 1, store => \$cmd, allow => [keys %$mapping] }, }; check( $tmpl, \%hash ) or return; for my $mod (@$aref) { my $obj = $cb->module_tree( $mod ); unless( $obj ) { print "No such module '$mod'\n"; next; } my $opts = $mapping->{$cmd}; $obj->install( %$opts ); } return $aref; } sub _shell { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my($aref, $cmd); my $tmpl = { result => { store => \$aref, default => [] }, command => { required => 1, store => \$cmd }, }; check( $tmpl, \%hash ) or return; my $shell = $conf->get_program('shell'); unless( $shell ) { print "Your configuration does not define a value for subshells.\n". qq[Please define it with "o conf shell "\n]; return; } my $cwd = Cwd::cwd(); for my $mod (@$aref) { print "Running $cmd for $mod\n"; my $obj = $cb->module_tree( $mod ) or next; $obj->fetch or next; $obj->extract or next; $cb->_chdir( dir => $obj->status->extract ) or next; #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; if( system($shell) and $! ) { print "Error executing your subshell '$shell': $!\n"; next; } } $cb->_chdir( dir => $cwd ); return $aref; } sub _readme { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my($aref, $cmd); my $tmpl = { result => { store => \$aref, default => [] }, command => { required => 1, store => \$cmd }, }; check( $tmpl, \%hash ) or return; for my $mod (@$aref) { my $obj = $cb->module_tree( $mod ) or next; if( my $readme = $obj->readme ) { $self->_pager_open; print $readme; $self->_pager_close; } } return 1; } sub _reload { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my($input, $cmd); my $tmpl = { input => { default => 'all', store => \$input }, command => { required => 1, store => \$cmd }, }; check( $tmpl, \%hash ) or return; if ( $input =~ /cpan/i ) { print qq[You want to reload the CPAN code\n]; print qq[Just type 'q' and then restart... ] . qq[Trust me, it is MUCH safer\n]; } elsif ( $input =~ /index/i ) { $cb->reload_indices(update_source => 1); } else { print qq[cpan re-evals the CPANPLUS.pm file\n]; print qq[index re-reads the index files\n]; } return 1; } sub _autobundle { my $self = shift; my $cb = $self->backend; print qq[Writing bundle file... This may take a while\n]; my $where = $cb->autobundle(); print $where ? qq[\nWrote autobundle to $where\n] : qq[\nCould not create autobundle\n]; return 1; } sub _set_conf { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my($aref, $input); my $tmpl = { result => { store => \$aref, default => [] }, input => { default => 'all', store => \$input }, }; check( $tmpl, \%hash ) or return; my $type = shift @$aref; if( $type eq 'debug' ) { print qq[Sorry you cannot set debug options through ] . qq[this shell in CPANPLUS\n]; return; } elsif ( $type eq 'conf' ) { ### from CPAN.pm :o) # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf' # should have been called set and 'o debug' maybe 'set debug' # commit Commit changes to disk # defaults Reload defaults from disk # init Interactive setting of all options my $name = shift @$aref; my $value = "@$aref"; if( $name eq 'init' ) { my $setup = CPANPLUS::Configure::Setup->new( conf => $cb->configure_object, term => $self->term, backend => $cb, ); return $setup->init; } elsif ($name eq 'commit' ) {; $cb->configure_object->save; print "Your CPAN++ configuration info has been saved!\n\n"; return; } elsif ($name eq 'defaults' ) { print qq[Sorry, CPANPLUS cannot restore default for you.\n] . qq[Perhaps you should run the interactive setup again.\n] . qq[\ttry running 'o conf init'\n]; return; ### we're just supplying things in the 'conf' section now, ### not the program section.. it's a bit of a hassle to make that ### work cleanly with the original CPAN.pm interface, so we'll fix ### it when people start complaining, which is hopefully never. } else { unless( $name ) { my @list = grep { $_ ne 'hosts' } $conf->options( type => $type ); my $method = 'get_' . $type; local $Data::Dumper::Indent = 0; for my $name ( @list ) { my $val = $conf->$method($name); ($val) = ref($val) ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) : "'$val'"; printf " %-25s %s\n", $name, $val; } } elsif ( $name eq 'hosts' ) { print "Setting hosts is not trivial.\n" . "It is suggested you edit the " . "configuration file manually"; } else { my $method = 'set_' . $type; if( $conf->$method($name => defined $value ? $value : '') ) { my $set_to = defined $value ? $value : 'EMPTY STRING'; print "Key '$name' was set to '$set_to'\n"; } } } } else { print qq[Known options:\n] . qq[ conf set or get configuration variables\n] . qq[ debug set or get debugging options\n]; } return; } ######################## ### search functions ### ######################## sub _author { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $short, $input, $class); my $tmpl = { result => { store => \$aref, default => ['/./'] }, short => { default => 0, store => \$short }, input => { default => 'all', store => \$input }, class => { default => 'Author', no_override => 1, store => \$class }, }; check( $tmpl, \%hash ) or return; my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref; my @rv; for my $type (qw[author cpanid]) { push @rv, $cb->search( type => $type, allow => \@regexes ); } unless( @rv ) { print "No object of type $class found for argument $input\n" unless $short; return; } return $self->_pp_author( result => \@rv, class => $class, short => $short, input => $input ); } ### find all modules matching a query ### sub _module { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $short, $input, $class); my $tmpl = { result => { store => \$aref, default => ['/./'] }, short => { default => 0, store => \$short }, input => { default => 'all', store => \$input }, class => { default => 'Module', no_override => 1, store => \$class }, }; check( $tmpl, \%hash ) or return; my @rv; for my $module (@$aref) { if( $module =~ m|/(.+)/| ) { push @rv, $cb->search( type => 'module', allow => [qr/$1/i] ); } else { my $obj = $cb->module_tree( $module ) or next; push @rv, $obj; } } return $self->_pp_module( result => \@rv, class => $class, short => $short, input => $input ); } ### find all bundles matching a query ### sub _bundle { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $short, $input, $class); my $tmpl = { result => { store => \$aref, default => ['/./'] }, short => { default => 0, store => \$short }, input => { default => 'all', store => \$input }, class => { default => 'Bundle', no_override => 1, store => \$class }, }; check( $tmpl, \%hash ) or return; my @rv; for my $bundle (@$aref) { if( $bundle =~ m|/(.+)/| ) { push @rv, $cb->search( type => 'module', allow => [qr/Bundle::.*?$1/i] ); } else { my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next; push @rv, $obj; } } return $self->_pp_module( result => \@rv, class => $class, short => $short, input => $input ); } sub _distribution { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $short, $input, $class); my $tmpl = { result => { store => \$aref, default => ['/./'] }, short => { default => 0, store => \$short }, input => { default => 'all', store => \$input }, class => { default => 'Distribution', no_override => 1, store => \$class }, }; check( $tmpl, \%hash ) or return; my @rv; for my $module (@$aref) { ### if it's a regex... ### if ( my ($match) = $module =~ m|^/(.+)/$|) { ### something like /FOO/Bar.tar.gz/ was entered if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) { my $seen; my @data = $cb->search( type => 'package', allow => [qr/$package/i] ); my @list = $cb->search( type => 'path', allow => [qr/$path/i], data => \@data ); ### make sure we don't list the same dist twice for my $val ( @list ) { next if $seen->{$val->package}++; push @rv, $val; } ### something like /FOO/ or /Bar.tgz/ was entered ### so we look both in the path, as well as in the package name } else { my $seen; { my @list = $cb->search( type => 'package', allow => [qr/$match/i] ); ### make sure we don't list the same dist twice for my $val ( @list ) { next if $seen->{$val->package}++; push @rv, $val; } } { my @list = $cb->search( type => 'path', allow => [qr/$match/i] ); ### make sure we don't list the same dist twice for my $val ( @list ) { next if $seen->{$val->package}++; push @rv, $val; } } } } else { ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) { my @data = $cb->search( type => 'package', allow => [qr/^$package$/] ); my @list = $cb->search( type => 'path', allow => [qr/$path$/i], data => \@data); ### make sure we don't list the same dist twice my $seen; for my $val ( @list ) { next if $seen->{$val->package}++; push @rv, $val; } } } } return $self->_pp_distribution( result => \@rv, class => $class, short => $short, input => $input ); } sub _find_all { my $self = shift; my @rv; for my $method (qw[_author _bundle _module _distribution]) { my $aref = $self->$method( @_, short => 1 ); push @rv, @$aref if $aref; } print scalar(@rv). " items found\n" } sub _uptodate { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $short, $input, $class); my $tmpl = { result => { store => \$aref, default => ['/./'] }, short => { default => 0, store => \$short }, input => { default => 'all', store => \$input }, class => { default => 'Uptodate', no_override => 1, store => \$class }, }; check( $tmpl, \%hash ) or return; my @rv; if( @$aref) { for my $module (@$aref) { if( $module =~ m|/(.+)/| ) { my @list = $cb->search( type => 'module', allow => [qr/$1/i] ); ### only add those that are installed and not core push @rv, grep { not $_->package_is_perl_core } grep { $_->installed_file } @list; } else { my $obj = $cb->module_tree( $module ) or next; push @rv, $obj; } } } else { @rv = @{$cb->_all_installed}; } return $self->_pp_uptodate( result => \@rv, class => $class, short => $short, input => $input ); } sub _ls { my $self = shift; my $cb = $self->backend; my %hash = @_; my($aref, $short, $input, $class); my $tmpl = { result => { store => \$aref, default => [] }, short => { default => 0, store => \$short }, input => { default => 'all', store => \$input }, class => { default => 'Uptodate', no_override => 1, store => \$class }, }; check( $tmpl, \%hash ) or return; my @rv; for my $name (@$aref) { my $auth = $cb->author_tree( uc $name ); unless( $auth ) { print qq[ls command rejects argument $name: not an author\n]; next; } push @rv, $auth->distributions; } return $self->_pp_ls( result => \@rv, class => $class, short => $short, input => $input ); } ############################ ### pretty printing subs ### ############################ sub _pp_author { my $self = shift; my %hash = @_; my( $aref, $short, $class, $input ); my $tmpl = { result => { required => 1, default => [], strict_type => 1, store => \$aref }, short => { default => 0, store => \$short }, class => { required => 1, store => \$class }, input => { required => 1, store => \$input }, }; check( $tmpl, \%hash ) or return; ### no results if( !@$aref ) { print "No objects of type $class found for argument $input\n" unless $short; ### one result, long output desired; } elsif( @$aref == 1 and !$short ) { ### should look like this: #cpan> a KANE #Author id = KANE # EMAIL boumans@frg.eur.nl # FULLNAME Jos Boumans my $obj = shift @$aref; print "$class id = ", $obj->cpanid(), "\n"; printf " %-12s %s\n", 'EMAIL', $obj->email(); printf " %-12s %s%s\n", 'FULLNAME', $obj->author(); } else { ### should look like this: #Author KANE (Jos Boumans) #Author LBROCARD (Leon Brocard) #2 items found for my $obj ( @$aref ) { printf qq[%-15s %s ("%s" (%s))\n], $class, $obj->cpanid, $obj->author, $obj->email; } print scalar(@$aref)." items found\n" unless $short; } return $aref; } sub _pp_module { my $self = shift; my %hash = @_; my( $aref, $short, $class, $input ); my $tmpl = { result => { required => 1, default => [], strict_type => 1, store => \$aref }, short => { default => 0, store => \$short }, class => { required => 1, store => \$class }, input => { required => 1, store => \$input }, }; check( $tmpl, \%hash ) or return; ### no results if( !@$aref ) { print "No objects of type $class found for argument $input\n" unless $short; ### one result, long output desired; } elsif( @$aref == 1 and !$short ) { ### should look like this: #Module id = LWP # DESCRIPTION Libwww-perl # CPAN_USERID GAAS (Gisle Aas ) # CPAN_VERSION 5.64 # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented) # MANPAGE LWP - The World-Wide Web library for Perl # INST_FILE C:\Perl\site\lib\LWP.pm # INST_VERSION 5.62 my $obj = shift @$aref; my $aut_obj = $obj->author; my $format = " %-12s %s%s\n"; print "$class id = ", $obj->module(), "\n"; printf $format, 'DESCRIPTION', $obj->description() if $obj->description(); printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" . $aut_obj->author() . " <" . $aut_obj->email() . ">)"; printf $format, 'CPAN_VERSION', $obj->version(); printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package(); printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip) if $obj->dslip() =~ /\w/; #printf $format, 'MANPAGE', $obj->foo(); ### this is for bundles... CPAN.pm downloads them, #printf $format, 'CONATAINS, # parses and goes from there... printf $format, 'INST_FILE', $obj->installed_file || '(not installed)'; printf $format, 'INST_VERSION', $obj->installed_version; } else { ### should look like this: #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz) #2 items found for my $obj ( @$aref ) { printf "%-15s %-15s (%s)\n", $class, $obj->module(), $obj->path() .'/'. $obj->package(); } print scalar(@$aref). " items found\n" unless $short; } return $aref; } sub _pp_dslip { my $self = shift; my $dslip = shift or return; my (%_statusD, %_statusS, %_statusL, %_statusI); @_statusD{qw(? i c a b R M S)} = qw(unknown idea pre-alpha alpha beta released mature standard); @_statusS{qw(? m d u n)} = qw(unknown mailing-list developer comp.lang.perl.* none); @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid); @_statusI{qw(? f r O h)} = qw(unknown functions references+ties object-oriented hybrid); my @status = split("", $dslip); my $results = sprintf( "%s (%s,%s,%s,%s)", $dslip, $_statusD{$status[0]}, $_statusS{$status[1]}, $_statusL{$status[2]}, $_statusI{$status[3]} ); return $results; } sub _pp_distribution { my $self = shift; my $cb = $self->backend; my %hash = @_; my( $aref, $short, $class, $input ); my $tmpl = { result => { required => 1, default => [], strict_type => 1, store => \$aref }, short => { default => 0, store => \$short }, class => { required => 1, store => \$class }, input => { required => 1, store => \$input }, }; check( $tmpl, \%hash ) or return; ### no results if( !@$aref ) { print "No objects of type $class found for argument $input\n" unless $short; ### one result, long output desired; } elsif( @$aref == 1 and !$short ) { ### should look like this: #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz # CPAN_USERID SABECK (Scott Beck ) # CONTAINSMODS POE::Component::Client::POP3 my $obj = shift @$aref; my $aut_obj = $obj->author; my $pkg = $obj->package; my $format = " %-12s %s\n"; my @list = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); print "$class id = ", $obj->path(), '/', $obj->package(), "\n"; printf $format, 'CPAN_USERID', $aut_obj->cpanid .' ('. $aut_obj->author . ' '. $aut_obj->email .')'; ### yes i know it's ugly, but it's what cpan.pm does printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list); } else { ### should look like this: #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz) #2 items found for my $obj ( @$aref ) { printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package(); } print scalar(@$aref). " items found\n" unless $short; } return $aref; } sub _pp_uptodate { my $self = shift; my $cb = $self->backend; my %hash = @_; my( $aref, $short, $class, $input ); my $tmpl = { result => { required => 1, default => [], strict_type => 1, store => \$aref }, short => { default => 0, store => \$short }, class => { required => 1, store => \$class }, input => { required => 1, store => \$input }, }; check( $tmpl, \%hash ) or return; my $format = "%-25s %9s %9s %s\n"; my @not_uptodate; my $no_version; my %seen; for my $mod (@$aref) { next if $mod->package_is_perl_core; next if $seen{ $mod->package }++; if( $mod->installed_file and not $mod->installed_version ) { $no_version++; next; } push @not_uptodate, $mod unless $mod->is_uptodate; } unless( @not_uptodate ) { my $string = $input ? "for $input" : ''; print "All modules are up to date $string\n"; return; } else { printf $format, ( 'Package namespace', 'installed', 'latest', 'in CPAN file' ); } for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) { printf $format, ( $mod->module, $mod->installed_version, $mod->version, $mod->path .'/'. $mod->package, ); } print "$no_version installed modules have no (parsable) version number\n" if $no_version; return \@not_uptodate; } sub _pp_ls { my $self = shift; my $cb = $self->backend; my %hash = @_; my( $aref, $short, $class, $input ); my $tmpl = { result => { required => 1, default => [], strict_type => 1, store => \$aref }, short => { default => 0, store => \$short }, class => { required => 1, store => \$class }, input => { required => 1, store => \$input }, }; check( $tmpl, \%hash ) or return; ### should look something like this: #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz #8171 2002-08-13 KANE/Acme-Comment-1.01.zip #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz ### don't know size or mtime #my $format = "%8d %10s %s/%s\n"; for my $mod ( sort { $a->package cmp $b->package } @$aref ) { print "\t" . $mod->package . "\n"; } return $aref; } ############################# ### end pretty print subs ### ############################# sub _bang { my $self = shift; my %hash = @_; my( $input ); my $tmpl = { input => { required => 1, store => \$input }, }; check( $tmpl, \%hash ) or return; eval $input; warn $@ if $@; print "\n"; return; } sub _help { print qq[ Display Information a authors b string display bundles d or info distributions m /regex/ about modules i or anything of above r none reinstall recommendations u uninstalled distributions Download, Test, Make, Install... get download make make (implies get) test modules, make test (implies make) install dists, bundles make install (implies test) clean make clean look open subshell in these dists' directories readme display these dists' README files Other h,? display this menu ! perl-code eval a perl command o conf [opt] set and query options q quit the cpan shell reload cpan load CPAN.pm again reload index load newer indices autobundle Snapshot force cmd unconditionally do cmd ]; } 1; __END__ =pod =head1 NAME CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS =head1 DESCRIPTION The Classic shell is designed to provide the feel of the CPAN.pm shell using CPANPLUS underneath. For detailed documentation, refer to L. =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =cut =head1 SEE ALSO L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Shell/Default.pm0000644000175000017500000016305512251421370017357 0ustar bingosbingospackage CPANPLUS::Shell::Default; use strict; use CPANPLUS::Error; use CPANPLUS::Backend; use CPANPLUS::Configure::Setup; use CPANPLUS::Internals::Constants; use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL]; use Cwd; use IPC::Cmd; use Term::UI; use Data::Dumper; use Term::ReadLine; use Module::Load qw[load]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load check_install]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; local $Params::Check::VERBOSE = 1; local $Data::Dumper::Indent = 1; # for dumpering from ! BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; $VERSION = "0.9144"; } load CPANPLUS::Shell; my $map = { 'm' => '_search_module', 'a' => '_search_author', '!' => '_bang', '?' => '_help', 'h' => '_help', 'q' => '_quit', 'r' => '_readme', 'v' => '_show_banner', 'w' => '__display_results', 'd' => '_fetch', 'z' => '_shell', 'f' => '_distributions', 'x' => '_reload_indices', 'i' => '_install', 't' => '_install', 'l' => '_details', 'p' => '_print', 's' => '_set_conf', 'o' => '_uptodate', 'b' => '_autobundle', 'u' => '_uninstall', '/' => '_meta', # undocumented for now 'c' => '_reports', 'e' => '_reload_shell', }; ### free letters: e g j k n y ### ### will be filled if you have a .default-shell.rc and ### Config::Auto installed my $rc = {}; ### the shell object, scoped to the file ### my $Shell; my $Brand = loc('CPAN Terminal'); my $Prompt = $Brand . '> '; =pod =head1 NAME CPANPLUS::Shell::Default - the default CPANPLUS shell =head1 SYNOPSIS ### loading the shell: $ cpanp # run 'cpanp' from the command line $ perl -MCPANPLUS -eshell # load the shell from the command line use CPANPLUS::Shell qw[Default]; # load this shell via the API # always done via CPANPLUS::Shell my $ui = CPANPLUS::Shell->new; $ui->shell; # run the shell $ui->dispatch_on_input( input => 'x'); # update the source using the # dispatch method ### when in the shell: ### Note that all commands can also take options. ### Look at their underlying CPANPLUS::Backend methods to see ### what options those are. cpanp> h # show help messages cpanp> ? # show help messages cpanp> m Acme # find acme modules, allows regexes cpanp> a KANE # find modules by kane, allows regexes cpanp> f Acme::Foo # get a list of all releases of Acme::Foo cpanp> i Acme::Foo # install Acme::Foo cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo cpanp> i # install from URI, like ftp://foo.com/X.tgz cpanp> i # install from an absolute or relative directory cpanp> i 1 3..5 # install search results 1, 3, 4 and 5 cpanp> i * # install all search results cpanp> a KANE; i *; # find modules by kane, install all results cpanp> t Acme::Foo # test Acme::Foo, without installing it cpanp> u Acme::Foo # uninstall Acme::Foo cpanp> d Acme::Foo # download Acme::Foo cpanp> z Acme::Foo # download & extract Acme::Foo, then open a # shell in the extraction directory cpanp> c Acme::Foo # get a list of test results for Acme::Foo cpanp> l Acme::Foo # view details about the Acme::Foo package cpanp> r Acme::Foo # view Acme::Foo's README file cpanp> o # get a list of all installed modules that # are out of date cpanp> o 1..3 # list uptodateness from a previous search cpanp> s conf # show config settings cpanp> s conf md5 1 # enable md5 checks cpanp> s program # show program settings cpanp> s edit # edit config file cpanp> s reconfigure # go through initial configuration again cpanp> s selfupdate # update your CPANPLUS install cpanp> s save # save config to disk cpanp> s mirrors # show currently selected mirrors cpanp> ! [PERL CODE] # execute the following perl code cpanp> b # create an autobundle for this computers # perl installation cpanp> x # reload index files (purges cache) cpanp> x --update_source # reload index files, get fresh source files cpanp> p [FILE] # print error stack (to a file) cpanp> v # show the banner cpanp> w # show last search results again cpanp> q # quit the shell cpanp> e # exit the shell and reload cpanp> /plugins # list available plugins cpanp> /? PLUGIN # list help test of ### common options: cpanp> i ... --skiptest # skip tests cpanp> i ... --force # force all operations cpanp> i ... --verbose # run in verbose mode =head1 DESCRIPTION This module provides the default user interface to C. You can start it via the C binary, or as detailed in the L. =cut sub new { my $class = shift; my $cb = CPANPLUS::Backend->new( @_ ); my $self = $class->SUPER::_init( brand => $Brand, term => Term::ReadLine->new( $Brand ), prompt => $Prompt, backend => $cb, format => "%4s %-55s %8s %-10s\n", dist_format => "%4s %-42s %-12s %8s %-10s\n", ); ### make it available package wide ### $Shell = $self; my $rc_file = File::Spec->catfile( $cb->configure_object->get_conf('base'), DOT_SHELL_DEFAULT_RC, ); if( -e $rc_file && -r _ ) { $rc = $self->_read_configuration_from_rc( $rc_file ); } ### register install callback ### $cb->_register_callback( name => 'install_prerequisite', code => \&__ask_about_install, ); ### execute any login commands specified ### $self->dispatch_on_input( input => $rc->{'login'} ) if defined $rc->{'login'}; ### register test report callbacks ### $cb->_register_callback( name => 'edit_test_report', code => \&__ask_about_edit_test_report, ); $cb->_register_callback( name => 'send_test_report', code => \&__ask_about_send_test_report, ); $cb->_register_callback( name => 'proceed_on_test_failure', code => \&__ask_about_test_failure, ); ### load all the plugins $self->_plugins_init; if (my $histfile = $cb->configure_object->get_conf( 'histfile' )) { my $term = $self->term; if ($term->can('AddHistory')) { if (open my $fh, '<', $histfile) { local $/ = "\n"; while (my $line = <$fh>) { chomp($line); $term->AddHistory($line); } close($fh); } } } return $self; } sub shell { my $self = shift; my $term = $self->term; my $conf = $self->backend->configure_object; $self->_show_banner; $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner? $self->_show_random_tip if $conf->get_conf('show_startup_tip'); $self->_input_loop && $self->__print( "\n" ); $self->_quit; } sub _input_loop { my $self = shift; my $term = $self->term; my $cb = $self->backend; my $normal_quit = 0; while ( defined (my $input = eval { $term->readline($self->prompt) } ) or $self->_signals->{INT}{count} == 1 ) { ### re-initiate all signal handlers while (my ($sig, $entry) = each %{$self->_signals} ) { $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); } $self->__print( "\n" ); last if $self->dispatch_on_input( input => $input ); ### flush the lib cache ### $cb->_flush( list => [qw|lib load|] ); } continue { ### clear the sigint count $self->_signals->{INT}{count}-- if $self->_signals->{INT}{count}; ### reset the 'install prereq?' cached answer $self->settings->{'install_all_prereqs'} = undef; } return 1; } ### return 1 to quit ### sub dispatch_on_input { my $self = shift; my $conf = $self->backend->configure_object(); my $term = $self->term; my %hash = @_; my($string, $noninteractive); my $tmpl = { input => { required => 1, store => \$string }, noninteractive => { required => 0, store => \$noninteractive }, }; check( $tmpl, \%hash ) or return; ### indicates whether or not the user will receive a shell ### prompt after the command has finished. $self->noninteractive($noninteractive) if defined $noninteractive; my $rv = 1; my @cmds = split ';', $string; while( my $input = shift @cmds ) { ### to send over the socket ### my $org_input = $input; my $key; my $options; { ### make whitespace not count when using special chars { $input =~ s|^\s*([!?/])|$1 |; } ### get the first letter of the input $input =~ s|^\s*([\w\?\!/])\w*||; chomp $input; $key = lc($1); ### we figured out what the command was... ### if we have more input, that DOES NOT start with a white ### space char, we misparsed.. like 'Test::Foo::Bar', which ### would turn into 't', '::Foo::Bar'... if( $input and $input !~ s/^\s+// ) { $self->__print( loc("Could not understand command: %1\n". "Possibly missing command before argument(s)?\n", $org_input) ); return; } ### allow overrides from the config file ### if( defined $rc->{$key} ) { $input = $rc->{$key} . $input; } ### grab command line options like --no-force and --verbose ### ($options,$input) = $term->parse_options($input) unless $key eq '!'; } ### empty line? ### return unless $key; ### time to quit ### return 1 if $key eq 'q'; my $method = $map->{$key}; ### dispatch meta locally at all times ### if( $key eq '/' ) { ### keep track of failures $rv *= length $self->$method(input => $input, options => $options); next; } ### flush unless we're trying to print the stack CPANPLUS::Error->flush unless $key eq 'p'; ### connected over a socket? ### if( $self->remote ) { ### unsupported commands ### if( $key eq 'z' or ($key eq 's' and $input =~ /^\s*edit/) ) { $self->__print( "\n", loc( "Command '%1' not supported over remote connection", join ' ', $key, $input ), "\n\n" ); } else { my($status,$buff) = $self->__send_remote_command($org_input); $self->__print( "\n", loc("Command failed!"), "\n\n" ) unless $status; ### keep track of failures $rv *= length $status; $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount; $self->__print( $buff ); $self->_pager_close; } ### or just a plain local shell? ### } else { unless( $self->can($method) ) { $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n"); $self->_help; } else { ### some methods don't need modules ### my @mods; @mods = $self->_select_modules($input) unless grep {$key eq $_} qw[! m a v w x p s b / ? h]; ### keep track of failures $rv *= defined eval { $self->$method( modules => \@mods, options => $options, input => $input, choice => $key ) }; error( $@ ) if $@; } } } ### outside the shell loop, we can return the actual return value; return $rv if $self->noninteractive; return; } sub _select_modules { my $self = shift; my $input = shift or return; my $cache = $self->cache; my $cb = $self->backend; ### expand .. in $input $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b} {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg; $input = join(' ', 1 .. $#{$cache}) if $input eq '*'; $input =~ s/'/::/g; # perl 4 convention my @rv; for my $mod (split /\s+/, $input) { ### it's a cache look up ### if( $mod =~ /^\d+/ and $mod > 0 ) { unless( scalar @$cache ) { $self->__print( loc("No search was done yet!"), "\n" ); } elsif ( my $obj = $cache->[$mod] ) { push @rv, $obj; } else { $self->__print( loc("No such module: %1", $mod), "\n" ); } } else { my $obj = $cb->parse_module( module => $mod ); unless( $obj ) { $self->__print( loc("No such module: %1", $mod), "\n" ); } else { push @rv, $obj; } } } unless( scalar @rv ) { $self->__print( loc("No modules found to operate on!\n") ); return; } else { return @rv; } } sub _format_version { my $self = shift; my $version = shift || 0; ### fudge $version into the 'optimal' format $version = 0 if $version eq 'undef'; $version =~ s/_//g; # everything after gets stripped off otherwise ### allow 6 digits after the dot, as that's how perl stringifies ### x.y.z numbers. $version = sprintf('%3.6f', $version); $version = '' if $version == '0.00'; $version =~ s/(00{0,3})$/' ' x (length $1)/e; return $version; } sub __display_results { my $self = shift; my $cache = $self->cache; my @rv = @$cache; if( scalar @rv ) { $self->_pager_open if $#{$cache} >= $self->_term_rowcount; my $i = 1; for my $mod (@rv) { next unless $mod; # first one is undef # humans start counting at 1 ### for dists only -- we have checksum info if( $mod->mtime ) { $self->__printf( $self->dist_format, $i, $mod->module, $mod->mtime, $self->_format_version( $mod->version ), $mod->author->cpanid ); } else { $self->__printf( $self->format, $i, $mod->module, $self->_format_version( $mod->version ), $mod->author->cpanid ); } $i++; } $self->_pager_close; } else { $self->__print( loc("No results to display"), "\n" ); } return 1; } sub _quit { my $self = shift; my $term = $self->term; $self->dispatch_on_input( input => $rc->{'logout'} ) if defined $rc->{'logout'}; if ($term->can('GetHistory')) { my @history = $term->GetHistory; my $histfile = $self->backend->configure_object->get_conf('histfile'); if (open my $fh, '>', $histfile) { foreach my $line (@history) { print {$fh} "$line\n"; } close($fh); } else { warn "Cannot open history file '$histfile' - $!"; } } $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); return 1; } ########################### ### actual command subs ### ########################### ### print out the help message ### ### perhaps, '?' should be a slightly different version ### { my @help; sub _help { my $self = shift; my %hash = @_; my $input; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { input => { required => 0, store => \$input } }; my $args = check( $tmpl, \%hash ) or return; } @help = ( loc('[General]' ), loc(' h | ? # display help' ), loc(' q # exit' ), loc(' e # exit and reload' ), loc(' v # version information' ), loc('[Search]' ), loc(' a AUTHOR ... # search by author(s)' ), loc(' m MODULE ... # search by module(s)' ), loc(' f MODULE ... # list all releases of a module' ), loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ), loc(' w # display the result of your last search again' ), loc('[Operations]' ), loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ), loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ), loc(' i DIR | ... # install module(s), by path (ie ./Module-1.0)' ), loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ), loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ), loc(' d MODULE | NUMBER ... # download module(s)' ), loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ), loc(' r MODULE | NUMBER ... # display README files of module(s)' ), loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ), loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ), loc('[Local Administration]' ), loc(' b # write a bundle file for your configuration' ), loc(' s program [OPT VALUE] # set program locations for this session' ), loc(' s conf [OPT VALUE] # set config options for this session' ), loc(' s mirrors # show currently selected mirrors' ), loc(' s reconfigure # reconfigure settings ' ), loc(' s selfupdate # update your CPANPLUS install '), loc(' s save [user|system] # save settings for this user or systemwide' ), loc(' s edit [user|system] # open configuration file in editor and reload' ), loc(' ! EXPR # evaluate a perl statement' ), loc(' p [FILE] # print the error stack (optionally to a file)' ), loc(' x # reload CPAN indices (purges cache)' ), loc(' x --update_source # reload CPAN indices, get fresh source files' ), loc('[Common Options]' ), loc(' i ... --skiptest # skip tests' ), loc(' i ... --force # force all operations' ), loc(' i ... --verbose # run in verbose mode' ), loc('[Plugins]' ), loc(' /plugins # list available plugins' ), loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), ) unless @help; $self->_pager_open if (@help >= $self->_term_rowcount); ### XXX: functional placeholder for actual 'detailed' help. $self->__print( "Detailed help for the command '$input' is " . "not available.\n\n" ) if length $input; $self->__print( map {"$_\n"} @help ); $self->__print( $/ ); $self->_pager_close; return 1; } } ### eval some code ### sub _bang { my $self = shift; my $cb = $self->backend; my %hash = @_; my $input; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { input => { required => 1, store => \$input } }; my $args = check( $tmpl, \%hash ) or return; } local $Data::Dumper::Indent = 1; # for dumpering from ! eval $input; error( $@ ) if $@; $self->__print( "\n" ); return if $@; return 1; } sub _search_module { my $self = shift; my $cb = $self->backend; my %hash = @_; my $args; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { input => { required => 1, }, options => { default => { } }, }; $args = check( $tmpl, \%hash ) or return; } my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; ### XXX this is rather slow, because (probably) ### of the many method calls ### XXX need to profile to speed it up =/ ### find the modules ### my @rv = sort { $a->module cmp $b->module } $cb->search( %{$args->{'options'}}, type => 'module', allow => \@regexes, ); ### store the result in the cache ### $self->cache([undef,@rv]); $self->__display_results; return 1; } sub _search_author { my $self = shift; my $cb = $self->backend; my %hash = @_; my $args; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { input => { required => 1, }, options => { default => { } }, }; $args = check( $tmpl, \%hash ) or return; } my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; my @rv; for my $type (qw[author cpanid]) { push @rv, $cb->search( %{$args->{'options'}}, type => $type, allow => \@regexes, ); } my %seen; my @list = sort { $a->module cmp $b->module } grep { defined } map { $_->modules } grep { not $seen{$_}++ } @rv; $self->cache([undef,@list]); $self->__display_results; return 1; } sub _readme { my $self = shift; my $cb = $self->backend; my %hash = @_; my $args; my $mods; my $opts; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { required => 1, store => \$mods }, options => { default => { }, store => \$opts }, }; $args = check( $tmpl, \%hash ) or return; } return unless scalar @$mods; $self->_pager_open; for my $mod ( @$mods ) { $self->__print( $mod->readme( %$opts ) ); } $self->_pager_close; return 1; } sub _fetch { my $self = shift; my $cb = $self->backend; my %hash = @_; my $args; my $mods; my $opts; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { required => 1, store => \$mods }, options => { default => { }, store => \$opts }, }; $args = check( $tmpl, \%hash ) or return; } $self->_pager_open if @$mods >= $self->_term_rowcount; my $rv = 1; for my $mod (@$mods) { my $where = $mod->fetch( %$opts ); $rv *= length $where; $self->__print( $where ? loc("Successfully fetched '%1' to '%2'", $mod->module, $where ) : loc("Failed to fetch '%1'", $mod->module) ); $self->__print( "\n" ); } $self->_pager_close; return 1 if $rv; return; } sub _shell { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my $shell = $conf->get_program('shell'); unless( $shell ) { $self->__print( loc("Your config does not specify a subshell!"), "\n", loc("Perhaps you need to re-run your setup?"), "\n" ); return; } my $args; my $mods; my $opts; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { required => 1, store => \$mods }, options => { default => { }, store => \$opts }, }; $args = check( $tmpl, \%hash ) or return; } my $cwd = Cwd::cwd(); for my $mod (@$mods) { $mod->fetch( %$opts ) or next; $mod->extract( %$opts ) or next; $cb->_chdir( dir => $mod->status->extract() ) or next; #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; if( system($shell) and $! ) { $self->__print( loc("Error executing your subshell '%1': %2", $shell, $!),"\n" ); next; } } $cb->_chdir( dir => $cwd ); return 1; } sub _distributions { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my $args; my $mods; my $opts; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { required => 1, store => \$mods }, options => { default => { }, store => \$opts }, }; $args = check( $tmpl, \%hash ) or return; } my @list; for my $mod (@$mods) { push @list, sort { $a->version <=> $b->version } grep { defined } $mod->distributions( %$opts ); } my @rv = sort { $a->module cmp $b->module } @list; $self->cache([undef,@rv]); $self->__display_results; return 1; } sub _reload_indices { my $self = shift; my $cb = $self->backend; my %hash = @_; my $args; my $opts; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, }; $args = check( $tmpl, \%hash ) or return; } my $rv = $cb->reload_indices( %$opts ); ### so the update failed, but you didn't give it any options either if( !$rv and !(keys %$opts) ) { $self->__print( "\nFailure may be due to corrupt source files\n" . "Try this:\n\tx --update_source\n\n" ); } return $rv; } sub _install { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my $args; my $mods; my $opts; my $choice; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { required => 1, store => \$mods }, options => { default => { }, store => \$opts }, choice => { required => 1, store => \$choice, allow => [qw|i t|] }, }; $args = check( $tmpl, \%hash ) or return; } unless( scalar @$mods ) { $self->__print( loc("Nothing done\n") ); return; } my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE; my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing '); my $action = $choice eq 'i' ? 'install' : 'test'; my $status = {}; ### first loop over the mods to install them ### for my $mod (@$mods) { $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" ); my $log_length = length CPANPLUS::Error->stack_as_string; ### store the status for look up when we're done with all ### install calls $status->{$mod} = $mod->install( %$opts, target => $target ); ### would you like a log file of what happened? if( $conf->get_conf('write_install_logs') ) { if ( ON_WIN32 and !check_install( module => 'IPC::Run', version => 0.55 ) ) { error(loc("IPC::Run version '%1' is required on MSWin32" . " in order to capture buffers." . " The logfile generated may not contain" . " any useful data, until it is installed", 0.55)); } my $dir = File::Spec->catdir( $conf->get_conf('base'), $conf->_get_build('install_log_dir'), ); ### create the dir if it doesn't exit yet $cb->_mkdir( dir => $dir ) unless -d $dir; my $file = File::Spec->catfile( $dir, INSTALL_LOG_FILE->( $mod ) ); if ( open my $fh, ">$file" ) { my $stack = CPANPLUS::Error->stack_as_string; ### remove everything in the log that was there *before* ### we started this install substr( $stack, 0, $log_length, '' ); print $fh $stack; close $fh; $self->__print( loc("*** Install log written to:\n %1\n\n", $file) ); } else { warn "Could not open '$file': $!\n"; next; } } } my $flag; ### then report whether all this went ok or not ### for my $mod (@$mods) { # if( $mod->status->installed ) { if( $status->{$mod} ) { $self->__print( loc("Module '%1' %tense(%2,past) successfully\n", $mod->module, $action) ); } else { $flag++; $self->__print( loc("Error %tense(%1,present) '%2'\n", $action, $mod->module) ); } } if( !$flag ) { $self->__print( loc("No errors %tense(%1,present) all modules", $action), "\n" ); } else { $self->__print( loc("Problem %tense(%1,present) one or more modules", $action) ); $self->__print( "\n" ); $self->__print( loc("*** You can view the complete error buffer by pressing ". "'%1' ***\n", 'p') ) unless $conf->get_conf('verbose') || $self->noninteractive; } $self->__print( "\n" ); return !$flag; } sub __ask_about_install { my $mod = shift or return; my $prereq = shift or return; my $term = $Shell->term; $Shell->__print( "\n" ); $Shell->__print( loc("Module '%1' requires '%2' to be installed", $mod->module, $prereq->module ) ); $Shell->__print( "\n\n" ); ### previously cached answer? return $Shell->settings->{'install_all_prereqs'} if defined $Shell->settings->{'install_all_prereqs'}; $Shell->__print( loc( "If you don't wish to see this question anymore\n". "you can disable it by entering the following ". "commands on the prompt:\n '%1'", 's conf prereqs 1; s save' ) ); $Shell->__print("\n\n"); my $yes = loc("Yes"); my $no = loc("No"); my $all = loc("Yes to all (for this module)"); my $none = loc("No to all (for this module)"); my $reply = $term->get_reply( prompt => loc("Should I install this module?"), choices => [ $yes, $no, $all, $none ], default => $yes, ); ### if 'all' or 'none', save this, so we can apply it to ### other prereqs in this chain. $Shell->settings->{'install_all_prereqs'} = $reply eq $all ? 1 : $reply eq $none ? 0 : undef; ### if 'yes' or 'all', the user wants it installed return $reply eq $all ? 1 : $reply eq $yes ? 1 : 0; } sub __ask_about_send_test_report { my($mod, $grade) = @_; return 1 unless $grade eq GRADE_FAIL; my $term = $Shell->term; $Shell->__print( "\n" ); $Shell->__print( loc("Test report prepared for module '%1'.\n Would you like to ". "send it? (You can edit it if you like)", $mod->module ) ); $Shell->__print( "\n\n" ); my $bool = $term->ask_yn( prompt => loc("Would you like to send the test report?"), default => 'n' ); return $bool; } sub __ask_about_edit_test_report { my($mod, $grade) = @_; return 0 unless $grade eq GRADE_FAIL; my $term = $Shell->term; $Shell->__print( "\n" ); $Shell->__print( loc("Test report prepared for module '%1'. You can edit this ". "report if you would like", $mod->module ) ); $Shell->__print("\n\n"); my $bool = $term->ask_yn( prompt => loc("Would you like to edit the test report?"), default => 'y' ); return $bool; } sub __ask_about_test_failure { my $mod = shift; my $captured = shift || ''; my $term = $Shell->term; $Shell->__print( "\n" ); $Shell->__print( loc( "The tests for '%1' failed. Would you like me to proceed ". "anyway or should we abort?", $mod->module ) ); $Shell->__print( "\n\n" ); my $bool = $term->ask_yn( prompt => loc("Proceed anyway?"), default => 'n', ); return $bool; } sub _details { my $self = shift; my $cb = $self->backend; my $conf = $cb->configure_object; my %hash = @_; my $args; my $mods; my $opts; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { modules => { required => 1, store => \$mods }, options => { default => { }, store => \$opts }, }; $args = check( $tmpl, \%hash ) or return; } ### every module has about 10 lines of details ### maybe more later with Module::CPANTS etc $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount; my $format = "%-24s %-45s\n"; my $cformat = "%-24s %-45s %-10s\n"; for my $mod (@$mods) { my $href = $mod->details( %$opts ); my @list = sort { $a->module cmp $b->module } $mod->contains; unless( $href ) { $self->__print( loc("No details for %1 - it might be outdated.", $mod->module), "\n" ); next; } else { $self->__print( loc( "Details for '%1'\n", $mod->module ) ); for my $item ( sort keys %$href ) { $self->__printf( $format, $item, $href->{$item} ); } my $showed; for my $item ( @list ) { $self->__printf( $cformat, ($showed ? '' : 'Contains:'), $item->module, $item->version ); $showed++; } $self->__print( "\n" ); } } $self->_pager_close; $self->__print( "\n" ); return 1; } sub _print { my $self = shift; my %hash = @_; my $args; my $opts; my $file; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, input => { default => '', store => \$file }, }; $args = check( $tmpl, \%hash ) or return; } my $old; my $fh; if( $file ) { $fh = FileHandle->new( ">$file" ) or( warn loc("Could not open '%1': '%2'", $file, $!), return ); $old = select $fh; } $self->_pager_open if !$file; $self->__print( CPANPLUS::Error->stack_as_string ); $self->_pager_close; select $old if $old; $self->__print( "\n" ); return 1; } sub _set_conf { my $self = shift; my %hash = @_; my $cb = $self->backend; my $conf = $cb->configure_object; ### possible options ### XXX hard coded, not optimal :( my %types = ( reconfigure => '', save => q([user | system | boxed]), edit => '', program => q([key => val]), conf => q([key => val]), mirrors => '', selfupdate => '', # XXX add all opts here? ); my $args; my $opts; my $input; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, input => { default => '', store => \$input }, }; $args = check( $tmpl, \%hash ) or return; } my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)$/; $value =~ s/\s+$//g if $value; $type = '' unless defined $type; $type = lc $type; if( $type eq 'reconfigure' ) { my $setup = CPANPLUS::Configure::Setup->new( configure_object => $conf, term => $self->term, backend => $cb, ); return $setup->init; } elsif ( $type eq 'save' ) { my $where = { user => CONFIG_USER, system => CONFIG_SYSTEM, boxed => CONFIG_BOXED, }->{ $key } || CONFIG_USER; ### boxed is special, so let's get its value from %INC ### so we can tell it where to save ### XXX perhaps this logic should be generic for all ### types, and put in the ->save() routine my $dir; if( $where eq CONFIG_BOXED ) { my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm'; my $file_re = quotemeta($file); my $path = $INC{$file} || ''; $path =~ s/$file_re$//; $dir = $path; } my $rv = $cb->configure_object->save( $where => $dir ); $self->__print( $rv ? loc("Configuration successfully saved to %1\n (%2)\n", $where, $rv) : loc("Failed to save configuration\n" ) ); return $rv; } elsif ( $type eq 'edit' ) { my $editor = $conf->get_program('editor') or( print(loc("No editor specified")), return ); my $where = { user => CONFIG_USER, system => CONFIG_SYSTEM, }->{ $key } || CONFIG_USER; my $file = $conf->_config_pm_to_file( $where ); system($editor,$file); ### now reload it ### disable warnings for this { require Module::Loaded; Module::Loaded::mark_as_unloaded( $where ); ### reinitialize the config local $^W; $conf->init; } return 1; } elsif ( $type eq 'mirrors' ) { $self->__print( loc("Readonly list of mirrors (in order of preference):\n\n" ) ); my $i; for my $host ( @{$conf->get_conf('hosts')} ) { my $uri = $cb->_host_to_uri( %$host ); $i++; $self->__print( "\t[$i] $uri\n" ); } $self->__print( loc("\nTo edit this list, please type: '%1'\n", 's edit') ); } elsif ( $type eq 'selfupdate' ) { my %valid = map { $_ => $_ } $cb->selfupdate_object->list_categories; unless( $valid{$key} ) { $self->__print( loc( "To update your current CPANPLUS installation, ". "choose one of the these options:\n%1", ( join $/, map { sprintf "\ts selfupdate %-17s " . "[--latest=0] [--dryrun]", $_ } sort keys %valid ) ) ); } else { my %update_args = ( update => $key, latest => 1, %$opts ); my %list = $cb->selfupdate_object ->list_modules_to_update( %update_args ); $self->__print(loc("The following updates will take place:"),$/.$/); for my $feature ( sort keys %list ) { my $aref = $list{$feature}; ### is it a 'feature' or a built in? $self->__print( $valid{$feature} ? " " . ucfirst($feature) . ":\n" : " Modules for '$feature' support:\n" ); ### show what modules would be installed $self->__print( scalar @$aref ? map { sprintf " %-42s %-6s -> %-6s \n", $_->name, $_->installed_version, $_->version } @$aref : " No upgrades required\n" ); $self->__print( $/ ); } unless( $opts->{'dryrun'} ) { $self->__print( loc("Updating your CPANPLUS installation\n") ); $cb->selfupdate_object->selfupdate( %update_args ); } } } else { if ( $type eq 'program' or $type eq 'conf' ) { my $format = { conf => '%-25s %s', program => '%-12s %s', }->{ $type }; unless( $key ) { my @list = grep { $_ ne 'hosts' } $conf->options( type => $type ); my $method = 'get_' . $type; local $Data::Dumper::Indent = 0; for my $name ( @list ) { my $val = $conf->$method($name) || ''; ($val) = ref($val) ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) : "'$val'"; $self->__printf( " $format\n", $name, $val ); } } elsif ( $key eq 'hosts' or $key eq 'lib' ) { $self->__print( loc( "Setting %1 is not trivial.\n" . "It is suggested you use '%2' and edit the " . "configuration file manually", $key, 's edit') ); } else { my $method = 'set_' . $type; $conf->$method( $key => defined $value ? $value : '' ) and $self->__print( loc("Key '%1' was set to '%2'", $key, defined $value ? $value : 'EMPTY STRING') ); } } else { $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) ); $self->__print( $/ ); $self->__print( loc("Try one of the following:") ); $self->__print( $/, join $/, map { sprintf "\t%-11s %s", $_, $types{$_} } sort keys %types ); } } $self->__print( "\n" ); return 1; } sub _uptodate { my $self = shift; my %hash = @_; my $cb = $self->backend; my $conf = $cb->configure_object; my $opts; my $mods; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, modules => { required => 1, store => \$mods }, }; check( $tmpl, \%hash ) or return; } ### long listing? short is default ### my $long = $opts->{'long'} ? 1 : 0; my @list = scalar @$mods ? @$mods : @{$cb->_all_installed}; my @rv; my %seen; for my $mod (@list) { ### skip this mod if it's up to date ### next if $mod->is_uptodate; ### skip this mod if it's core ### next if $mod->package_is_perl_core; if( $long or !$seen{$mod->package}++ ) { push @rv, $mod; } } @rv = sort { $a->module cmp $b->module } @rv; $self->cache([undef,@rv]); $self->_pager_open if scalar @rv >= $self->_term_rowcount; my $format = "%5s %12s %12s %-36s %-10s\n"; my $i = 1; for my $mod ( @rv ) { $self->__printf( $format, $i, $self->_format_version($mod->installed_version) || 'Unparsable', $self->_format_version( $mod->version ), $mod->module, $mod->author->cpanid ); $i++; } $self->_pager_close; return 1; } sub _autobundle { my $self = shift; my %hash = @_; my $cb = $self->backend; my $conf = $cb->configure_object; my $opts; my $input; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, input => { default => '', store => \$input }, }; check( $tmpl, \%hash ) or return; } $opts->{'path'} = $input if $input; my $where = $cb->autobundle( %$opts ); $self->__print( $where ? loc("Wrote autobundle to '%1'", $where) : loc("Could not create autobundle" ) ); $self->__print( "\n" ); return $where ? 1 : 0; } sub _uninstall { my $self = shift; my %hash = @_; my $cb = $self->backend; my $term = $self->term; my $conf = $cb->configure_object; my $opts; my $mods; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, modules => { default => [], store => \$mods }, }; check( $tmpl, \%hash ) or return; } my $force = $opts->{'force'} || $conf->get_conf('force'); unless( $force ) { my $list = join "\n", map { ' ' . $_->module } @$mods; $self->__print( loc(" This will uninstall the following modules: %1 Note that if you installed them via a package manager, you probably should use the same package manager to uninstall them ", $list) ); return unless $term->ask_yn( prompt => loc("Are you sure you want to continue?"), default => 'n', ); } ### first loop over all the modules to uninstall them ### for my $mod (@$mods) { $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" ); $mod->uninstall( %$opts ); } my $flag; ### then report whether all this went ok or not ### for my $mod (@$mods) { if( $mod->status->uninstall ) { $self->__print( loc("Module '%1' %tense(uninstall,past) successfully\n", $mod->module ) ); } else { $flag++; $self->__print( loc("Error %tense(uninstall,present) '%1'\n", $mod->module) ); } } if( !$flag ) { $self->__print( loc("All modules %tense(uninstall,past) successfully"), "\n" ); } else { $self->__print( loc("Problem %tense(uninstall,present) one or more modules" ), "\n" ); $self->__print( loc("*** You can view the complete error buffer by pressing '%1'". "***\n", 'p') ) unless $conf->get_conf('verbose'); } $self->__print( "\n" ); return !$flag; } sub _reports { my $self = shift; my %hash = @_; my $cb = $self->backend; my $term = $self->term; my $conf = $cb->configure_object; my $opts; my $mods; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, modules => { default => '', store => \$mods }, }; check( $tmpl, \%hash ) or return; } ### XXX might need to be conditional ### $self->_pager_open; for my $mod (@$mods) { my @list = $mod->fetch_report( %$opts ) or( print(loc("No reports available for this distribution.")), next ); @list = reverse map { $_->[0] } sort { $a->[1] cmp $b->[1] } map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list; ### XXX this may need to be sorted better somehow ### my $url; my $format = "%8s %s %s\n"; my %seen; for my $href (@list ) { $self->__print( "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n" ) unless $seen{ $href->{'dist'} }++; $self->__printf( $format, $href->{'grade'}, $href->{'platform'}, ($href->{'details'} ? '(*)' : '') ); $url ||= $href->{'details'}; } $self->__print( "\n==> $url\n" ) if $url; $self->__print( "\n" ); } $self->_pager_close; return 1; } ### Load plugins { my @PluginModules; my %Dispatch = ( showtip => [ __PACKAGE__, '_show_random_tip'], plugins => [ __PACKAGE__, '_list_plugins' ], '?' => [ __PACKAGE__, '_plugins_usage' ], ); sub plugin_modules { return @PluginModules } sub plugin_table { return %Dispatch } my $init_done; sub _plugins_init { ### only initialize once return if $init_done++; ### find all plugins first if( check_install( module => 'Module::Pluggable', version => '2.4') ) { require Module::Pluggable; my $only_re = __PACKAGE__ . '::Plugins::\w+$'; Module::Pluggable->import( sub_name => '_plugins', search_path => __PACKAGE__, only => qr/$only_re/, #except => [ INSTALLER_MM, INSTALLER_SAMPLE ] ); push @PluginModules, __PACKAGE__->_plugins; } ### now try to load them for my $p ( __PACKAGE__->plugin_modules ) { my %map = eval { load $p; $p->import; $p->plugins }; error(loc("Could not load plugin '$p': $@")), next if $@; ### register each plugin while( my($name, $func) = each %map ) { if( not length $name or not length $func ) { error(loc("Empty plugin name or dispatch function detected")); next; } if( exists( $Dispatch{$name} ) ) { error(loc("'%1' is already registered by '%2'", $name, $Dispatch{$name}->[0])); next; } ### register name, package and function $Dispatch{$name} = [ $p, $func ]; } } } ### dispatch a plugin command to its function sub _meta { my $self = shift; my %hash = @_; my $cb = $self->backend; my $term = $self->term; my $conf = $cb->configure_object; my $opts; my $input; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { options => { default => { }, store => \$opts }, input => { default => '', store => \$input }, }; check( $tmpl, \%hash ) or return; } $input =~ s/\s*(\S+)\s*//; my $cmd = $1; ### look up the command, or go to the default my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ]; my($pkg,$func) = @$aref; my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) }; error( $@ ) if $@; ### return $rv instead, so input loop can be terminated? return 1; } sub _plugin_default { error(loc("No such plugin command")) } } ### plugin commands { my $help_format = " /%-21s # %s\n"; sub _list_plugins { my $self = shift; $self->__print( loc("Available plugins:\n") ); $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) ); $self->__print( $/ ); my %table = __PACKAGE__->plugin_table; for my $name( sort keys %table ) { my $pkg = $table{$name}->[0]; my $this = __PACKAGE__; my $who = $pkg eq $this ? "Standard Plugin" : do { my $v = $self->_format_version($pkg->VERSION) || ''; $pkg =~ s/^$this/../; sprintf "Provided by: %-30s %-10s", $pkg, $v; }; $self->__printf( $help_format, $name, $who ); } $self->__print( $/.$/ ); $self->__print( " Write your own plugins? Read the documentation of:\n" . " CPANPLUS::Shell::Default::Plugins::HOWTO\n" ); $self->__print( $/ ); } sub _list_plugins_help { return sprintf $help_format, 'plugins', loc("lists available plugins"); } ### registered as a plugin too sub _show_random_tip_help { return sprintf $help_format, 'showtip', loc("show usage tips" ); } sub _plugins_usage { my $self = shift; my $shell = shift; my $cb = shift; my $cmd = shift; my $input = shift; my %table = $self->plugin_table; my @list = length $input ? split /\s+/, $input : sort keys %table; for my $name( @list ) { ### no such plugin? skip error(loc("No such plugin '$name'")), next unless $table{$name}; my $pkg = $table{$name}->[0]; my $func = $table{$name}->[1] . '_help'; if ( my $sub = $pkg->can( $func ) ) { eval { $self->__print( $sub->() ) }; error( $@ ) if $@; } else { $self->__print(" No usage for '$name' -- try perldoc $pkg"); } $self->__print( $/ ); } $self->__print( $/.$/ ); } sub _plugins_usage_help { return sprintf $help_format, '? [NAME ...]', loc("show usage for plugins"); } } ### send a command to a remote host, retrieve the answer; sub __send_remote_command { my $self = shift; my $cmd = shift; my $remote = $self->remote or return; my $user = $remote->{'username'}; my $pass = $remote->{'password'}; my $conn = $remote->{'connection'}; my $end = "\015\012"; my $answer; my $send = join "\0", $user, $pass, $cmd; print $conn $send . $end; ### XXX why doesn't something like this just work? #1 while recv($conn, $answer, 1024, 0); while(1) { my $buff; $conn->recv( $buff, 1024, 0 ); $answer .= $buff; last if $buff =~ /$end$/; } my($status,$buffer) = split "\0", $answer; return ($status, $buffer); } sub _read_configuration_from_rc { my $self = shift; my $rc_file = shift; my $href; if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) { $Config::Auto::DisablePerl = 1; eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) }; $self->__print( loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) ) if $@; } return $href || {}; } { my @tips = ( loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ), loc( "You can install modules by URL using '%1'", 'i URL' ), loc( "You can turn off these tips using '%1'", 's conf show_startup_tip 0' ), loc( "You can use wildcards like '%1' and '%2' on search results", '*', '2..5' ) , loc( "You can use plugins. Type '%1' to list available plugins", '/plugins' ), loc( "You can show all your out of date modules using '%1'", 'o' ), loc( "Many operations take options, like '%1', '%2' or '%3'", '--verbose', '--force', '--skiptest' ), loc( "The documentation in %1 and %2 is very useful", "CPANPLUS::Module", "CPANPLUS::Backend" ), loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ), loc( "You can run an interactive setup using '%1'", 's reconfigure' ), loc( "You can add custom sources to your index. See '%1' for details", '/cs --help' ), loc( "CPANPLUS now has an experimental SQLite backend. You can enable ". "it via: '%1'. Update dependencies via '%2'", 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save', 's selfupdate enabled_features ' ), ); sub _show_random_tip { my $self = shift; $self->__print( $/, "Did you know...\n ", $tips[ int rand scalar @tips ], $/ ); return 1; } } sub _reload_shell { { exec ($^X, '-MCPANPLUS', '-e', 'shell') }; print STDERR "couldn't exec foo: $!"; } 1; __END__ =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: __END__ TODO: e => "_expand_inc", # scratch it, imho -- not used enough ### free letters: g j k n y ### CPANPLUS-0.9144/lib/CPANPLUS/Shell/Default/0000755000175000017500000000000012251422462017012 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Shell/Default/Plugins/0000755000175000017500000000000012251422462020433 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Shell/Default/Plugins/Source.pm0000644000175000017500000000512612251421370022232 0ustar bingosbingospackage CPANPLUS::Shell::Default::Plugins::Source; use strict; use CPANPLUS::Error qw[error msg]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; =head1 NAME CPANPLUS::Shell::Default::Plugins::Source - read in CPANPLUS commands =head1 SYNOPSIS CPAN Terminal> /source /tmp/list_of_commands /tmp/more_commands =head1 DESCRIPTION This is a C plugin that works just like your unix shells source(1) command; it reads in a file that has commands in it to execute, and then executes them. A sample file might look like this: # first, update all the source files x --update_source # find all of my modules that are on the CPAN # test them, and store the error log a ^KANE$' t * p /home/kane/cpan-autotest/log # and inform us we're good to go ! print "Autotest complete, log stored; please enter your commands!" Note how empty lines, and lines starting with a '#' are being skipped in the execution. =cut sub plugins { return ( source => 'source' ) } sub source { my $class = shift; my $shell = shift; my $cb = shift; my $cmd = shift; my $input = shift || ''; my $opts = shift || {}; my $verbose = $cb->configure_object->get_conf('verbose'); for my $file ( split /\s+/, $input ) { my $fh = FileHandle->new("$file") or( error(loc("Could not open file '%1': %2", $file, $!)), next ); while( my $line = <$fh> ) { chomp $line; next if $line !~ /\S+/; # skip empty/whitespace only lines next if $line =~ /^#/; # skip comments msg(loc("Dispatching '%1'", $line), $verbose); return 1 if $shell->dispatch_on_input( input => $line ); } } } sub source_help { return loc(' /source FILE [FILE ..] '. '# read in commands from the specified file' ), } 1; =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm0000644000175000017500000001333612251421370023427 0ustar bingosbingospackage CPANPLUS::Shell::Default::Plugins::CustomSource; use strict; use CPANPLUS::Error qw[error msg]; use CPANPLUS::Internals::Constants; use Data::Dumper; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; =head1 NAME CPANPLUS::Shell::Default::Plugins::CustomSource - add custom sources to CPANPLUS =head1 SYNOPSIS ### elaborate help text CPAN Terminal> /? cs ### add a new custom source CPAN Terminal> /cs --add file:///path/to/releases ### list all your custom sources by CPAN Terminal> /cs --list ### display the contents of a custom source by URI or ID CPAN Terminal> /cs --contents file:///path/to/releases CPAN Terminal> /cs --contents 1 ### Update a custom source by URI or ID CPAN Terminal> /cs --update file:///path/to/releases CPAN Terminal> /cs --update 1 ### Remove a custom source by URI or ID CPAN Terminal> /cs --remove file:///path/to/releases CPAN Terminal> /cs --remove 1 ### Write an index file for a custom source, to share ### with 3rd parties or remote users CPAN Terminal> /cs --write file:///path/to/releases ### Make sure to save your sources when adding/removing ### sources, so your changes are reflected in the cache: CPAN Terminal> x =head1 DESCRIPTION This is a C plugin that can add custom sources to your CPANPLUS installation. This is a wrapper around the C code as outlined in L. This allows you to extend your index of available modules beyond what's available on C with your own local distributions, or ones offered by third parties. =cut sub plugins { return ( cs => 'custom_source' ) } my $Cb; my $Shell; my @Index = (); sub _uri_from_cache { my $self = shift; my $input = shift or return; ### you gave us a search number my $uri = $input =~ /^\d+$/ ? $Index[ $input - 1 ] # remember, off by 1! : $input; my %files = reverse $Cb->list_custom_sources; ### it's an URI we know ### VMS can lower case all files, so make sure we check that too my $local = $files{ $uri }; $local = $files{ lc $uri } if !$local && ON_VMS; if( $local ) { return wantarray ? ($uri, $local) : $uri; } ### couldn't resolve the input error(loc("Unknown URI/index: '%1'", $input)); return; } sub _list_custom_sources { my $class = shift; my %files = $Cb->list_custom_sources; $Shell->__print( loc("Your remote sources:"), $/ ) if keys %files; my $i = 0; while(my($local,$remote) = each %files) { $Shell->__printf( " [%2d] %s\n", ++$i, $remote ); ### remember, off by 1! push @Index, $remote; } $Shell->__print( $/ ); } sub _list_contents { my $class = shift; my $input = shift; my ($uri,$local) = $class->_uri_from_cache( $input ); unless( $uri ) { error(loc("--contents needs URI parameter")); return; } my $fh = OPEN_FILE->( $local ) or return; $Shell->__printf( " %s", $_ ) for sort <$fh>; $Shell->__print( $/ ); } sub custom_source { my $class = shift; my $shell = shift; $Shell = $shell; # available to all methods now my $cb = shift; $Cb = $cb; # available to all methods now my $cmd = shift; my $input = shift || ''; my $opts = shift || {}; ### show a list if( $opts->{'list'} ) { $class->_list_custom_sources; } elsif ( $opts->{'contents'} ) { $class->_list_contents( $input ); } elsif ( $opts->{'add'} ) { unless( $input ) { error(loc("--add needs URI parameter")); return; } $cb->add_custom_source( uri => $input ) and $shell->__print(loc("Added remote source '%1'", $input), $/); $Shell->__print($/, loc("Remote source contains:"), $/, $/); $class->_list_contents( $input ); } elsif ( $opts->{'remove'} ) { my($uri,$local) = $class->_uri_from_cache( $input ); unless( $uri ) { error(loc("--remove needs URI parameter")); return; } 1 while unlink $local; $shell->__print( loc("Removed remote source '%1'", $uri), $/ ); } elsif ( $opts->{'update'} ) { ### did we get input? if so, it's a remote part my $uri = $class->_uri_from_cache( $input ); $cb->update_custom_source( $uri ? ( remote => $uri ) : () ) and do { $shell->__print( loc("Updated remote sources"), $/ ) }; } elsif ( $opts->{'write'} ) { $cb->write_custom_source_index( path => $input ) and $shell->__print( loc("Wrote remote source index for '%1'", $input), $/); } else { error(loc("Unrecognized command, see '%1' for help", '/? cs')); } return; } sub custom_source_help { return loc( $/ . ' # Plugin to manage custom sources from the default shell' . $/ . " # See the 'CUSTOM MODULE SOURCES' section in the " . $/ . ' # CPANPLUS::Backend documentation for details.' . $/ . ' /cs --list # list available sources' . $/ . ' /cs --add URI # add source' . $/ . ' /cs --remove URI | INDEX # remove source' . $/ . ' /cs --contents URI | INDEX # show packages from source'. $/ . ' /cs --update [URI | INDEX] # update source index' . $/ . ' /cs --write PATH # write source index' . $/ ); } 1; CPANPLUS-0.9144/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod0000644000175000017500000000741212207704351022044 0ustar bingosbingos=head1 NAME CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your own plugins =head1 SYNOPSIS package CPANPLUS::Shell::Default::Plugins::MyPlugin; ### return command => method mapping sub plugins { ( myplugin1 => 'mp1', myplugin2 => 'mp2' ) } ### method called when the command '/myplugin1' is issued sub mp1 { .... } ### method called when the command '/? myplugin1' is issued sub mp1_help { return "Help Text" } =head1 DESCRIPTION This pod text explains how to write your own plugins for C. =head1 HOWTO =head2 Registering Plugin Modules Plugins are detected by using C. Every module in the C namespace is considered a plugin, and is attempted to be loaded. Therefor, any plugin must be declared in that namespace, in a corresponding C<.pm> file. =head2 Registering Plugin Commands To register any plugin commands, a list of key value pairs must be returned by a C method in your package. The keys are the commands you wish to register, the values are the methods in the plugin package you wish to have called when the command is issued. For example, a simple 'Hello, World!' plugin: package CPANPLUS::Shell::Default::Plugins::HW; sub plugins { return ( helloworld => 'hw' ) }; sub hw { print "Hello, world!\n" } When the user in the default shell now issues the C command, this command will be dispatched to the plugin, and its C method will be called =head2 Registering Plugin Help To provide usage information for your plugin, the user of the default shell can type C. In that case, the function C will be called in your plugin package. For example, extending the above example, when a user calls C, the function C will be called, which might look like this: sub hw_help { " /helloworld # prints "Hello, world!\n" } If you don't provide a corresponding _help function to your commands, the default shell will handle it gracefully, but the user will be stuck without usage information on your commands, so it's considered undesirable to omit the help functions. =head2 Arguments to Plugin Commands Any plugin function will receive the following arguments when called, which are all positional: =over 4 =item Classname -- The name of your plugin class =item Shell -- The CPANPLUS::Shell::Default object =item Backend -- The CPANPLUS::Backend object =item Command -- The command issued by the user =item Input -- The input string from the user =item Options -- A hashref of options provided by the user =back For example, the following command: /helloworld bob --nofoo --bar=2 joe Would yield the following arguments: sub hw { my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW my $shell = shift; # CPANPLUS::Shell::Default object my $cb = shift; # CPANPLUS::Backend object my $cmd = shift; # 'helloworld' my $input = shift; # 'bob joe' my $opts = shift; # { foo => 0, bar => 2 } .... } =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm0000644000175000017500000001126212251421717022230 0ustar bingosbingospackage CPANPLUS::Shell::Default::Plugins::Remote; use strict; use Module::Load; use Params::Check qw[check]; use CPANPLUS::Error qw[error msg]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; =head1 NAME CPANPLUS::Shell::Default::Plugins::Remote - connect to a remote CPANPLUS =head1 SYNOPSIS CPAN Terminal> /connect localhost 1337 --user=foo --pass=bar ... CPAN Terminal@localhost> /disconnect =head1 DESCRIPTION This is a C plugin that allows you to connect to a machine running an instance of C, allowing remote usage of the C. A sample session, updating all modules on a remote machine, might look like this: CPAN Terminal> /connect --user=my_user --pass=secret localhost 1337 Connection accepted Successfully connected to 'localhost' on port '11337' Note that no output will appear until a command has completed -- this may take a while CPAN Terminal@localhost> o; i * [....] CPAN Terminal@localhost> /disconnect CPAN Terminal> =cut ### store the original prompt here, so we can restore it on disconnect my $Saved_Prompt; sub plugins { ( connect => 'connect', disconnect => 'disconnect' ) } sub connect { my $class = shift; my $shell = shift; my $cb = shift; my $cmd = shift; my $input = shift || ''; my $opts = shift || {}; my $conf = $cb->configure_object; my $user; my $pass; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { user => { default => 'cpanpd', store => \$user }, pass => { required => 1, store => \$pass }, }; check( $tmpl, $opts ) or return; } my @parts = split /\s+/, $input; my $host = shift @parts || 'localhost'; my $port = shift @parts || '1337'; load IO::Socket; my $remote = IO::Socket::INET->new( Proto => "tcp", PeerAddr => $host, PeerPort => $port, ) or ( error( loc( "Cannot connect to port '%1' ". "on host '%2'", $port, $host ) ), return ); my $con = { connection => $remote, username => $user, password => $pass, }; ### store the connection $shell->remote( $con ); my($status,$buffer) = $shell->__send_remote_command( "VERSION=$CPANPLUS::Shell::Default::VERSION"); if( $status ) { print "\n$buffer\n\n"; print loc( "Successfully connected to '%1' on port '%2'", $host, $port ); print "\n\n"; print loc( "Note that no output will appear until a command ". "has completed\n-- this may take a while" ); print "\n\n"; ### save the original prompt $Saved_Prompt = $shell->prompt; $shell->prompt( $shell->brand .'@'. $host .':'. $port .'> ' ); } else { print "\n$buffer\n\n"; print loc( "Failed to connect to '%1' on port '%2'", $host, $port ); print "\n\n"; $shell->remote( undef ); } } sub disconnect { my $class = shift; my $shell = shift; print "\n", ( $shell->remote ? loc( "Disconnecting from remote host" ) : loc( "Not connected to remote host" ) ), "\n\n"; $shell->remote( undef ); $shell->prompt( $Saved_Prompt ); } sub connect_help { return loc( " /connect [HOST PORT] # Connect to the remote machine,\n" . " # defaults taken from your config\n" . " --user=USER # Optional username\n" . " --pass=PASS # Optional password" ); } sub disconnect_help { return loc( " /disconnect # Disconnect from the remote server" ); } 1; =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Module/0000755000175000017500000000000012251422462015604 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Module/Checksums.pm0000644000175000017500000001561712251421370020076 0ustar bingosbingospackage CPANPLUS::Module::Checksums; use strict; use vars qw[@ISA $VERSION]; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use FileHandle; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; $Params::Check::VERBOSE = 1; @ISA = qw[ CPANPLUS::Module::Signature ]; $VERSION = "0.9144"; =head1 NAME CPANPLUS::Module::Checksums - checking the checksum of a distribution =head1 SYNOPSIS $file = $modobj->checksums; $bool = $mobobj->_validate_checksum; =head1 DESCRIPTION This is a class that provides functions for checking the checksum of a distribution. Should not be loaded directly, but used via the interface provided via C. =head1 METHODS =head2 $mod->checksums Fetches the checksums file for this module object. For the options it can take, see C. Returns the location of the checksums file on success and false on error. The location of the checksums file is also stored as $mod->status->checksums =cut sub checksums { my $mod = shift or return; my $file = $mod->_get_checksums_file( @_ ); return $mod->status->checksums( $file ) if $file; return; } ### checks if the package checksum matches the one ### from the checksums file sub _validate_checksum { my $self = shift; #must be isa CPANPLUS::Module my $conf = $self->parent->configure_object; my %hash = @_; my $verbose; my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; check( $tmpl, \%hash ) or return; ### if we can't check it, we must assume it's ok ### return $self->status->checksum_ok(1) unless can_load( modules => { 'Digest::SHA' => '0.0' } ); #class CPANPLUS::Module::Status is runtime-generated my $file = $self->_get_checksums_file( verbose => $verbose ) or ( error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return ); $self->_check_signature_for_checksum_file( file => $file ) or ( error(loc(q[Could not verify '%1' file], CHECKSUMS)), return ); #for whole CHECKSUMS file my $href = $self->_parse_checksums_file( file => $file ) or ( error(loc(q[Could not parse '%1' file], CHECKSUMS)), return ); my $size = $href->{ $self->package }->{'size'}; ### the checksums file tells us the size of the archive ### but the downloaded file is of different size if( defined $size ) { if( not (-s $self->status->fetch == $size) ) { error(loc( "Archive size does not match for '%1': " . "size is '%2' but should be '%3'", $self->package, -s $self->status->fetch, $size)); return $self->status->checksum_ok(0); } } else { msg(loc("Archive size is not known for '%1'",$self->package),$verbose); } my $sha = $href->{ $self->package }->{'sha256'}; unless( defined $sha ) { msg(loc("No 'sha256' checksum known for '%1'",$self->package),$verbose); return $self->status->checksum_ok(1); } $self->status->checksum_value($sha); my $fh = FileHandle->new( $self->status->fetch ) or return; binmode $fh; my $ctx = Digest::SHA->new(256); $ctx->addfile( $fh ); my $hexdigest = $ctx->hexdigest; my $flag = $hexdigest eq $sha; $flag ? msg(loc("Checksum matches for '%1'", $self->package),$verbose) : error(loc("Checksum does not match for '%1': " . "SHA256 is '%2' but should be '%3'", $self->package, $hexdigest, $sha),$verbose); return $self->status->checksum_ok(1) if $flag; return $self->status->checksum_ok(0); } ### fetches the module objects checksum file ### sub _get_checksums_file { my $self = shift; my %hash = @_; my $clone = $self->clone; $clone->package( CHECKSUMS ); # If the user specified a fetchdir, then every CHECKSUMS file will always # be stored there, not in an author-specific subdir. Thus, in this case, # we need to always re-fetch the CHECKSUMS file and hence need to set the # TTL to something small. my $have_fetchdir = $self->parent->configure_object->get_conf('fetchdir') ne ''; my $ttl = $have_fetchdir ? 0.001 : 3600; my $file = $clone->fetch( ttl => $ttl, %hash ) or return; return $file; } sub _parse_checksums_file { my $self = shift; my %hash = @_; my $file; my $tmpl = { file => { required => 1, allow => FILE_READABLE, store => \$file }, }; my $args = check( $tmpl, \%hash ); my $fh = OPEN_FILE->( $file ) or return; ### loop over the header, there might be a pgp signature ### my $signed; while (local $_ = <$fh>) { last if /^\$cksum = \{\s*$/; # skip till this line my $header = PGP_HEADER; # but be tolerant of whitespace $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks } ### read the filehandle, parse it rather than eval it, even though it ### *should* be valid perl code my $dist; my $cksum = {}; while (local $_ = <$fh>) { if (/^\s*'([^']+)' => \{\s*$/) { $dist = $1; } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) { $cksum->{$dist}{$1} = $2; } elsif (/^\s*}[,;]?\s*$/) { undef $dist; } elsif (/^__END__\s*$/) { last; } else { error( loc("Malformed %1 line: %2", CHECKSUMS, $_) ); } } return $cksum; } sub _check_signature_for_checksum_file { my $self = shift; my $conf = $self->parent->configure_object; my %hash = @_; ### you don't want to check signatures, ### so let's just return true; return 1 unless $conf->get_conf('signature'); my($force,$file,$verbose); my $tmpl = { file => { required => 1, allow => FILE_READABLE, store => \$file }, force => { default => $conf->get_conf('force'), store => \$force }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; my $args = check( $tmpl, \%hash ) or return; my $fh = OPEN_FILE->($file) or return; my $signed; while (local $_ = <$fh>) { my $header = PGP_HEADER; $signed = 1 if /^$header$/; } if ( !$signed ) { msg(loc("No signature found in %1 file '%2'", CHECKSUMS, $file), $verbose); return 1 unless $force; error( loc( "%1 file '%2' is not signed -- aborting", CHECKSUMS, $file ) ); return; } if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) { # local $Module::Signature::SIGNATURE = $file; # ... check signatures ... } return 1; } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: 1; CPANPLUS-0.9144/lib/CPANPLUS/Module/Author/0000755000175000017500000000000012251422462017046 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Module/Author/Fake.pm0000644000175000017500000000335112251421370020251 0ustar bingosbingospackage CPANPLUS::Module::Author::Fake; use CPANPLUS::Module::Author; use CPANPLUS::Internals; use CPANPLUS::Error; use strict; use vars qw[@ISA $VERSION]; use Params::Check qw[check]; $VERSION = "0.9144"; @ISA = qw[CPANPLUS::Module::Author]; $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Module::Author::Fake - dummy author object for CPANPLUS =head1 SYNOPSIS my $auth = CPANPLUS::Module::Author::Fake->new( author => 'Foo Bar', email => 'luser@foo.com', cpanid => 'FOO', _id => $cpan->id, ); =head1 DESCRIPTION A class for creating fake author objects, for shortcut use internally by CPANPLUS. Inherits from C. =head1 METHODS =head2 new( _id => DIGIT ) Creates a dummy author object. It can take the same options as C<< CPANPLUS::Module::Author->new >>, but will fill in default ones if none are provided. Only the _id key is required. =cut sub new { my $class = shift; my %hash = @_; my $tmpl = { author => { default => 'CPANPLUS Internals' }, email => { default => 'cpanplus-info@lists.sf.net' }, cpanid => { default => 'CPANPLUS' }, _id => { default => CPANPLUS::Internals->_last_id }, }; my $args = check( $tmpl, \%hash ) or return; my $obj = CPANPLUS::Module::Author->new( %$args ) or return; unless( $obj->_id ) { error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); return; } ### rebless object ### return bless $obj, $class; } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Module/Author.pm0000644000175000017500000001321112251421370017377 0ustar bingosbingospackage CPANPLUS::Module::Author; use strict; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use Params::Check qw[check]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; local $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Module::Author - CPAN author object for CPANPLUS =head1 SYNOPSIS my $author = CPANPLUS::Module::Author->new( author => 'Jack Ashton', cpanid => 'JACKASH', _id => INTERNALS_OBJECT_ID, ); $author->cpanid; $author->author; $author->email; @dists = $author->distributions; @mods = $author->modules; @accessors = CPANPLUS::Module::Author->accessors; =head1 DESCRIPTION C creates objects from the information in the source files. These can then be used to query on. These objects should only be created internally. For C objects, there's the C class. =head1 ACCESSORS An objects of this class has the following accessors: =over 4 =item author Name of the author. =item cpanid The CPAN id of the author. =item email The email address of the author, which defaults to '' if not provided. =item parent The C that spawned this module object. =back =cut my $tmpl = { author => { required => 1 }, # full name of the author cpanid => { required => 1 }, # cpan id email => { default => '' }, # email address of the author _id => { required => 1 }, # id of the Internals object that spawned us }; ### autogenerate accessors ### for my $key ( keys %$tmpl ) { no strict 'refs'; *{__PACKAGE__."::$key"} = sub { my $self = shift; $self->{$key} = $_[0] if @_; return $self->{$key}; } } sub parent { my $self = shift; my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); return $obj; } =pod =head1 METHODS =head2 $auth = CPANPLUS::Module::Author->new( author => AUTHOR_NAME, cpanid => CPAN_ID, _id => INTERNALS_ID [, email => AUTHOR_EMAIL] ) This method returns a C object, based on the given parameters. Returns false on failure. =cut sub new { my $class = shift; my %hash = @_; ### don't check the template for sanity ### -- we know it's good and saves a lot of performance local $Params::Check::SANITY_CHECK_TEMPLATE = 0; my $object = check( $tmpl, \%hash ) or return; return bless $object, $class; } =pod =head2 @mod_objs = $auth->modules() Return a list of module objects this author has released. =cut sub modules { my $self = shift; my $cb = $self->parent; my $aref = $cb->_search_module_tree( type => 'author', ### XXX, depending on backend, this is either an object ### or the cpanid string. Don't know an elegant way to ### solve this right now, so passing both allow => [$self, $self->cpanid], ); return @$aref if $aref; return; } =pod =head2 @dists = $auth->distributions() Returns a list of module objects representing all the distributions this author has released. =cut sub distributions { my $self = shift; my %hash = @_; local $Params::Check::ALLOW_UNKNOWN = 1; local $Params::Check::NO_DUPLICATES = 1; my $mod; my $tmpl = { module => { default => '', store => \$mod }, }; my $args = check( $tmpl, \%hash ) or return; ### if we didn't get a module object passed, we'll find one ourselves ### unless( $mod ) { my @list = $self->modules; if( @list ) { $mod = $list[0]; } else { error( loc( "This author has released no modules" ) ); return; } } my $file = $mod->checksums( %hash ); my $href = $mod->_parse_checksums_file( file => $file ) or return; my @rv; for my $name ( keys %$href ) { ### shortcut asap, so we avoid extra ops. On big checksums files ### the call to clone() takes up a lot of time. ### .meta files are now also in the checksums file, ### which means we have to filter out things that don't ### match our regex next if $mod->package_extension( $name ) eq META_EXT; ### used to do this wiht ->clone. However, that calls ->dslip, ### (which is wrong anyway, as we're doing a different module), ### which in turn calls ->contains, which scans the entire ### module tree using _search_module_tree, which uses P::C ### and is therefor VERY VERY slow. ### so let's do this the direct way for speed ups. my $dist = CPANPLUS::Module::Fake->new( module => do { my $m = $mod->package_name( $name ); $m =~ s/-/::/g; $m; }, version => $mod->package_version( $name ), package => $name, path => $mod->path, # same author after all author => $mod->author, # same author after all mtime => $href->{$name}->{'mtime'}, # release date ); push @rv, $dist; } return @rv; } =pod =head1 CLASS METHODS =head2 accessors () Returns a list of all accessor methods to the object =cut sub accessors { return keys %$tmpl }; 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Module/Signature.pm0000644000175000017500000000310312251421370020075 0ustar bingosbingospackage CPANPLUS::Module::Signature; use strict; use Cwd; use CPANPLUS::Error; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use vars qw[$VERSION]; $VERSION = "0.9144"; ### detached sig, not actually used afaik --kane ### #sub get_signature { # my $self = shift; # # my $clone = $self->clone; # $clone->package( $self->package . '.sig' ); # # return $clone->fetch; #} sub check_signature { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; my $verbose; my $tmpl = { verbose => {default => $conf->get_conf('verbose'), store => \$verbose}, }; check( $tmpl, \%hash ) or return; my $dir = $self->status->extract or ( error( loc( "Do not know what dir '%1' was extracted to; ". "Cannot check signature", $self->module ) ), return ); my $cwd = cwd(); unless( $cb->_chdir( dir => $dir ) ) { error(loc( "Could not chdir to '%1', cannot verify distribution '%2'", $dir, $self->module )); return; } ### check prerequisites my $flag; my $use_list = { 'Module::Signature' => '0.06' }; if( can_load( modules => $use_list, verbose => 1 ) ) { my $rv = Module::Signature::verify(); unless ($rv eq Module::Signature::SIGNATURE_OK() or $rv eq Module::Signature::SIGNATURE_MISSING() ) { $flag++; # whoops, bad sig } } $cb->_chdir( dir => $cwd ); return $flag ? 0 : 1; } 1; CPANPLUS-0.9144/lib/CPANPLUS/Module/Fake.pm0000644000175000017500000000370412251421370017011 0ustar bingosbingospackage CPANPLUS::Module::Fake; use CPANPLUS::Error; use CPANPLUS::Module; use CPANPLUS::Module::Author::Fake; use CPANPLUS::Internals; use strict; use vars qw[@ISA $VERSION]; use Params::Check qw[check]; $VERSION = "0.9144"; @ISA = qw[CPANPLUS::Module]; $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Module::Fake - fake module object for internal use =head1 SYNOPSIS my $obj = CPANPLUS::Module::Fake->new( module => 'Foo', path => 'ftp/path/to/foo', author => CPANPLUS::Module::Author::Fake->new, package => 'fake-1.1.tgz', _id => $cpan->_id, ); =head1 DESCRIPTION A class for creating fake module objects, for shortcut use internally by CPANPLUS. Inherits from C. =head1 METHODS =head2 new( module => $mod, path => $path, package => $pkg, [_id => DIGIT] ) Creates a dummy module object from the above parameters. It can take more options (same as C<< CPANPLUS::Module->new >> but the above are required. =cut sub new { my $class = shift; my %hash = @_; local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { module => { required => 1 }, path => { required => 1 }, package => { required => 1 }, _id => { default => CPANPLUS::Internals->_last_id }, author => { default => '' }, }; my $args = check( $tmpl, \%hash ) or return; $args->{author} ||= CPANPLUS::Module::Author::Fake->new( _id => $args->{_id} ); my $obj = CPANPLUS::Module->new( %$args ) or return; unless( $obj->_id ) { error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); return; } ### rebless object ### return bless $obj, $class; } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/0000755000175000017500000000000012251422462016316 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Internals/Extract.pm0000644000175000017500000001677212251421370020300 0ustar bingosbingospackage CPANPLUS::Internals::Extract; use strict; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use File::Spec (); use File::Basename (); use Archive::Extract; use IPC::Cmd qw[run]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load check_install]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; local $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Internals::Extract - internals for archive extraction =head1 SYNOPSIS ### for source files ### $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); ### for modules/packages ### $dir = $self->_extract( module => $modobj, extractdir => '/some/where' ); =head1 DESCRIPTION CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. It can do this by either a pure perl solution (preferred) with the use of C and C, or with binaries, like C and C. The flow looks like this: $cb->_extract Delegate to Archive::Extract =head1 METHODS =head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) C<_extract> will take a module object and extract it to C if provided, or the default location which is obtained from your config. The file name is obtained by looking at C<< $modobj->status->fetch >> and will be parsed to see if it's a tar or zip archive. If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> will be called. In the unlikely event the file is of neither format, an error will be thrown. C<_extract> takes the following options: =over 4 =item module A C object. This is required. =item extractdir The directory to extract the archive to. By default this looks something like: /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME =item prefer_bin A flag indicating whether you prefer a pure perl solution, ie C or C respectively, or a binary solution like C and C. =item perl The path to the perl executable to use for any perl calls. Also used to determine the build version directory for extraction. =item verbose Specifies whether to be verbose or not. Defaults to your corresponding config entry. =item force Specifies whether to force the extraction or not. Defaults to your corresponding config entry. =back All other options are passed on verbatim to C<__unzip> or C<__untar>. Returns the directory the file was extracted to on success and false on failure. =cut sub _extract { my $self = shift; my $conf = $self->configure_object; my %hash = @_; local $Params::Check::ALLOW_UNKNOWN = 1; my( $mod, $verbose, $force ); my $tmpl = { force => { default => $conf->get_conf('force'), store => \$force }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, prefer_bin => { default => $conf->get_conf('prefer_bin') }, extractdir => { default => $conf->get_conf('extractdir') }, module => { required => 1, allow => IS_MODOBJ, store => \$mod }, perl => { default => $^X }, }; my $args = check( $tmpl, \%hash ) or return; ### did we already extract it ? ### my $loc = $mod->status->extract(); if( $loc && !$force ) { msg(loc("Already extracted '%1' to '%2'. ". "Won't extract again without force", $mod->module, $loc), $verbose); return $loc; } ### did we already fetch the file? ### my $file = $mod->status->fetch(); unless( -s $file ) { error( loc( "File '%1' has zero size: cannot extract", $file ) ); return; } ### the dir to extract to ### my $to = $args->{'extractdir'} || File::Spec->catdir( $conf->get_conf('base'), $self->_perl_version( perl => $args->{'perl'} ), $conf->_get_build('moddir'), ); ### delegate to Archive::Extract ### ### set up some flags for archive::extract ### local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'}; local $Archive::Extract::DEBUG = $conf->get_conf('debug'); local $Archive::Extract::WARN = $verbose; my $ae = Archive::Extract->new( archive => $file ); unless( $ae->extract( to => $to ) ) { error( loc( "Unable to extract '%1' to '%2': %3", $file, $to, $ae->error ) ); return; } ### if ->files is not filled, we don't know what the hell was ### extracted.. try to offer a suggestion and bail :( unless ( $ae->files ) { error( loc( "'%1' was not able to determine extracted ". "files from the archive. Install '%2' and ensure ". "it works properly and try again", $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) ); return; } ### print out what files we extracted ### ### No one needs to see this, but we'll log it msg(loc("Extracted '%1'",$_),0) for @{$ae->files}; ### set them all to be +w for the owner, so we don't get permission ### denied for overwriting files that are just +r ### this is too rigorous -- just change to +w for the owner [cpan #13358] #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } # @{$ae->files}; for my $file ( @{$ae->files} ) { my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) ); $self->_mode_plus_w( file => $path ); } ### check the return value for the extracted path ### ### Make an educated guess if we didn't get an extract_path ### back ### XXX apparently some people make their own dists and they ### pack up '.' which means the leading directory is '.' ### and only the second directory is the actual module directory ### so, we'll have to check if our educated guess exists first, ### then see if the extract path works.. and if nothing works... ### well, then we really don't know. my $dir; for my $try ( File::Spec->rel2abs( ### _safe_path must be called before catdir because catdir on ### VMS currently will not handle the extra dots in the directories. File::Spec->catdir( $self->_safe_path( path => $to ) , $self->_safe_path( path => $mod->package_name .'-'. $mod->package_version ) ) ) , File::Spec->rel2abs( $ae->extract_path ), ) { ($dir = $try) && last if -d $try; } ### test if the dir exists ### unless( $dir && -d $dir ) { error(loc("Unable to determine extract dir for '%1'",$mod->module)); return; } else { msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); ### register where we extracted the files to, ### also store what files were extracted $mod->status->extract( $dir ); $mod->status->files( $ae->files ); } ### also, figure out what kind of install we're dealing with ### $mod->get_installer_type(); return $mod->status->extract(); } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/Utils/0000755000175000017500000000000012251422462017416 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Internals/Utils/Autoflush.pm0000644000175000017500000000016112251421370021721 0ustar bingosbingospackage CPANPLUS::Internals::Utils::Autoflush; use vars qw[$VERSION]; $VERSION = "0.9144"; BEGIN { $|++ }; 1; CPANPLUS-0.9144/lib/CPANPLUS/Internals/Utils.pm0000644000175000017500000004153212251421370017756 0ustar bingosbingospackage CPANPLUS::Internals::Utils; use strict; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use Cwd qw[chdir cwd]; use File::Copy; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use version; use vars qw[$VERSION]; $VERSION = "0.9144"; local $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Internals::Utils - convenience functions for CPANPLUS =head1 SYNOPSIS my $bool = $cb->_mkdir( dir => 'blah' ); my $bool = $cb->_chdir( dir => 'blah' ); my $bool = $cb->_rmdir( dir => 'blah' ); my $bool = $cb->_move( from => '/some/file', to => '/other/file' ); my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' ); my $cont = $cb->_get_file_contents( file => '/path/to/file' ); my $version = $cb->_perl_version( perl => $^X ); =head1 DESCRIPTION C holds a few convenience functions for CPANPLUS libraries. =head1 METHODS =head2 $cb->_mkdir( dir => '/some/dir' ) C<_mkdir> creates a full path to a directory. Returns true on success, false on failure. =cut sub _mkdir { my $self = shift; my %hash = @_; my $tmpl = { dir => { required => 1 }, }; my $args = check( $tmpl, \%hash ) or ( error(loc( Params::Check->last_error ) ), return ); unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { error( loc("Could not use File::Path! This module should be core!") ); return; } eval { File::Path::mkpath($args->{dir}) }; if($@) { chomp($@); error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); return; } return 1; } =pod =head2 $cb->_chdir( dir => '/some/dir' ) C<_chdir> changes directory to a dir. Returns true on success, false on failure. =cut sub _chdir { my $self = shift; my %hash = @_; my $tmpl = { dir => { required => 1, allow => DIR_EXISTS }, }; my $args = check( $tmpl, \%hash ) or return; unless( chdir $args->{dir} ) { error( loc(q[Could not chdir into '%1'], $args->{dir}) ); return; } return 1; } =pod =head2 $cb->_rmdir( dir => '/some/dir' ); Removes a directory completely, even if it is non-empty. Returns true on success, false on failure. =cut sub _rmdir { my $self = shift; my %hash = @_; my $tmpl = { dir => { required => 1, allow => IS_DIR }, }; my $args = check( $tmpl, \%hash ) or return; unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { error( loc("Could not use File::Path! This module should be core!") ); return; } eval { File::Path::rmtree($args->{dir}) }; if($@) { chomp($@); error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); return; } return 1; } =pod =head2 $cb->_perl_version ( perl => 'some/perl/binary' ); C<_perl_version> returns the version of a certain perl binary. It does this by actually running a command. Returns the perl version on success and false on failure. =cut sub _perl_version { my $self = shift; my %hash = @_; my $perl; my $tmpl = { perl => { required => 1, store => \$perl }, }; check( $tmpl, \%hash ) or return; my $perl_version; ### special perl, or the one we are running under? if( $perl eq $^X ) { ### just load the config require Config; $perl_version = $Config::Config{version}; } else { my $cmd = $perl . ' -MConfig -eprint+Config::config_vars+version'; ($perl_version) = (`$cmd` =~ /version='(.*)'/); } return $perl_version if defined $perl_version; return; } =pod =head2 $cb->_version_to_number( version => $version ); Returns a proper module version, or '0.0' if none was available. =cut sub _version_to_number { my $self = shift; my %hash = @_; my $version; my $tmpl = { version => { default => '0.0', store => \$version }, }; check( $tmpl, \%hash ) or return; $version =~ s!_!!g; # *sigh* return $version if $version =~ /^\d*(?:\.\d+)?$/; if ( my ($vers) = $version =~ /^(v?\d+(?:\.\d+(?:\.\d+)?)?)/ ) { return eval { version->parse($vers)->numify }; } return '0.0'; } =pod =head2 $cb->_whoami Returns the name of the subroutine you're currently in. =cut sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } =pod =head2 _get_file_contents( file => $file ); Returns the contents of a file =cut sub _get_file_contents { my $self = shift; my %hash = @_; my $file; my $tmpl = { file => { required => 1, store => \$file } }; check( $tmpl, \%hash ) or return; my $fh = OPEN_FILE->($file) or return; my $contents = do { local $/; <$fh> }; return $contents; } =pod =head2 $cb->_move( from => $file|$dir, to => $target ); Moves a file or directory to the target. Returns true on success, false on failure. =cut sub _move { my $self = shift; my %hash = @_; my $from; my $to; my $tmpl = { file => { required => 1, allow => [IS_FILE,IS_DIR], store => \$from }, to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; if( File::Copy::move( $from, $to ) ) { return 1; } else { error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); return; } } =pod =head2 $cb->_copy( from => $file|$dir, to => $target ); Moves a file or directory to the target. Returns true on success, false on failure. =cut sub _copy { my $self = shift; my %hash = @_; my($from,$to); my $tmpl = { file =>{ required => 1, allow => [IS_FILE,IS_DIR], store => \$from }, to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; if( File::Copy::copy( $from, $to ) ) { return 1; } else { error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); return; } } =head2 $cb->_mode_plus_w( file => '/path/to/file' ); Sets the +w bit for the file. Returns true on success, false on failure. =cut sub _mode_plus_w { my $self = shift; my %hash = @_; require File::stat; my $file; my $tmpl = { file => { required => 1, allow => IS_FILE, store => \$file }, }; check( $tmpl, \%hash ) or return; ### set the mode to +w for a file and +wx for a dir my $x = File::stat::stat( $file ); my $mask = -d $file ? 0100 : 0200; if( $x and chmod( $x->mode|$mask, $file ) ) { return 1; } else { error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); return; } } =head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); Turns a CPANPLUS::Config style C entry into an URI string. Returns the uri on success, and false on failure =cut sub _host_to_uri { my $self = shift; my %hash = @_; my($scheme, $host, $path); my $tmpl = { scheme => { required => 1, store => \$scheme }, host => { default => 'localhost', store => \$host }, path => { default => '', store => \$path }, }; check( $tmpl, \%hash ) or return; ### it's an URI, so unixify the path. ### VMS has a special method for just that $path = ON_VMS ? VMS::Filespec::unixify($path) : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); } =head2 $cb->_vcmp( VERSION, VERSION ); Normalizes the versions passed and does a '<=>' on them, returning the result. =cut sub _vcmp { my $self = shift; my ($x, $y) = @_; $x = $self->_version_to_number(version => $x); $y = $self->_version_to_number(version => $y); return $x <=> $y; } =head2 $cb->_home_dir Returns the user's homedir, or C if it could not be found =cut sub _home_dir { if ( can_load( modules => { 'File::HomeDir' => 0.0 } ) ) { if ( defined $ENV{APPDATA} && length $ENV{APPDATA} && !ON_WIN32 ) { msg("'APPDATA' env var is set and not on MSWin32, " . "please use 'PERL5_CPANPLUS_HOME' instead to change .cpanplus location", 1 ); } return File::HomeDir->my_home if -d File::HomeDir->my_home; } my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); for my $env ( @os_home_envs ) { next unless exists $ENV{ $env }; next unless defined $ENV{ $env } && length $ENV{ $env }; return $ENV{ $env } if -d $ENV{ $env }; } return cwd(); } =head2 $path = $cb->_safe_path( path => $path ); Returns a path that's safe to us on Win32 and VMS. Only cleans up the path on Win32 if the path exists. On VMS, it encodes dots to _ using C =cut sub _safe_path { my $self = shift; my %hash = @_; my $path; my $tmpl = { path => { required => 1, store => \$path }, }; check( $tmpl, \%hash ) or return; if( ON_WIN32 ) { ### only need to fix it up if there's spaces in the path return $path unless $path =~ /\s+/; ### clean up paths if we are on win32 return Win32::GetShortPathName( $path ) || $path; } elsif ( ON_VMS ) { ### XXX According to John Malmberg, there's an VMS issue: ### catdir on VMS can not currently deal with directory components ### with dots in them. ### Fixing this is a three step procedure, which will work for ### VMS in its traditional ODS-2 mode, and it will also work if ### VMS is in the ODS-5 mode that is being implemented. ### If the path is already in VMS syntax, assume that we are done. ### VMS format is a path with a trailing ']' or ':' return $path if $path =~ /\:|\]$/; ### 1. Make sure that the value to be converted, $path is ### in UNIX directory syntax by appending a '/' to it. $path .= '/' unless $path =~ m|/$|; ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to ### underscores if needed. The trailing '/' is needed as so that ### C knows that it should use directory translation instead of ### filename translation, as filename translation leaves one dot. $path = VMS::Filespec::vmsify( $path ); ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify( ### $path . '/') to remove the directory delimiters. ### From John Malmberg: ### File::Spec->catdir will put the path back together. ### The '/' trick only works if the string is a directory name ### with UNIX style directory delimiters or no directory delimiters. ### It is to force vmsify to treat the input specification as UNIX. ### ### There is a VMS::Filespec::unixpath() to do the appending of the '/' ### to the specification, which will do a VMS::Filespec::vmsify() ### if needed. ### However it is not a good idea to call vmsify() on a pathname ### returned by unixify(), and it is not a good idea to call unixify() ### on a pathname returned by vmsify(). Because of the nature of the ### conversion, not all file specifications can make the round trip. ### ### I think that directory specifications can safely make the round ### trip, but not ones containing filenames. $path = File::Spec->catdir( File::Spec->splitdir( $path ) ) } return $path; } =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); Splits the name of a CPAN package string up into its package, version and extension parts. For example, C would return the following parts: Package: Foo-Bar Version: 1.2 Extension: tar.gz =cut { my $del_re = qr/[-_\+]/i; # delimiter between elements my $pkg_re = qr/[a-z] # any letters followed by [a-z\d]* # any letters, numbers (?i:\.pm)? # followed by '.pm'--authors do this :( (?: # optionally repeating: $del_re # followed by a delimiter [a-z] # any letters followed by [a-z\d]* # any letters, numbers (?i:\.pm)? # followed by '.pm'--authors do this :( )* /xi; my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters (?: # however, some start with a . only :( [-._] # followed by a delimiter [a-z\d]+ # and more digits and or letters )*? /xi; my $ext_re = qr/[a-z] # a letter, followed by [a-z\d]* # letters and or digits, optionally (?: \. # followed by a dot and letters [a-z\d]+ # and or digits (like .tar.bz2) )? # optionally /xi; my $ver_ext_re = qr/ ($ver_re+) # version, optional (?: \. # a literal . ($ext_re) # extension, )? # optional, but requires version /xi; ### composed regex for CPAN packages my $full_re = qr/ ^ ( # the whole thing ($pkg_re+) # package (?: $del_re # delimiter $ver_ext_re # version + extension )? ) $ /xi; ### composed regex for perl packages my $perl = PERL_CORE; my $perl_re = qr/ ^ ( # the whole thing ($perl) # package name for 'perl' (?: $ver_ext_re # version + extension )? ) $ /xi; sub _split_package_string { my $self = shift; my %hash = @_; my $str; my $tmpl = { package => { required => 1, store => \$str } }; check( $tmpl, \%hash ) or return; ### 2 different regexes, one for the 'perl' package, ### one for ordinary CPAN packages.. try them both, ### first match wins. for my $re ( $full_re, $perl_re ) { ### try the next if the match fails $str =~ $re or next; my $full = $1 || ''; my $pkg = $2 || ''; my $ver = $3 || ''; my $ext = $4 || ''; ### this regex resets the capture markers! ### strip the trailing delimiter $pkg =~ s/$del_re$//; ### strip the .pm package suffix some authors insist on adding $pkg =~ s/\.pm$//i; return ($pkg, $ver, $ext, $full ); } return; } } { my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0 .. 255; sub _uri_encode { my $self = shift; my %hash = @_; my $str; my $tmpl = { uri => { store => \$str, required => 1 } }; check( $tmpl, \%hash ) or return; ### XXX taken straight from URI::Encode ### Default unsafe characters. RFC 2732 ^(uric - reserved) $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g; return $str; } sub _uri_decode { my $self = shift; my %hash = @_; my $str; my $tmpl = { uri => { store => \$str, required => 1 } }; check( $tmpl, \%hash ) or return; ### XXX use unencode routine in utils? $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; return $str; } } sub _update_timestamp { my $self = shift; my %hash = @_; my $file; my $tmpl = { file => { required => 1, store => \$file, allow => FILE_EXISTS } }; check( $tmpl, \%hash ) or return; ### `touch` the file, so windoze knows it's new -jmb ### works on *nix too, good fix -Kane ### make sure it is writable first, otherwise the `touch` will fail my $now = time; unless( chmod( 0644, $file) && utime ($now, $now, $file) ) { error( loc("Couldn't touch %1", $file) ); return; } return 1; } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/Source.pm0000644000175000017500000012266212251421370020122 0ustar bingosbingospackage CPANPLUS::Internals::Source; use strict; use CPANPLUS::Error; use CPANPLUS::Module; use CPANPLUS::Module::Fake; use CPANPLUS::Module::Author; use CPANPLUS::Internals::Constants; use File::Fetch; use Archive::Extract; use IPC::Cmd qw[can_run]; use File::Temp qw[tempdir]; use File::Basename qw[dirname]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; $Params::Check::VERBOSE = 1; ### list of methods the parent class must implement { for my $sub ( qw[_init_trees _finalize_trees _standard_trees_completed _custom_trees_completed _add_module_object _add_author_object _save_state ] ) { no strict 'refs'; *$sub = sub { my $self = shift; my $class = ref $self || $self; require Carp; Carp::croak( loc( "Class %1 must implement method '%2'", $class, $sub ) ); } } } { my $recurse; # flag to prevent recursive calls to *_tree functions ### lazy loading of module tree sub _module_tree { my $self = $_[0]; unless ($self->_mtree or $recurse++ > 0) { my $uptodate = $self->_check_trees( @_[1..$#_] ); $self->_build_trees(uptodate => $uptodate); } $recurse--; return $self->_mtree; } ### lazy loading of author tree sub _author_tree { my $self = $_[0]; unless ($self->_atree or $recurse++ > 0) { my $uptodate = $self->_check_trees( @_[1..$#_] ); $self->_build_trees(uptodate => $uptodate); } $recurse--; return $self->_atree; } } =pod =head1 NAME CPANPLUS::Internals::Source - internals for updating source files =head1 SYNOPSIS ### lazy load author/module trees ### $cb->_author_tree; $cb->_module_tree; =head1 DESCRIPTION CPANPLUS::Internals::Source controls the updating of source files and the parsing of them into usable module/author trees to be used by C. Functions exist to check if source files are still C as well as update them, and then parse them. The flow looks like this: $cb->_author_tree || $cb->_module_tree $cb->_check_trees $cb->__check_uptodate $cb->_update_source $cb->__update_custom_module_sources $cb->__update_custom_module_source $cb->_build_trees ### engine methods { $cb->_init_trees; $cb->_standard_trees_completed $cb->_custom_trees_completed } $cb->__create_author_tree ### engine methods { $cb->_add_author_object } $cb->__create_module_tree $cb->__create_dslip_tree ### engine methods { $cb->_add_module_object } $cb->__create_custom_module_entries $cb->_dslip_defs =head1 METHODS =cut =pod =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) This method rebuilds the author- and module-trees from source. It takes the following arguments: =over 4 =item uptodate Indicates whether any on disk caches are still ok to use. =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =item use_stored A boolean flag indicating whether or not it is ok to use previously stored trees. Defaults to true. =back Returns a boolean indicating success. =cut ### (re)build the trees ### sub _build_trees { my ($self, %hash) = @_; my $conf = $self->configure_object; my($path,$uptodate,$use_stored,$verbose); my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, uptodate => { required => 1, store => \$uptodate }, use_stored => { default => 1, store => \$use_stored }, }; my $args = check( $tmpl, \%hash ) or return; $self->_init_trees( path => $path, uptodate => $uptodate, verbose => $verbose, use_stored => $use_stored, ) or do { error( loc("Could not initialize trees" ) ); return; }; ### return if we weren't able to build the trees ### return unless $self->_mtree && $self->_atree; ### did we get everything from a stored state? if not, ### process them now. if( not $self->_standard_trees_completed ) { ### first, prep the author tree $self->__create_author_tree( uptodate => $uptodate, path => $path, verbose => $verbose, ) or return; ### and now the module tree $self->_create_mod_tree( uptodate => $uptodate, path => $path, verbose => $verbose, ) or return; } ### XXX unpleasant hack. since custom sources uses ->parse_module, we ### already have a special module object with extra meta data. That ### doesn't go well with the sqlite storage engine. So, we check 'normal' ### trees from separate trees, so the engine can treat them differently. ### Effectively this means that with the SQLite engine, for now, custom ### sources are continuously reparsed =/ -kane if( not $self->_custom_trees_completed ) { ### update them if the other sources are also deemed out of date if( $conf->get_conf('enable_custom_sources') ) { $self->__update_custom_module_sources( verbose => $verbose ) or error(loc("Could not update custom module sources")); } ### add custom sources here if enabled if( $conf->get_conf('enable_custom_sources') ) { $self->__create_custom_module_entries( verbose => $verbose ) or error(loc("Could not create custom module entries")); } } ### give the source engine a chance to wrap up creation $self->_finalize_trees( path => $path, uptodate => $uptodate, verbose => $verbose, use_stored => $use_stored, ) or do { error(loc( "Could not finalize trees" )); return; }; ### still necessary? can only run one instance now ### ### will probably stay that way --kane # my $id = $self->_store_id( $self ); # # unless ( $id == $self->_id ) { # error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); # } return 1; } =pod =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] ) Retrieve source files and return a boolean indicating whether or not the source files are up to date. Takes several arguments: =over 4 =item update_source A flag to force re-fetching of the source files, even if they are still up to date. =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =back Will get information from the config file by default. =cut ### retrieve source files, and returns a boolean indicating if it's up to date sub _check_trees { my ($self, %hash) = @_; my $conf = $self->configure_object; my $update_source; my $verbose; my $path; my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, update_source => { default => 0, store => \$update_source }, }; my $args = check( $tmpl, \%hash ) or return; ### if the user never wants to update their source without explicitly ### telling us, shortcircuit here return 1 if $conf->get_conf('no_update') && !$update_source; ### a check to see if our source files are still up to date ### msg( loc("Checking if source files are up to date"), $verbose ); my $uptodate = 1; # default return value for my $name (qw[auth mod]) { for my $file ( $conf->_get_source( $name ) ) { $self->__check_uptodate( file => File::Spec->catfile( $path, $file ), name => $name, update_source => $update_source, verbose => $verbose, ) or $uptodate = 0; } } ### if we're explicitly asked to update the sources, or if the ### standard source files are out of date, update the custom sources ### as well ### RT #47820: Don't try to update custom sources if they are disabled ### in the configuration. $self->__update_custom_module_sources( verbose => $verbose ) if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate ); return $uptodate; } =pod =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] ) C<__check_uptodate> checks if a given source file is still up-to-date and if not, or when C is true, will re-fetch the source file. Takes the following arguments: =over 4 =item file The source file to check. =item name The internal shortcut name for the source file (used for config lookups). =item update_source Flag to force updating of sourcefiles regardless. =item verbose Boolean to indicate whether to be verbose or not. =back Returns a boolean value indicating whether the current files are up to date or not. =cut ### this method checks whether or not the source files we are using are still up to date sub __check_uptodate { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $tmpl = { file => { required => 1 }, name => { required => 1 }, update_source => { default => 0 }, verbose => { default => $conf->get_conf('verbose') }, }; my $args = check( $tmpl, \%hash ) or return; my $flag; unless ( -e $args->{'file'} && ( ( stat $args->{'file'} )[9] + $conf->_get_source('update') ) > time ) { $flag = 1; } if ( $flag or $args->{'update_source'} ) { if ( $self->_update_source( name => $args->{'name'} ) ) { return 0; # return 0 so 'uptodate' will be set to 0, meaning no # use of previously stored hashrefs! } else { msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} ); return 1; } } else { return 1; } } =pod =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] ) This method does the actual fetching of source files. It takes the following arguments: =over 4 =item name The internal shortcut name for the source file (used for config lookups). =item path The full path where to write the files. =item verbose Boolean to indicate whether to be verbose or not. =back Returns a boolean to indicate success. =cut ### this sub fetches new source files ### sub _update_source { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $verbose; my $tmpl = { name => { required => 1 }, path => { default => $conf->get_conf('base') }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; my $args = check( $tmpl, \%hash ) or return; my $path = $args->{path}; { ### this could use a clean up - Kane ### no worries about the / -> we get it from the _ftp configuration, so ### it's not platform dependant. -kane my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg; msg( loc("Updating source file '%1'", $file), $verbose ); my $fake = CPANPLUS::Module::Fake->new( module => $args->{'name'}, path => $dir, package => $file, _id => $self->_id, ); ### can't use $fake->fetch here, since ->parent won't work -- ### the sources haven't been saved yet my $rv = $self->_fetch( module => $fake, fetchdir => $path, force => 1, ); unless ($rv) { error( loc("Couldn't fetch '%1'", $file) ); return; } $self->_update_timestamp( file => File::Spec->catfile($path, $file) ); } return 1; } =pod =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL]) This method opens a source files and parses its contents into a searchable author-tree or restores a file-cached version of a previous parse, if the sources are uptodate and the file-cache exists. It takes the following arguments: =over 4 =item uptodate A flag indicating whether the file-cache is uptodate or not. =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =back Will get information from the config file by default. Returns a tree on success, false on failure. =cut sub __create_author_tree { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $tmpl = { path => { default => $conf->get_conf('base') }, verbose => { default => $conf->get_conf('verbose') }, uptodate => { default => 0 }, }; my $args = check( $tmpl, \%hash ) or return; my $file = File::Spec->catfile( $args->{path}, $conf->_get_source('auth') ); msg(loc("Rebuilding author tree, this might take a while"), $args->{verbose}); ### extract the file ### my $ae = Archive::Extract->new( archive => $file ) or return; my $out = STRIP_GZ_SUFFIX->($file); ### make sure to set the PREFER_BIN flag if desired ### { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); $ae->extract( to => $out ) or return; } my $cont = $self->_get_file_contents( file => $out ) or return; ### don't need it anymore ### unlink $out; my ($tot,$prce,$prc,$idx); if ( $args->{verbose} and local $|=1 ) { no warnings; $tot = scalar(split /\n/, $cont); ($prce, $prc, $idx) = (int $tot / 25, 0, 0); print "\t0%"; } for ( split /\n/, $cont ) { my($id, $name, $email) = m/^alias \s+ (\S+) \s+ "\s* ([^\"\<]+?) \s* <(.+)> \s*" /x; $self->_add_author_object( author => $name, #authors name email => $email, #authors email address cpanid => $id, #authors CPAN ID ) or error( loc("Could not add author '%1'", $name ) ); $args->{verbose} and ( $idx++, ($idx==$prce and ($prc+=4,$idx=0,print ".")), (($prc % 10) or $idx or print $prc,'%') ); } $args->{verbose} and print "\n"; return $self->_atree; } #__create_author_tree =pod =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL]) This method opens a source files and parses its contents into a searchable module-tree or restores a file-cached version of a previous parse, if the sources are uptodate and the file-cache exists. It takes the following arguments: =over 4 =item uptodate A flag indicating whether the file-cache is up-to-date or not. =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =back Will get information from the config file by default. Returns a tree on success, false on failure. =cut ### this builds a hash reference with the structure of the cpan module tree ### sub _create_mod_tree { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $base = $conf->_get_mirror('base'); my $tmpl = { path => { default => $conf->get_conf('base') }, verbose => { default => $conf->get_conf('verbose') }, uptodate => { default => 0 }, }; my $args = check( $tmpl, \%hash ) or return undef; my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod')); msg(loc("Rebuilding module tree, this might take a while"), $args->{verbose}); my $dslip_tree = $self->__create_dslip_tree( %$args ); my $author_tree = $self->author_tree; ### extract the file ### my $ae = Archive::Extract->new( archive => $file ) or return; my $out = STRIP_GZ_SUFFIX->($file); ### make sure to set the PREFER_BIN flag if desired ### { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); $ae->extract( to => $out ) or return; } my $content = $self->_get_file_contents( file => $out ) or return; my $lines = $content =~ tr/\n/\n/; ### don't need it anymore ### unlink $out; my($past_header, $count, $tot, $prce, $prc, $idx); if ( $args->{verbose} and local $|=1 ) { no warnings; $tot = scalar(split /\n/, $content); ($prce, $prc, $idx) = (int $tot / 25, 0, 0); print "\t0%"; } for ( split /\n/, $content ) { ### we're still in the header -- find the amount of lines we expect unless( $past_header ) { ### header has ended -- did we get the line count? if( m|^\s*$| ) { unless( $count ) { error(loc("Could not determine line count from %1", $file)); return; } $past_header = 1; ### if the line count doesn't match what we expect, bail out ### this should address: #45644: detect broken index } else { $count = $1 if /^Line-Count:\s+(\d+)/; if( $count ) { if( $lines < $count ) { error(loc("Expected to read at least %1 lines, but %2 ". "contains only %3 lines!", $count, $file, $lines )); return; } } } ### still in the header, keep moving next; } my @data = split /\s+/; ### three fields expected on each line next unless @data == 3; ### filter out the author and filename as well ### ### authors can apparently have digits in their names, ### and dirs can have dots... blah! my ($author, $package) = $data[2] =~ m| (?:[A-Z\d-]/)? (?:[A-Z\d-]{2}/)? ([A-Z\d-]+) (?:/[\S]+)?/ ([^/]+)$ |xsg; ### remove file name from the path $data[2] =~ s|/[^/]+$||; my $aobj = $author_tree->{$author}; unless( $aobj ) { error( loc( "No such author '%1' -- can't make module object " . "'%2' that is supposed to belong to this author", $author, $data[0] ) ); next; } my $dslip_mod = $dslip_tree->{ $data[0] }; ### adding the dslip info my $dslip; for my $item ( qw[ statd stats statl stati statp ] ) { ### checking if there's an entry in the dslip info before ### catting it on. appeasing warnings this way $dslip .= $dslip_mod->{$item} || ' '; } ### XXX this could be sped up if we used author names, not author ### objects in creation, and then look them up in the author tree ### when needed. This will need a fix to all the places that create ### fake author/module objects as well. ### callback to store the individual object $self->_add_module_object( module => $data[0], # full module name version => ($data[1] eq 'undef' # version number ? '0.0' : $data[1]), path => File::Spec::Unix->catfile( $base, $data[2], ), # extended path on the cpan mirror, # like /A/AB/ABIGAIL comment => $data[3], # comment on the module author => $aobj, package => $package, # package name, like # 'foo-bar-baz-1.03.tar.gz' description => $dslip_mod->{'description'}, dslip => $dslip, mtime => '', ) or error( loc( "Could not add module '%1'", $data[0] ) ); $args->{verbose} and ( $idx++, ($idx==$prce and ($prc+=4,$idx=0,print ".")), (($prc % 10) or $idx or print $prc,'%') ); } #for $args->{verbose} and print "\n"; return $self->_mtree; } #_create_mod_tree =pod =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL]) This method opens a source files and parses its contents into a searchable dslip-tree or restores a file-cached version of a previous parse, if the sources are uptodate and the file-cache exists. It takes the following arguments: =over 4 =item uptodate A flag indicating whether the file-cache is uptodate or not. =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =back Will get information from the config file by default. Returns a tree on success, false on failure. =cut sub __create_dslip_tree { my $self = shift; my %hash = @_; my $conf = $self->configure_object; return {}; # Quick hack my $tmpl = { path => { default => $conf->get_conf('base') }, verbose => { default => $conf->get_conf('verbose') }, uptodate => { default => 0 }, }; my $args = check( $tmpl, \%hash ) or return; ### get the file name of the source ### my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip')); ### extract the file ### my $ae = Archive::Extract->new( archive => $file ) or return; my $out = STRIP_GZ_SUFFIX->($file); ### make sure to set the PREFER_BIN flag if desired ### { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); $ae->extract( to => $out ) or return; } my $in = $self->_get_file_contents( file => $out ) or return; ### don't need it anymore ### unlink $out; ### get rid of the comments and the code ### ### need a smarter parser, some people have this in their dslip info: # [ # 'Statistics::LTU', # 'R', # 'd', # 'p', # 'O', # '?', # 'Implements Linear Threshold Units', # ...skipping... # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!", # 'BENNIE', # '11' # ], ### also, older versions say: ### $cols = [....] ### and newer versions say: ### $CPANPLUS::Modulelist::cols = [...] ### split '$cols' and '$data' into 2 variables ### ### use this regex to make sure dslips with ';' in them don't cause ### parser errors my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ (\$(?:CPAN::Modulelist::)?cols.*?) (\$(?:CPAN::Modulelist::)?data.*) |sx); ### eval them into existence ### ### still not too fond of this solution - kane ### my ($cols, $data); { #local $@; can't use this, it's buggy -kane $cols = eval $ds_one; error( loc("Error in eval of dslip source files: %1", $@) ) if $@; $data = eval $ds_two; error( loc("Error in eval of dslip source files: %1", $@) ) if $@; } my $tree = {}; my $primary = "modid"; ### this comes from CPAN::Modulelist ### which is in 03modlist.data.gz for (@$data){ my %hash; @hash{@$cols} = @$_; $tree->{$hash{$primary}} = \%hash; } return $tree; } #__create_dslip_tree =pod =head2 $cb->_dslip_defs () This function returns the definition structure (ARRAYREF) of the dslip tree. =cut ### these are the definitions used for dslip info ### they shouldn't change over time.. so hardcoding them doesn't appear to ### be a problem. if it is, we need to parse 03modlist.data better to filter ### all this out. ### right now, this is just used to look up dslip info from a module sub _dslip_defs { my $self = shift; my $aref = [ # D [ q|Development Stage|, { i => loc('Idea, listed to gain consensus or as a placeholder'), c => loc('under construction but pre-alpha (not yet released)'), a => loc('Alpha testing'), b => loc('Beta testing'), R => loc('Released'), M => loc('Mature (no rigorous definition)'), S => loc('Standard, supplied with Perl 5'), }], # S [ q|Support Level|, { m => loc('Mailing-list'), d => loc('Developer'), u => loc('Usenet newsgroup comp.lang.perl.modules'), n => loc('None known, try comp.lang.perl.modules'), a => loc('Abandoned; volunteers welcome to take over maintenance'), }], # L [ q|Language Used|, { p => loc('Perl-only, no compiler needed, should be platform independent'), c => loc('C and perl, a C compiler will be needed'), h => loc('Hybrid, written in perl with optional C code, no compiler needed'), '+' => loc('C++ and perl, a C++ compiler will be needed'), o => loc('perl and another language other than C or C++'), }], # I [ q|Interface Style|, { f => loc('plain Functions, no references used'), h => loc('hybrid, object and function interfaces available'), n => loc('no interface at all (huh?)'), r => loc('some use of unblessed References or ties'), O => loc('Object oriented using blessed references and/or inheritance'), }], # P [ q|Public License|, { p => loc('Standard-Perl: user may choose between GPL and Artistic'), g => loc('GPL: GNU General Public License'), l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'), b => loc('BSD: The BSD License'), a => loc('Artistic license alone'), o => loc('other (but distribution allowed without restrictions)'), }], ]; return $aref; } =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); Adds a custom source index and updates it based on the provided URI. Returns the full path to the index file on success or false on failure. =cut sub _add_custom_module_source { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($verbose,$uri); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, uri => { required => 1, store => \$uri } }; check( $tmpl, \%hash ) or return; ### what index file should we use on disk? my $index = $self->__custom_module_source_index_file( uri => $uri ); ### already have it. if( IS_FILE->( $index ) ) { msg(loc("Source '%1' already added", $uri)); return 1; } ### do we need to create the targe dir? { my $dir = dirname( $index ); unless( IS_DIR->( $dir ) ) { $self->_mkdir( dir => $dir ) or return } } ### write the file my $fh = OPEN_FILE->( $index => '>' ) or do { error(loc("Could not open index file for '%1'", $uri)); return; }; ### basically we 'touched' it. Check the return value, may be ### important on win32 and similar OS, where there's file length ### limits close $fh or do { error(loc("Could not write index file to disk for '%1'", $uri)); return; }; $self->__update_custom_module_source( remote => $uri, local => $index, verbose => $verbose, ) or do { ### we failed to update it, we probably have an empty ### possibly silly filename on disk now -- remove it 1 while unlink $index; return; }; return $index; } =head2 $index = $cb->__custom_module_source_index_file( uri => $uri ); Returns the full path to the encoded index file for C<$uri>, as used by all C routines. =cut sub __custom_module_source_index_file { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($verbose,$uri); my $tmpl = { uri => { required => 1, store => \$uri } }; check( $tmpl, \%hash ) or return; my $index = File::Spec->catfile( $conf->get_conf('base'), $conf->_get_build('custom_sources'), $self->_uri_encode( uri => $uri ), ); return $index; } =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); Removes a custom index file based on the URI provided. Returns the full path to the index file on success or false on failure. =cut sub _remove_custom_module_source { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($verbose,$uri); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, uri => { required => 1, store => \$uri } }; check( $tmpl, \%hash ) or return; ### use uri => local, instead of the other way around my %files = reverse $self->__list_custom_module_sources; ### On VMS the case of key to %files can be either exact or lower case ### XXX abstract this lookup out? --kane my $file = $files{ $uri }; $file = $files{ lc $uri } if !defined($file) && ON_VMS; unless (defined $file) { error(loc("No such custom source '%1'", $uri)); return; }; 1 while unlink $file; if( IS_FILE->( $file ) ) { error(loc("Could not remove index file '%1' for custom source '%2'", $file, $uri)); return; } msg(loc("Successfully removed index file for '%1'", $uri), $verbose); return $file; } =head2 %files = $cb->__list_custom_module_sources This method scans the 'custom-sources' directory in your base directory for additional sources to include in your module tree. Returns a list of key value pairs as follows: /full/path/to/source/file%3Fencoded => http://decoded/mirror/path =cut sub __list_custom_module_sources { my $self = shift; my $conf = $self->configure_object; my($verbose); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; my $dir = File::Spec->catdir( $conf->get_conf('base'), $conf->_get_build('custom_sources'), ); unless( IS_DIR->( $dir ) ) { msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose); return; } ### unencode the files ### skip ones starting with # though my %files = map { my $org = $_; my $dec = $self->_uri_decode( uri => $_ ); File::Spec->catfile( $dir, $org ) => $dec } grep { $_ !~ /^#/ } READ_DIR->( $dir ); return %files; } =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] ); Attempts to update all the index files to your custom module sources. If the index is missing, and it's a C uri, it will generate a new local index for you. Return true on success, false on failure. =cut sub __update_custom_module_sources { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my $verbose; my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose } }; check( $tmpl, \%hash ) or return; my %files = $self->__list_custom_module_sources; ### uptodate check has been done a few levels up. my $fail; while( my($local,$remote) = each %files ) { $self->__update_custom_module_source( remote => $remote, local => $local, verbose => $verbose, ) or ( $fail++, next ); } error(loc("Failed updating one or more remote sources files")) if $fail; return if $fail; return 1; } =head2 $ok = $cb->__update_custom_module_source Attempts to update all the index files to your custom module sources. If the index is missing, and it's a C uri, it will generate a new local index for you. Return true on success, false on failure. =cut sub __update_custom_module_source { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($verbose,$local,$remote); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, local => { store => \$local, allow => FILE_EXISTS }, remote => { required => 1, store => \$remote }, }; check( $tmpl, \%hash ) or return; msg( loc("Updating sources from '%1'", $remote), $verbose); ### if you didn't provide a local file, we'll look in your custom ### dir to find the local encoded version for you $local ||= do { ### find all files we know of my %files = reverse $self->__list_custom_module_sources or do { error(loc("No custom modules sources defined -- need '%1' argument", 'local')); return; }; ### On VMS the case of key to %files can be either exact or lower case ### XXX abstract this lookup out? --kane my $file = $files{ $remote }; $file = $files{ lc $remote } if !defined ($file) && ON_VMS; ### return the local file we're supposed to use $file or do { error(loc("Remote source '%1' unknown -- needs '%2' argument", $remote, 'local')); return; }; }; my $uri = join '/', $remote, $conf->_get_source('custom_index'); my $ff = File::Fetch->new( uri => $uri ); ### tempdir doesn't clean up by default, as opposed to tempfile() ### so add it explicitly. my $dir = tempdir( CLEANUP => 1 ); my $res = do { local $File::Fetch::WARN = 0; local $File::Fetch::TIMEOUT = $conf->get_conf('timeout'); $ff->fetch( to => $dir ); }; ### couldn't get the file unless( $res ) { ### it's not a local scheme, so can't auto index unless( $ff->scheme eq 'file' ) { error(loc("Could not update sources from '%1': %2", $remote, $ff->error )); return; ### it's a local uri, we can index it ourselves } else { msg(loc("No index file found at '%1', generating one", $ff->uri), $verbose ); ### ON VMS, if you are working with a UNIX file specification, ### you need currently use the UNIX variants of the File::Spec. my $ff_path = do { my $file_class = 'File::Spec'; $file_class .= '::Unix' if ON_VMS; $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) ); }; $self->__write_custom_module_index( path => $ff_path, to => $local, verbose => $verbose, ) or return; ### XXX don't write that here, __write_custom_module_index ### already prints this out #msg(loc("Index file written to '%1'", $to), $verbose); } ### copy it to the real spot and update its timestamp } else { $self->_move( file => $res, to => $local ) or return; $self->_update_timestamp( file => $local ); msg(loc("Index file saved to '%1'", $local), $verbose); } return $local; } =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] ) Scans the C you provided for packages and writes an index with all the available packages to C<$path/packages.txt>. If you'd like the index to be written to a different file, provide the C argument. Returns true on success and false on failure. =cut sub __write_custom_module_index { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my ($verbose, $path, $to); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, path => { required => 1, allow => DIR_EXISTS, store => \$path }, to => { store => \$to }, }; check( $tmpl, \%hash ) or return; ### no explicit to? then we'll use our default $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') ); my @files; require File::Find; File::Find::find( sub { ### let's see if A::E can even parse it my $ae = do { local $Archive::Extract::WARN = 0; local $Archive::Extract::WARN = 0; Archive::Extract->new( archive => $File::Find::name ) } or return; ### it's a type A::E recognize, so we can add it $ae->type or return; ### neither $_ nor $File::Find::name have the chunk of the path in ### it starting $path -- it's either only the filename, or the full ### path, so we have to strip it ourselves ### make sure to remove the leading slash as well. my $copy = $File::Find::name; my $re = quotemeta($path); $copy =~ s|^$re[\\/]?||i; push @files, $copy; }, $path ); ### does the dir exist? if not, create it. { my $dir = dirname( $to ); unless( IS_DIR->( $dir ) ) { $self->_mkdir( dir => $dir ) or return } } ### create the index file my $fh = OPEN_FILE->( $to => '>' ) or return; print $fh "$_\n" for @files; close $fh; msg(loc("Successfully written index file to '%1'", $to), $verbose); return $to; } =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] ) Creates entries in the module tree based upon the files as returned by C<__list_custom_module_sources>. Returns true on success, false on failure. =cut ### use $auth_obj as a persistent version, so we don't have to recreate ### modules all the time { my $auth_obj; sub __create_custom_module_entries { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my $verbose; my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; check( $tmpl, \%hash ) or return undef; my %files = $self->__list_custom_module_sources; while( my($file,$name) = each %files ) { msg(loc("Adding packages from custom source '%1'", $name), $verbose); my $fh = OPEN_FILE->( $file ) or next; while( local $_ = <$fh> ) { chomp; next if /^#/; next unless /\S+/; ### join on / -- it's a URI after all! my $parse = join '/', $name, $_; ### try to make a module object out of it my $mod = $self->parse_module( module => $parse ) or ( error(loc("Could not parse '%1'", $_)), next ); ### mark this object with a custom author $auth_obj ||= do { my $id = CUSTOM_AUTHOR_ID; ### if the object is being created for the first time, ### make sure there's an entry in the author tree as ### well, so we can search on the CPAN ID $self->author_tree->{ $id } = CPANPLUS::Module::Author::Fake->new( cpanid => $id ); }; $mod->author( $auth_obj ); ### and now add it to the module tree -- this MAY ### override things of course if( my $old_mod = $self->module_tree( $mod->module ) ) { ### On VMS use the old module name to get the real case $mod->module( $old_mod->module ) if ON_VMS; msg(loc("About to overwrite module tree entry for '%1' with '%2'", $mod->module, $mod->package), $verbose); } ### mark where it came from $mod->description( loc("Custom source from '%1'",$name) ); ### store it in the module tree $self->module_tree->{ $mod->module } = $mod; } } return 1; } } 1; CPANPLUS-0.9144/lib/CPANPLUS/Internals/Constants/0000755000175000017500000000000012251422462020272 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Internals/Constants/Report.pm0000644000175000017500000003604212251421370022105 0ustar bingosbingospackage CPANPLUS::Internals::Constants::Report; use strict; use CPANPLUS::Error; use File::Spec; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; require Exporter; use vars qw[$VERSION @ISA @EXPORT]; use Package::Constants; ### for the version require CPANPLUS::Internals; $VERSION = "0.9144"; @ISA = qw[Exporter]; @EXPORT = Package::Constants->list( __PACKAGE__ ); ### OS to regex map ### my %OS = ( Amiga => 'amigaos', Atari => 'mint', BSD => 'bsdos|bitrig|darwin|freebsd|openbsd|netbsd', Be => 'beos', BeOS => 'beos', Cygwin => 'cygwin', Darwin => 'darwin', EBCDIC => 'os390|os400|posix-bc|vmesa', HPUX => 'hpux', Linux => 'linux', MSDOS => 'dos|os2|MSWin32|cygwin', 'bin\\d*Mac'=> 'MacOS|darwin', # binMac, bin56Mac, bin58Mac... Mac => 'MacOS|darwin', MacPerl => 'MacOS', MacOS => 'MacOS|darwin', MacOSX => 'darwin', MPE => 'mpeix', MPEiX => 'mpeix', OS2 => 'os2', Plan9 => 'plan9', RISCOS => 'riscos', SGI => 'irix', Solaris => 'solaris', Unix => 'aix|bsdos|bitrig|darwin|dgux|dynixptx|freebsd|'. 'linux|hpux|machten|netbsd|next|openbsd|dec_osf|'. 'svr4|sco_sv|unicos|unicosmk|solaris|sunos', VMS => 'VMS', VOS => 'VOS', Win32 => 'MSWin32|cygwin', Win32API => 'MSWin32|cygwin', ); use constant GRADE_FAIL => 'fail'; use constant GRADE_PASS => 'pass'; use constant GRADE_NA => 'na'; use constant GRADE_UNKNOWN => 'unknown'; use constant MAX_REPORT_SEND => 2; use constant CPAN_TESTERS_EMAIL => 'cpan-testers@perl.org'; ### the cpan mail account for this user ### use constant CPAN_MAIL_ACCOUNT => sub { my $username = shift or return; return $username . '@cpan.org'; }; ### check if this module is platform specific and if we're on that ### specific platform. Alternately, the module is not platform specific ### and we're always OK to send out test results. use constant RELEVANT_TEST_RESULT => sub { my $mod = shift or return; my $name = $mod->module; my $specific; for my $platform (keys %OS) { if( $name =~ /^$platform\b/i ) { # beware the Mac != MAC next if($platform eq 'Mac' && $name !~ /^$platform\b/); $specific++; return 1 if $^O =~ /^(?:$OS{$platform})$/ } }; return $specific ? 0 : 1; }; use constant UNSUPPORTED_OS => sub { my $buffer = shift or return; if( $buffer =~ /No support for OS|OS unsupported/im ) { return 1; } return 0; }; use constant PERL_VERSION_TOO_LOW => sub { my $buffer = shift or return; # ExtUtils::MakeMaker format if( $buffer =~ /Perl .*? required--this is only .*?/m ) { return 1; } # Module::Build format if( $buffer =~ /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) { return 1; } return 0; }; use constant NO_TESTS_DEFINED => sub { my $buffer = shift or return; if( $buffer =~ /(No tests defined( for [\w:]+ extension)?\.)/ and $buffer !~ /\*\.t/m and $buffer !~ /test\.pl/m ) { return $1 } return; }; ### what stage did the test fail? ### use constant TEST_FAIL_STAGE => sub { my $buffer = shift or return; return $buffer =~ /(MAKE [A-Z]+).*/ ? lc $1 : 'fetch'; }; use constant MISSING_PREREQS_LIST => sub { my $buffer = shift; my $last = ( split /\[ERROR\] .+? MAKE TEST/, $buffer )[-1]; my @list = map { s/.pm$//; s|/|::|g; $_ } ($last =~ m/\bCan\'t locate (\S+) in \@INC/g); ### make sure every missing prereq is only ### listed once { my %seen; @list = grep { !$seen{$_}++ } @list } return @list; }; use constant MISSING_EXTLIBS_LIST => sub { my $buffer = shift; my @list = ($buffer =~ m/No library found for -l([-\w]+)/g); return @list; }; use constant REPORT_MESSAGE_HEADER => sub { my ($version, $author) = @_; return << "."; Dear $author, This is a computer-generated error report created automatically by CPANPLUS, version $version. Testers personal comments may appear at the end of this report. . }; use constant REPORT_MESSAGE_FAIL_HEADER => sub { my($stage, $buffer) = @_; return << "."; Thank you for uploading your work to CPAN. However, it appears that there were some problems testing your distribution. TEST RESULTS: Below is the error stack from stage '$stage': $buffer . }; use constant REPORT_MESSAGE_PASS_HEADER => sub { my($stage, $buffer) = @_; return << "."; Thank you for uploading your work to CPAN. Congratulations! All tests were successful. TEST RESULTS: Below is the error stack from stage '$stage': $buffer . }; use constant REPORT_MISSING_PREREQS => sub { my ($author,$email,@missing) = @_; $author = ($author && $email) ? "$author ($email)" : 'Your Name Here'; my $modules = join "\n", @missing; my $prereqs = join "\n", map {"\t'$_'\t=> '0',". " # or a minimum working version"} @missing; return << "."; MISSING PREREQUISITES: It was observed that the test suite seem to fail without these modules: $modules As such, adding the prerequisite module(s) to 'PREREQ_PM' in your Makefile.PL should solve this problem. For example: WriteMakefile( AUTHOR => '$author', ... # other information PREREQ_PM => { $prereqs } ); Thanks! :-) . }; use constant REPORT_MISSING_TESTS => sub { return << "."; RECOMMENDATIONS: It would be very helpful if you could include even a simple test script in the next release, so people can verify which platforms can successfully install them, as well as avoid regression bugs? A simple 't/use.t' that says: #!/usr/bin/env perl -w use strict; use Test; BEGIN { plan tests => 1 } use Your::Module::Here; ok(1); exit; __END__ would be appreciated. If you are interested in making a more robust test suite, please see the Test::Simple, Test::More and Test::Tutorial documentation at . Thanks! :-) . }; use constant REPORT_LOADED_PREREQS => sub { my $mod = shift; my $cb = $mod->parent; my $prq = $mod->status->prereqs || {}; ### not every prereq may be coming from CPAN ### so maybe we wont find it in our module ### tree at all... ### skip ones that can't be found in the list ### as reported in #12723 my @prq = grep { defined } map { $cb->module_tree($_) } sort keys %$prq; ### no prereqs? return '' unless @prq; ### some apparently, list what we loaded my $str = << "."; PREREQUISITES: Here is a list of prerequisites you specified and versions we managed to load: . $str .= join '', map { sprintf "\t%s %-30s %8s %8s\n", @$_ } [' ', 'Module Name', 'Have', 'Want'], map { my $want = $prq->{$_->name}; [ do { $_->is_uptodate( version => $want ) ? ' ' : '!' }, $_->name, $_->installed_version, $want ], ### might be empty entries in there } grep { $_ } @prq; return $str; }; use constant REPORT_TOOLCHAIN_VERSIONS => sub { my $mod = shift; my $cb = $mod->parent; #die unless $cb->isa('CPANPLUS::Backend'); my @toolchain_modules= qw( CPANPLUS CPANPLUS::Dist::Build Cwd ExtUtils::CBuilder ExtUtils::Command ExtUtils::Install ExtUtils::MakeMaker ExtUtils::Manifest ExtUtils::ParseXS File::Spec Module::Build Pod::Parser Pod::Simple Test::Harness Test::More version ); my @toolchain = grep { $_ } #module_tree returns '' when module is not found map { $cb->module_tree($_) } sort @toolchain_modules; ### no prereqs? return '' unless @toolchain; ### toolchain modules my $str = << "."; Perl module toolchain versions installed: . $str .= join '', map { sprintf "\t%-30s %8s\n", @$_ } ['Module Name', 'Have'], map { [ $_->name, $_->installed_version, ], ### might be empty entries in there } @toolchain; return $str; }; use constant REPORT_TESTS_SKIPPED => sub { return << "."; ******************************** NOTE ******************************** *** *** *** The tests for this module were skipped during this build *** *** *** ********************************************************************** . }; use constant REPORT_MESSAGE_FOOTER => sub { return << "."; ******************************** NOTE ******************************** The comments above are created mechanically, possibly without manual checking by the sender. As there are many people performing automatic tests on each upload to CPAN, it is likely that you will receive identical messages about the same problem. If you believe that the message is mistaken, please reply to the first one with correction and/or additional informations, and do not take it personally. We appreciate your patience. :) ********************************************************************** Additional comments: . }; 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/Fetch.pm0000644000175000017500000003734612251421370017717 0ustar bingosbingospackage CPANPLUS::Internals::Fetch; use strict; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use File::Fetch; use File::Spec; use Cwd qw[cwd]; use IPC::Cmd qw[run]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Internals::Fetch - internals for fetching files =head1 SYNOPSIS my $output = $cb->_fetch( module => $modobj, fetchdir => '/path/to/save/to', verbose => BOOL, force => BOOL, ); $cb->_add_fail_host( host => 'foo.com' ); $cb->_host_ok( host => 'foo.com' ); =head1 DESCRIPTION CPANPLUS::Internals::Fetch fetches files from either ftp, http, file or rsync mirrors. This is the rough flow: $cb->_fetch Delegate to File::Fetch; =head1 METHODS =cut =head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, ttl => $seconds] ) C<_fetch> will fetch files based on the information in a module object. You always need a module object. If you want a fake module object for a one-off fetch, look at C. C is the place to save the file to. Usually this information comes from your configuration, but you can override it expressly if needed. C lets you specify an URI to get this file from. If you do not specify one, your list of configured hosts will be probed to download the file from. C forces a new download, even if the file already exists. C simply indicates whether or not to print extra messages. C indicates whether you prefer the use of commandline programs over perl modules. Defaults to your corresponding config setting. C (in seconds) indicates how long a cached copy is valid for. If the fetch time of the local copy is within the ttl, the cached copy is returned. Otherwise, the file is refetched. C<_fetch> figures out, based on the host list, what scheme to use and from there, delegates to C do the actual fetching. Returns the path of the output file on success, false on failure. Note that you can set a C on certain methods in the config. Simply add the identifying name of the method (ie, C) to: $conf->_set_fetch( blacklist => ['lwp'] ); And the C function will be skipped by C. =cut sub _fetch { my $self = shift; my $conf = $self->configure_object; my %hash = @_; local $Params::Check::NO_DUPLICATES = 0; my ($modobj, $verbose, $force, $fetch_from, $ttl); my $tmpl = { module => { required => 1, allow => IS_MODOBJ, store => \$modobj }, fetchdir => { default => $conf->get_conf('fetchdir') }, fetch_from => { default => '', store => \$fetch_from }, force => { default => $conf->get_conf('force'), store => \$force }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, prefer_bin => { default => $conf->get_conf('prefer_bin') }, ttl => { default => 0, store => \$ttl }, }; my $args = check( $tmpl, \%hash ) or return; ### check if we already downloaded the thing ### if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) { msg(loc("Already fetched '%1' to '%2', " . "won't fetch again without force", $modobj->module, $where ), $verbose ); return $where; } my ($remote_file, $local_file, $local_path); ### build the local path to download to ### { $local_path = $args->{fetchdir} || File::Spec->catdir( $conf->get_conf('base'), $modobj->path, ); ### create the path if it doesn't exist ### unless( -d $local_path ) { unless( $self->_mkdir( dir => $local_path ) ) { msg( loc("Could not create path '%1'", $local_path), $verbose); return; } } $local_file = File::Spec->rel2abs( File::Spec->catfile( $local_path, $modobj->package, ) ); ### do we already have the file? if so, can we use the cached version, ### or do we need to refetch? if( -e $local_file ) { my $unlink = 0; my $use_cached = 0; ### if force is in effect, we have to refetch if( $force ) { $unlink++ ### if you provided a ttl, and it was exceeded, we'll refetch, } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) { msg(loc("Using cached file '%1' on disk; ". "ttl (%2s) is not exceeded", $local_file, $ttl), $verbose ); $use_cached++; ### if you provided a ttl, and the above conditional didn't match, ### we exceeded the ttl, so we refetch } elsif ( $ttl ) { $unlink++; ### otherwise we can use the cached version } else { $use_cached++; } if( $unlink ) { ### some fetches will fail if the files exist already, so let's ### delete them first 1 while unlink $local_file; msg(loc("Could not delete %1, some methods may " . "fail to force a download", $local_file), $verbose) if -e $local_file; } else { ### store where we fetched it ### $modobj->status->fetch( $local_file ); return $local_file; } } } ### we got a custom URI if ( $fetch_from ) { my $abs = $self->__file_fetch( from => $fetch_from, to => $local_path, verbose => $verbose ); unless( $abs ) { error(loc("Unable to download '%1'", $fetch_from)); return; } ### store where we fetched it ### $modobj->status->fetch( $abs ); return $abs; ### we will get it from one of our mirrors } else { ### build the remote path to download from ### { $remote_file = File::Spec::Unix->catfile( $modobj->path, $modobj->package, ); unless( $remote_file ) { error( loc('No remote file given for download') ); return; } } ### see if we even have a host or a method to use to download with ### my $found_host; my @maybe_bad_host; HOST: { ### F*CKING PIECE OF F*CKING p4 SHIT makes ### '$File :: Fetch::SOME_VAR' ### into a meta variable and starts substituting the file name... ### GRAAAAAAAAAAAAAAAAAAAAAAH! ### use ' to combat it! ### set up some flags for File::Fetch ### local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist'); local $File'Fetch::TIMEOUT = $conf->get_conf('timeout'); local $File'Fetch::DEBUG = $conf->get_conf('debug'); local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive'); local $File'Fetch::FROM_EMAIL = $conf->get_conf('email'); local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin'); local $File'Fetch::WARN = $verbose; ### loop over all hosts we have ### for my $host ( @{$conf->get_conf('hosts')} ) { $found_host++; my $where; ### file:// uris are special and need parsing if( $host->{'scheme'} eq 'file' ) { ### the full path in the native format of the OS my $host_spec = File::Spec->file_name_is_absolute( $host->{'path'} ) ? $host->{'path'} : File::Spec->rel2abs( $host->{'path'} ); ### there might be volumes involved on vms/win32 if( ON_WIN32 or ON_VMS ) { ### now extract the volume in order to be Win32 and ### VMS friendly. ### 'no_file' indicates that there's no file part ### of this path, so we only get 2 bits returned. my ($vol, $host_path) = File::Spec->splitpath( $host_spec, 'no_file' ); ### and split up the directories my @host_dirs = File::Spec->splitdir( $host_path ); ### if we got a volume we pretend its a directory for ### the sake of the file:// url if( defined $vol and $vol ) { ### D:\foo\bar needs to be encoded as D|\foo\bar ### For details, see the following link: ### http://en.wikipedia.org/wiki/File:// ### The RFC doesn't seem to address Windows volume ### descriptors but it does address VMS volume ### descriptors, however wikipedia covers a bit of ### history regarding win32 $vol =~ s/:$/|/ if ON_WIN32; $vol =~ s/:// if ON_VMS; ### XXX i'm not sure what cases this is addressing. ### this comes straight from dmq's file:// patches ### for win32. --kane ### According to dmq, the best summary is: ### "if file:// urls don't look right on VMS reuse ### the win32 logic and see if that fixes things" ### first element not empty? Might happen on VMS. ### prepend the volume in that case. if( $host_dirs[0] ) { unshift @host_dirs, $vol; ### element empty? reuse it to store the volume ### encoded as a directory name. (Win32/VMS) } else { $host_dirs[0] = $vol; } } ### now it's in UNIX format, which is the same format ### as used for URIs $host_spec = File::Spec::Unix->catdir( @host_dirs ); } ### now create the file:// uri from the components $where = CREATE_FILE_URI->( File::Spec::Unix->catfile( $host->{'host'} || '', $host_spec, $remote_file, ) ); ### its components will be in unix format, for a http://, ### ftp:// or any other style of URI } else { my $mirror_path = File::Spec::Unix->catfile( $host->{'path'}, $remote_file ); my %args = ( scheme => $host->{scheme}, host => $host->{host}, path => $mirror_path, ); $where = $self->_host_to_uri( %args ); } my $abs = $self->__file_fetch( from => $where, to => $local_path, verbose => $verbose ); ### we got a path back? if( $abs ) { ### store where we fetched it ### $modobj->status->fetch( $abs ); ### this host is good, the previous ones are apparently ### not, so mark them as such. $self->_add_fail_host( host => $_ ) for @maybe_bad_host; return $abs; } ### so we tried to get the file but didn't actually fetch it -- ### there's a chance this host is bad. mark it as such and ### actually flag it back if we manage to get the file ### somewhere else push @maybe_bad_host, $host; } } $found_host ? error(loc("Fetch failed: host list exhausted " . "-- are you connected today?")) : error(loc("No hosts found to download from " . "-- check your config")); } return; } sub __file_fetch { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my ($where, $local_path, $verbose); my $tmpl = { from => { required => 1, store => \$where }, to => { required => 1, store => \$local_path }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; check( $tmpl, \%hash ) or return; msg(loc("Trying to get '%1'", $where ), $verbose ); ### build the object ### my $ff = File::Fetch->new( uri => $where ); ### sanity check ### error(loc("Bad uri '%1'",$where)), return unless $ff; if( my $file = $ff->fetch( to => $local_path ) ) { unless( -e $file && -s _ ) { msg(loc("'%1' said it fetched '%2', but it was not created", 'File::Fetch', $file), $verbose); } else { my $abs = File::Spec->rel2abs( $file ); ### so TTLs will work $self->_update_timestamp( file => $abs ); return $abs; } } else { error(loc("Fetching of '%1' failed: %2", $where, $ff->error)); } return; } =pod =head2 _add_fail_host( host => $host_hashref ) Mark a particular host as bad. This makes C skip it in fetches until this cache is flushed. =head2 _host_ok( host => $host_hashref ) Query the cache to see if this host is ok, or if it has been flagged as bad. Returns true if the host is ok, false otherwise. =cut { ### caching functions ### sub _add_fail_host { my $self = shift; my %hash = @_; my $host; my $tmpl = { host => { required => 1, default => {}, strict_type => 1, store => \$host }, }; check( $tmpl, \%hash ) or return; return $self->_hosts->{$host} = 1; } sub _host_ok { my $self = shift; my %hash = @_; my $host; my $tmpl = { host => { required => 1, store => \$host }, }; check( $tmpl, \%hash ) or return; return $self->_hosts->{$host} ? 0 : 1; } } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/Search.pm0000644000175000017500000002754612251421370020074 0ustar bingosbingospackage CPANPLUS::Internals::Search; use strict; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use CPANPLUS::Module; use CPANPLUS::Module::Author; use File::Find; use File::Spec; use Params::Check qw[check allow]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; $Params::Check::VERBOSE = 1; =pod =head1 NAME CPANPLUS::Internals::Search - internals for searching for modules =head1 SYNOPSIS my $aref = $cpan->_search_module_tree( type => 'package', allow => [qr/DBI/], ); my $aref = $cpan->_search_author_tree( type => 'cpanid', data => \@old_results, verbose => 1, allow => [qw|KANE AUTRIJUS|], ); my $aref = $cpan->_all_installed( ); =head1 DESCRIPTION The functions in this module are designed to find module(objects) based on certain criteria and return them. =head1 METHODS =head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] ) Searches the moduletree for module objects matching the criteria you specify. Returns an array ref of module objects on success, and false on failure. It takes the following arguments: =over 4 =item type This can be any of the accessors for the C objects. This is a required argument. =item allow A set of rules, or more precisely, a list of regexes (via C or plain strings), that the C must adhere too. You can specify as many as you like, and it will be treated as an C search. For an C search, see the C argument. This is a required argument. =item data An arrayref of previous search results. This is the way to do an C search -- C<_search_module_tree> will only search the module objects specified in C if provided, rather than the moduletree itself. =back =cut # Although the Params::Check solution is more graceful, it is WAY too slow. # # This sample script: # # use CPANPLUS::Backend; # my $cb = new CPANPLUS::Backend; # $cb->module_tree; # my @list = $cb->search( type => 'module', allow => [qr/^Acme/] ); # print $_->module, $/ for @list; # # Produced the following output using Dprof WITH params::check code # # Total Elapsed Time = 3.670024 Seconds # User+System Time = 3.390373 Seconds # Exclusive Times # %Time ExclSec CumulS #Calls sec/call Csec/c Name # 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check # 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore # 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default # _gettext # 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it # 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check # 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve # 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case # 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs # 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs # 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key # 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq # 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear # ch_module_tree # 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey # 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error # 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ # # and this output /without/ # # Total Elapsed Time = 2.803426 Seconds # User+System Time = 2.493426 Seconds # Exclusive Times # %Time ExclSec CumulS #Calls sec/call Csec/c Name # 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore # 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve # 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ # 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear # ch_module_tree # 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN # 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN # 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN # 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN # 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN # 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file # 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN # 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN # 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN # 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH # 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc # sub _search_module_tree { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($mods,$list,$verbose,$type); my $tmpl = { data => { default => [], strict_type=> 1, store => \$mods }, allow => { required => 1, default => [ ], strict_type => 1, store => \$list }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, type => { required => 1, allow => [CPANPLUS::Module->accessors()], store => \$type }, }; my $args = do { ### don't check the template for sanity ### -- we know it's good and saves a lot of performance local $Params::Check::SANITY_CHECK_TEMPLATE = 0; check( $tmpl, \%hash ); } or return; ### a list of module objects was supplied if( @$mods ) { local $Params::Check::VERBOSE = 0; my @rv; for my $mod (@$mods) { #push @rv, $mod if check( # { $type => { allow => $list } }, # { $type => $mod->$type() } # ); push @rv, $mod if allow( $mod->$type() => $list ); } return \@rv; } else { my @rv = $self->_source_search_module_tree( allow => $list, type => $type, ); return \@rv; } } =pod =head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) Searches the authortree for author objects matching the criteria you specify. Returns an array ref of author objects on success, and false on failure. It takes the following arguments: =over 4 =item type This can be any of the accessors for the C objects. This is a required argument. =item allow A set of rules, or more precisely, a list of regexes (via C or plain strings), that the C must adhere too. You can specify as many as you like, and it will be treated as an C search. For an C search, see the C argument. This is a required argument. =item data An arrayref of previous search results. This is the way to do an C search -- C<_search_author_tree> will only search the author objects specified in C if provided, rather than the authortree itself. =back =cut sub _search_author_tree { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($authors,$list,$verbose,$type); my $tmpl = { data => { default => [], strict_type=> 1, store => \$authors }, allow => { required => 1, default => [ ], strict_type => 1, store => \$list }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()], store => \$type }, }; my $args = check( $tmpl, \%hash ) or return; if( @$authors ) { local $Params::Check::VERBOSE = 0; my @rv; for my $auth (@$authors) { #push @rv, $auth if check( # { $type => { allow => $list } }, # { $type => $auth->$type } # ); push @rv, $auth if allow( $auth->$type() => $list ); } return \@rv; } else { my @rv = $self->_source_search_author_tree( allow => $list, type => $type, ); return \@rv; } } =pod =head2 _all_installed() This function returns an array ref of module objects of modules that are installed on this system. =cut sub _all_installed { my $self = shift; my $conf = $self->configure_object; my %hash = @_; ### File::Find uses follow_skip => 1 by default, which doesn't die ### on duplicates, unless they are directories or symlinks. ### Ticket #29796 shows this code dying on Alien::WxWidgets, ### which uses symlinks. ### File::Find doc says to use follow_skip => 2 to ignore duplicates ### so this will stop it from dying. my %find_args = ( follow_skip => 2 ); ### File::Find uses lstat, which quietly becomes stat on win32 ### it then uses -l _ which is not allowed by the statbuffer because ### you did a stat, not an lstat (duh!). so don't tell win32 to ### follow symlinks, as that will break badly $find_args{'follow_fast'} = 1 unless ON_WIN32; ### never use the @INC hooks to find installed versions of ### modules -- they're just there in case they're not on the ### perl install, but the user shouldn't trust them for *other* ### modules! ### XXX CPANPLUS::inc is now obsolete, remove the calls #local @INC = CPANPLUS::inc->original_inc; my %seen; my @rv; for my $dir (@INC ) { next if $dir eq '.'; ### not a directory after all ### may be coderef or some such next unless -d $dir; ### make sure to clean up the directories just in case, ### as we're making assumptions about the length ### This solves rt.cpan issue #19738 ### John M. notes: On VMS cannonpath can not currently handle ### the $dir values that are in UNIX format. $dir = File::Spec->canonpath( $dir ) unless ON_VMS; ### have to use F::S::Unix on VMS, or things will break my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec'; ### XXX in some cases File::Find can actually die! ### so be safe and wrap it in an eval. eval { File::Find::find( { %find_args, wanted => sub { return unless /\.pm$/i; my $mod = $File::Find::name; ### make sure it's in Unix format, as it ### may be in VMS format on VMS; $mod = VMS::Filespec::unixify( $mod ) if ON_VMS; $mod = substr($mod, length($dir) + 1, -3); $mod = join '::', $file_spec->splitdir($mod); return if $seen{$mod}++; my $modobj = $self->module_tree($mod); ### separate return, a list context return with one '' ### in it, is also true! return unless $modobj; push @rv, $modobj; }, }, $dir ) }; ### report the error if file::find died error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@; } return \@rv; } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/Report.pm0000644000175000017500000005426412251421370020137 0ustar bingosbingospackage CPANPLUS::Internals::Report; use strict; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use CPANPLUS::Internals::Constants::Report; use Data::Dumper; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use version; use vars qw[$VERSION]; $VERSION = "0.9144"; $Params::Check::VERBOSE = 1; ### for the version ### require CPANPLUS::Internals; =head1 NAME CPANPLUS::Internals::Report - internals for sending test reports =head1 SYNOPSIS ### enable test reporting $cb->configure_object->set_conf( cpantest => 1 ); ### set custom mx host, shouldn't normally be needed $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' ); =head1 DESCRIPTION This module provides all the functionality to send test reports to C using the C module. All methods will be called automatically if you have C configured to enable test reporting (see the C). =head1 METHODS =head2 $bool = $cb->_have_query_report_modules This function checks if all the required modules are here for querying reports. It returns true and loads them if they are, or returns false otherwise. =head2 $bool = $cb->_have_send_report_modules This function checks if all the required modules are here for sending reports. It returns true and loads them if they are, or returns false otherwise. =cut ### XXX remove this list and move it into selfupdate, somehow.. ### this is dual administration { my $query_list = { 'File::Fetch' => '0.13_02', 'Parse::CPAN::Meta' => '0.0', 'File::Temp' => '0.0', }; my $send_list = { %$query_list, 'Test::Reporter' => '1.54', }; sub _have_query_report_modules { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my $tmpl = { verbose => { default => $conf->get_conf('verbose') }, }; my $args = check( $tmpl, \%hash ) or return; return can_load( modules => $query_list, verbose => $args->{verbose} ) ? 1 : 0; } sub _have_send_report_modules { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my $tmpl = { verbose => { default => $conf->get_conf('verbose') }, }; my $args = check( $tmpl, \%hash ) or return; return can_load( modules => $send_list, verbose => $args->{verbose} ) ? 1 : 0; } } =head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] ) This function queries the CPAN testers database at I for test results of specified module objects, module names or distributions. The optional argument C controls whether all versions of a given distribution should be grabbed. It defaults to false (fetching only reports for the current version). Returns the a list with the following data structures (for CPANPLUS version 0.042) on success, or false on failure. The contents of the data structure depends on what I returns, but generally looks like this: { 'grade' => 'PASS', 'dist' => 'CPANPLUS-0.042', 'platform' => 'i686-pld-linux-thread-multi' 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316' ... }, { 'grade' => 'PASS', 'dist' => 'CPANPLUS-0.042', 'platform' => 'i686-linux-thread-multi' 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416' ... }, { 'grade' => 'FAIL', 'dist' => 'CPANPLUS-0.042', 'platform' => 'cygwin-multi-64int', 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371' ... }, { 'grade' => 'FAIL', 'dist' => 'CPANPLUS-0.042', 'platform' => 'i586-linux', 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396' ... }, The status of the test can be one of the following: UNKNOWN, PASS, FAIL or NA (not applicable). =cut sub _query_report { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($mod, $verbose, $all); my $tmpl = { module => { required => 1, allow => IS_MODOBJ, store => \$mod }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, all_versions => { default => 0, store => \$all }, }; check( $tmpl, \%hash ) or return; ### check if we have the modules we need for querying return unless $self->_have_query_report_modules( verbose => 1 ); ### XXX no longer use LWP here. However, that means we don't ### automagically set proxies anymore!!! # my $ua = LWP::UserAgent->new; # $ua->agent( CPANPLUS_UA->() ); # ### set proxies if we have them ### # $ua->env_proxy(); my $url = TESTERS_URL->($mod->package_name); my $ff = File::Fetch->new( uri => $url ); msg( loc("Fetching: '%1'", $url), $verbose ); my $res = do { my $tempdir = File::Temp::tempdir(); my $where = $ff->fetch( to => $tempdir ); unless( $where ) { error( loc( "Fetching report for '%1' failed: %2", $url, $ff->error ) ); return; } my $fh = OPEN_FILE->( $where ); do { local $/; <$fh> }; }; my ($aref) = eval { Parse::CPAN::Meta::Load( $res ) }; if( $@ ) { error(loc("Error reading result: %1", $@)); return; }; my $dist = $mod->package_name .'-'. $mod->package_version; my $details = TESTERS_DETAILS_URL->($mod->package_name); my @rv; for my $href ( @$aref ) { next unless $all or defined $href->{'distversion'} && $href->{'distversion'} eq $dist; $href->{'details'} = $details; ### backwards compatibility :( $href->{'dist'} ||= $href->{'distversion'}; $href->{'grade'} ||= $href->{'action'} || $href->{'status'}; push @rv, $href; } return @rv if @rv; return; } =pod =head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]); This function sends a testers report to C for a particular distribution. It returns true on success, and false on failure. It takes the following options: =over 4 =item module The module object of this particular distribution =item buffer The output buffer from the 'make/make test' process =item failed Boolean indicating if the 'make/make test' went wrong =item save Boolean indicating if the report should be saved locally instead of mailed out. If provided, this function will return the location the report was saved to, rather than a simple boolean 'TRUE'. Defaults to false. =item address The email address to mail the report for. You should never need to override this, but it might be useful for debugging purposes. Defaults to C. =item verbose Boolean indicating on whether or not to be verbose. Defaults to your configuration settings =item force Boolean indicating whether to force the sending, even if the max amount of reports for fails have already been reached, or if you may already have sent it before. Defaults to your configuration settings =back =cut sub _send_report { my $self = shift; my $conf = $self->configure_object; my %hash = @_; ### do you even /have/ test::reporter? ### unless( $self->_have_send_report_modules(verbose => 1) ) { error( loc( "You don't have '%1' (or modules required by '%2') ". "installed, you cannot report test results.", 'Test::Reporter', 'Test::Reporter' ) ); return; } ### check arguments ### my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $tests_skipped, $status ); my $tmpl = { module => { required => 1, store => \$mod, allow => IS_MODOBJ }, buffer => { required => 1, store => \$buffer }, failed => { required => 1, store => \$failed }, status => { default => {}, store => \$status, strict_type => 1 }, address => { default => CPAN_TESTERS_EMAIL, store => \$address }, save => { default => 0, store => \$save }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, force => { default => $conf->get_conf('force'), store => \$force }, tests_skipped => { default => 0, store => \$tests_skipped }, }; check( $tmpl, \%hash ) or return; ### get the data to fill the email with ### my $name = $mod->module; my $dist = $mod->package_name . '-' . $mod->package_version; my $author = $mod->author->author; my $distfile= $mod->author->cpanid . "/" . $mod->package; my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); my $cp_conf = $conf->get_conf('cpantest') || ''; my $int_ver = $CPANPLUS::Internals::VERSION; my $cb = $mod->parent; ### will be 'fetch', 'make', 'test', 'install', etc ### my $stage = TEST_FAIL_STAGE->($buffer); ### determine the grade now ### my $grade; ### check if this is a platform specific module ### ### if we failed the test, there may be reasons why ### an 'NA' might have to be instead GRADE: { if ( $failed ) { ### XXX duplicated logic between this block ### and REPORTED_LOADED_PREREQS :( ### figure out if the prereqs are on CPAN at all ### -- if not, send NA grade ### Also, if our version of prereqs is too low, ### -- send NA grade. ### This is to address bug: #25327: do not count ### as FAIL modules where prereqs are not filled { my $prq = $mod->status->prereqs || {}; PREREQ: while( my($prq_name,$prq_ver) = each %$prq ) { # 'perl' listed as prereq if ( $prq_name eq 'perl' ) { my $req_ver = eval { version->new( $prq_ver ) }; next PREREQ unless $req_ver; if ( version->new( $] ) < $req_ver ) { msg(loc("'%1' requires a higher version of perl than your current ". "version -- sending N/A grade.", $name), $verbose); $grade = GRADE_NA; last GRADE; } next PREREQ; } my $obj = $cb->module_tree( $prq_name ); my $sub = CPANPLUS::Module->can( 'module_is_supplied_with_perl_core' ); ### if we can't find the module and it's not supplied with core. ### this addresses: #32064: NA reports generated for failing ### tests where core prereqs are specified ### Note that due to a bug in Module::CoreList, in some released ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing) ### 'Config' is not recognized as a core module. See this bug: ### http://rt.cpan.org/Ticket/Display.html?id=32155 if( !$obj and !defined $sub->( $prq_name ) ) { msg(loc( "Prerequisite '%1' for '%2' could not be obtained". " from CPAN -- sending N/A grade", $prq_name, $name ), $verbose ); $grade = GRADE_NA; last GRADE; } if ( !$obj ) { my $vcore = $sub->( $prq_name ); if ( $cb->_vcmp( $prq_ver, $vcore ) > 0 ) { msg(loc( "Version of core module '%1' ('%2') is too low for ". "'%3' (needs '%4') -- sending N/A grade", $prq_name, $vcore, $name, $prq_ver ), $verbose ); $grade = GRADE_NA; last GRADE; } } if( $obj and $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) { msg(loc( "Installed version of '%1' ('%2') is too low for ". "'%3' (needs '%4') -- sending N/A grade", $prq_name, $obj->installed_version, $name, $prq_ver ), $verbose ); $grade = GRADE_NA; last GRADE; } } } unless( RELEVANT_TEST_RESULT->($mod) ) { msg(loc( "'%1' is a platform specific module, and the test results on". " your platform are not relevant --sending N/A grade.", $name), $verbose); $grade = GRADE_NA; } elsif ( UNSUPPORTED_OS->( $buffer ) ) { msg(loc( "'%1' is a platform specific module, and the test results on". " your platform are not relevant --sending N/A grade.", $name), $verbose); $grade = GRADE_NA; ### you don't have a high enough perl version? } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) { msg(loc("'%1' requires a higher version of perl than your current ". "version -- sending N/A grade.", $name), $verbose); $grade = GRADE_NA; ### perhaps where were no tests... ### see if the thing even had tests ### } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { $grade = GRADE_UNKNOWN; ### failures in PL or make/build stage are now considered UNKNOWN } elsif ( $stage !~ /\btest\b/ ) { $grade = GRADE_UNKNOWN } else { $grade = GRADE_FAIL; } ### if we got here, it didn't fail and tests were present.. so a PASS ### is in order } else { $grade = GRADE_PASS; } } ### so an error occurred, let's see what stage it went wrong in ### ### the header -- always include so the CPANPLUS version is apparent my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author ); if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) { ### return if one or more missing external libraries if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) { msg(loc("Not sending test report - " . "external libraries not pre-installed")); return 1; } ### return if we're only supposed to report make_test failures ### return 1 if $cp_conf =~ /\bmaketest_only\b/i and ($stage !~ /\btest\b/); my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer ); ### the bit where we inform what went wrong $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture ); ### was it missing prereqs? ### if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { if(!$self->_verify_missing_prereqs( module => $mod, missing => \@missing )) { msg(loc("Not sending test report - " . "bogus missing prerequisites report")); return 1; } $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); } ### was it missing test files? ### if( NO_TESTS_DEFINED->($buffer) ) { $message .= REPORT_MISSING_TESTS->(); } ### add a list of what modules have been loaded of your prereqs list $message .= REPORT_LOADED_PREREQS->($mod); ### add a list of versions of toolchain modules $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); ### the footer $message .= REPORT_MESSAGE_FOOTER->(); ### it may be another grade than fail/unknown.. may be worth noting ### that tests got skipped, since the buffer is not added in } elsif ( $tests_skipped ) { $message .= REPORT_TESTS_SKIPPED->(); } elsif( $grade eq GRADE_NA) { my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer ); ### add the reason for the NA to the buffer $capture = join $/, $capture, map { '[' . $_->tag . '] [' . $_->when . '] ' . $_->message } ( CPANPLUS::Error->stack )[-1]; ### the bit where we inform what went wrong $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture ); ### add a list of what modules have been loaded of your prereqs list $message .= REPORT_LOADED_PREREQS->($mod); ### add a list of versions of toolchain modules $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); ### the footer $message .= REPORT_MESSAGE_FOOTER->(); } elsif ( $grade eq GRADE_PASS and ( $status and defined $status->{capture} ) ) { ### the bit where we inform what went right $message .= REPORT_MESSAGE_PASS_HEADER->( $stage, $status->{capture} ); ### add a list of what modules have been loaded of your prereqs list $message .= REPORT_LOADED_PREREQS->($mod); ### add a list of versions of toolchain modules $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); ### the footer $message .= REPORT_MESSAGE_FOOTER->(); } msg( loc("Sending test report for '%1'", $dist), $verbose); ### reporter object ### my $reporter = do { my $args = $conf->get_conf('cpantest_reporter_args') || {}; unless( UNIVERSAL::isa( $args, 'HASH' ) ) { error(loc("'%1' must be a hashref, ignoring...", 'cpantest_reporter_args')); $args = {}; } Test::Reporter->new( grade => $grade, distribution => $dist, distfile => $distfile, via => "CPANPLUS $int_ver", timeout => $conf->get_conf('timeout') || 60, debug => $conf->get_conf('debug'), %$args, ); }; ### set a custom mx, if requested $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) if $conf->get_conf('cpantest_mx'); ### set the from address ### $reporter->from( $conf->get_conf('email') ) if $conf->get_conf('email') !~ /\@example\.\w+$/i; ### give the user a chance to programmatically alter the message $message = $self->_callbacks->munge_test_report->($mod, $message, $grade); ### add the body if we have any ### $reporter->comments( $message ) if defined $message && length $message; ### do a callback to ask if we should send the report unless ($self->_callbacks->send_test_report->($mod, $grade)) { msg(loc("Ok, not sending test report")); return 1; } ### do a callback to ask if we should edit the report if ($self->_callbacks->edit_test_report->($mod, $grade)) { ### test::reporter 1.20 and lower don't have a way to set ### the preferred editor with a method call, but it does ### respect your env variable, so let's set that. local $ENV{VISUAL} = $conf->get_program('editor') if $conf->get_program('editor'); $reporter->edit_comments; } ### allow to be overridden, but default to the normal address ### $reporter->address( $address ); ### should we save it locally? ### if( $save ) { if( my $file = $reporter->write() ) { msg(loc("Successfully wrote report for '%1' to '%2'", $dist, $file), $verbose); return $file; } else { error(loc("Failed to write report for '%1'", $dist)); return; } ### XXX should we do an 'already sent' check? ### ### something broke :( ### } else { my $status; eval { $status = $reporter->send(); }; if ( $@ ) { error(loc("Could not send '%1' report for '%2': %3", $grade, $dist, $@)); return; } if ( $status ) { msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist), $verbose); return 1; } error(loc("Could not send '%1' report for '%2': %3", $grade, $dist, $reporter->errstr)); return; } } sub _verify_missing_prereqs { my $self = shift; my %hash = @_; ### check arguments ### my ($mod, $missing); my $tmpl = { module => { required => 1, store => \$mod }, missing => { required => 1, store => \$missing }, }; check( $tmpl, \%hash ) or return; my %missing = map {$_ => 1} @$missing; my $conf = $self->configure_object; my $extract = $mod->status->extract; ### Read pre-requisites from Makefile.PL or Build.PL (if there is one), ### of the form: ### 'PREREQ_PM' => { ### 'Compress::Zlib' => '1.20', ### 'Test::More' => 0, ### }, ### Build.PL uses 'requires' instead of 'PREREQ_PM'. my @search; push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->()); push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->()); for my $file ( @search ) { if(-e $file and -r $file) { my $slurp = $self->_get_file_contents(file => $file); my ($prereq) = ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s); my @prereq = ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg); delete $missing{$_} for(@prereq); } } return 1 if(keys %missing); # There ARE missing prerequisites return; # All prerequisites accounted for } 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Internals/Source/0000755000175000017500000000000012251422462017556 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Internals/Source/SQLite.pm0000644000175000017500000002301612251421370021254 0ustar bingosbingospackage CPANPLUS::Internals::Source::SQLite; use strict; use warnings; use base 'CPANPLUS::Internals::Source'; use CPANPLUS::Error; use CPANPLUS::Internals::Constants; use CPANPLUS::Internals::Source::SQLite::Tie; use Data::Dumper; use DBIx::Simple; use DBD::SQLite; use Params::Check qw[allow check]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; use constant TXN_COMMIT => 1000; =head1 NAME CPANPLUS::Internals::Source::SQLite - SQLite implementation =cut { my $Dbh; my $DbFile; sub __sqlite_file { return $DbFile if $DbFile; my $self = shift; my $conf = $self->configure_object; $DbFile = File::Spec->catdir( $conf->get_conf('base'), SOURCE_SQLITE_DB ); return $DbFile; }; sub __sqlite_dbh { return $Dbh if $Dbh; my $self = shift; $Dbh = DBIx::Simple->connect( "dbi:SQLite:dbname=" . $self->__sqlite_file, '', '', { AutoCommit => 1 } ); #$Dbh->dbh->trace(1); $Dbh->query(qq{PRAGMA synchronous = OFF}); return $Dbh; }; sub __sqlite_disconnect { return unless $Dbh; $Dbh->disconnect; $Dbh = undef; return; } } { my $used_old_copy = 0; sub _init_trees { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($path,$uptodate,$verbose,$use_stored); my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, uptodate => { required => 1, store => \$uptodate }, use_stored => { default => 1, store => \$use_stored }, }; check( $tmpl, \%hash ) or return; ### if it's not uptodate, or the file doesn't exist, we need to create ### a new sqlite db if( not $uptodate or not -e $self->__sqlite_file ) { $used_old_copy = 0; ### chuck the file $self->__sqlite_disconnect; 1 while unlink $self->__sqlite_file; ### and create a new one $self->__sqlite_create_db or do { error(loc("Could not create new SQLite DB")); return; } } else { $used_old_copy = 1; } ### set up the author tree { my %at; tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie', dbh => $self->__sqlite_dbh, table => 'author', key => 'cpanid', cb => $self; $self->_atree( \%at ); } ### set up the author tree { my %mt; tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie', dbh => $self->__sqlite_dbh, table => 'module', key => 'module', cb => $self; $self->_mtree( \%mt ); } ### start a transaction $self->__sqlite_dbh->query('BEGIN'); return 1; } sub _standard_trees_completed { return $used_old_copy } sub _custom_trees_completed { return } ### finish transaction sub _finalize_trees { $_[0]->__sqlite_dbh->commit; return 1 } ### saves current memory state, but not implemented in sqlite sub _save_state { error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); return; } } { my $txn_count = 0; ### XXX move this outside the sub, so we only compute it once my $class; my @keys = qw[ author cpanid email ]; my $tmpl = { class => { default => 'CPANPLUS::Module::Author', store => \$class }, map { $_ => { required => 1 } } @keys }; ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually my $ph = join ',', map { '?' } @keys; sub _add_author_object { my $self = shift; my %hash = @_; my $dbh = $self->__sqlite_dbh; my $href = do { local $Params::Check::NO_DUPLICATES = 1; local $Params::Check::SANITY_CHECK_TEMPLATE = 0; check( $tmpl, \%hash ) or return; }; ### keep counting how many we inserted unless( ++$txn_count % TXN_COMMIT ) { #warn "Committing transaction $txn_count"; $dbh->commit or error( $dbh->error ); # commit previous transaction $dbh->begin_work or error( $dbh->error ); # and start a new one } $dbh->query( "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", values %$href ) or do { error( $dbh->error ); return; }; return 1; } } { my $txn_count = 0; ### XXX move this outside the sub, so we only compute it once my $class; my @keys = qw[ module version path comment author package description dslip mtime ]; my $tmpl = { class => { default => 'CPANPLUS::Module', store => \$class }, map { $_ => { required => 1 } } @keys }; ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually my $ph = join ',', map { '?' } @keys; sub _add_module_object { my $self = shift; my %hash = @_; my $dbh = $self->__sqlite_dbh; my $href = do { local $Params::Check::NO_DUPLICATES = 1; local $Params::Check::SANITY_CHECK_TEMPLATE = 0; check( $tmpl, \%hash ) or return; }; ### fix up author to be 'plain' string $href->{'author'} = $href->{'author'}->cpanid; ### keep counting how many we inserted unless( ++$txn_count % TXN_COMMIT ) { #warn "Committing transaction $txn_count"; $dbh->commit or error( $dbh->error ); # commit previous transaction $dbh->begin_work or error( $dbh->error ); # and start a new one } $dbh->query( "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)", values %$href ) or do { error( $dbh->error ); return; }; return 1; } } { my %map = ( _source_search_module_tree => [ module => module => 'CPANPLUS::Module' ], _source_search_author_tree => [ author => cpanid => 'CPANPLUS::Module::Author' ], ); while( my($sub, $aref) = each %map ) { no strict 'refs'; my($table, $key, $class) = @$aref; *$sub = sub { my $self = shift; my %hash = @_; my($list,$type); my $tmpl = { allow => { required => 1, default => [ ], strict_type => 1, store => \$list }, type => { required => 1, allow => [$class->accessors()], store => \$type }, }; check( $tmpl, \%hash ) or return; ### we aliased 'module' to 'name', so change that here too $type = 'module' if $type eq 'name'; my $meth = $table .'_tree'; { my $throw = $self->$meth; } my $dbh = $self->__sqlite_dbh; my $res = $dbh->query( "SELECT * from $table" ); my @rv = map { $self->$meth( $_->{$key} ) } grep { allow( $_->{$type} => $list ) } $res->hashes; return @rv; } } } sub __sqlite_create_db { my $self = shift; my $dbh = $self->__sqlite_dbh; ### we can ignore the result/error; not all sqlite implementations ### support this $dbh->query( qq[ DROP TABLE IF EXISTS author; \n] ) or do { msg( $dbh->error ); }; $dbh->query( qq[ DROP TABLE IF EXISTS module; \n] ) or do { msg( $dbh->error ); }; $dbh->query( qq[ /* the author information */ CREATE TABLE author ( id INTEGER PRIMARY KEY AUTOINCREMENT, author varchar(255), email varchar(255), cpanid varchar(255) ); \n] ) or do { error( $dbh->error ); return; }; $dbh->query( qq[ /* the module information */ CREATE TABLE module ( id INTEGER PRIMARY KEY AUTOINCREMENT, module varchar(255), version varchar(255), path varchar(255), comment varchar(255), author varchar(255), package varchar(255), description varchar(255), dslip varchar(255), mtime varchar(255) ); \n] ) or do { error( $dbh->error ); return; }; $dbh->query( qq[ /* the module index */ CREATE INDEX IX_module_module ON module ( module ); \n] ) or do { error( $dbh->error ); return; }; $dbh->query( qq[ /* the version index */ CREATE INDEX IX_module_version ON module ( version ); \n] ) or do { error( $dbh->error ); return; }; $dbh->query( qq[ /* the module-version index */ CREATE INDEX IX_module_module_version ON module ( module, version ); \n] ) or do { error( $dbh->error ); return; }; return 1; } 1; CPANPLUS-0.9144/lib/CPANPLUS/Internals/Source/Memory.pm0000644000175000017500000002425612251421370021372 0ustar bingosbingospackage CPANPLUS::Internals::Source::Memory; use base 'CPANPLUS::Internals::Source'; use strict; use CPANPLUS::Error; use CPANPLUS::Module; use CPANPLUS::Module::Fake; use CPANPLUS::Module::Author; use CPANPLUS::Internals::Constants; use File::Fetch; use Archive::Extract; use IPC::Cmd qw[can_run]; use File::Temp qw[tempdir]; use File::Basename qw[dirname]; use Params::Check qw[allow check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[$VERSION]; $VERSION = "0.9144"; $Params::Check::VERBOSE = 1; =head1 NAME CPANPLUS::Internals::Source::Memory - In memory implementation =cut ### flag to show if init_trees got its' data from storable. This allows ### us to not write an existing stored file back to disk { my $from_storable; sub _init_trees { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($path,$uptodate,$verbose,$use_stored); my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, uptodate => { required => 1, store => \$uptodate }, use_stored => { default => 1, store => \$use_stored }, }; check( $tmpl, \%hash ) or return; ### retrieve the stored source files ### my $stored = $self->__memory_retrieve_source( path => $path, uptodate => $uptodate && $use_stored, verbose => $verbose, ) || {}; ### we got this from storable if $stored has keys.. $from_storable = keys %$stored ? 1 : 0; ### set up the trees $self->_atree( $stored->{_atree} || {} ); $self->_mtree( $stored->{_mtree} || {} ); return 1; } sub _standard_trees_completed { return $from_storable } sub _custom_trees_completed { return $from_storable } sub _finalize_trees { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($path,$uptodate,$verbose); my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, uptodate => { required => 1, store => \$uptodate }, }; { local $Params::Check::ALLOW_UNKNOWN = 1; check( $tmpl, \%hash ) or return; } ### write the stored files to disk, so we can keep using them ### from now on, till they become invalid ### write them if the original sources weren't uptodate, or ### we didn't just load storable files $self->__memory_save_source() if !$uptodate or not $from_storable; return 1; } ### saves current memory state sub _save_state { my $self = shift; return $self->_finalize_trees( @_, uptodate => 0 ); } } sub _add_author_object { my $self = shift; my %hash = @_; my $class; my $tmpl = { class => { default => 'CPANPLUS::Module::Author', store => \$class }, map { $_ => { required => 1 } } qw[ author cpanid email ] }; my $href = do { local $Params::Check::NO_DUPLICATES = 1; check( $tmpl, \%hash ) or return; }; my $obj = $class->new( %$href, _id => $self->_id ); $self->author_tree->{ $href->{'cpanid'} } = $obj or return; return $obj; } { my $tmpl = { class => { default => 'CPANPLUS::Module' }, map { $_ => { required => 1 } } qw[ module version path comment author package description dslip mtime ], }; sub _add_module_object { my $self = shift; my %hash = @_; my $href = do { local $Params::Check::SANITY_CHECK_TEMPLATE = 0; check( $tmpl, \%hash ) or return; }; my $class = delete $href->{class}; my $obj = $class->new( %$href, _id => $self->_id ); ### Every module get's stored as a module object ### $self->module_tree->{ $href->{module} } = $obj or return; return $obj; } } { my %map = ( _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ], _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ], ); while( my($sub, $aref) = each %map ) { no strict 'refs'; my($meth, $class) = @$aref; *$sub = sub { my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($authors,$list,$verbose,$type); my $tmpl = { data => { default => [], strict_type=> 1, store => \$authors }, allow => { required => 1, default => [ ], strict_type => 1, store => \$list }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, type => { required => 1, allow => [$class->accessors()], store => \$type }, }; my $args = check( $tmpl, \%hash ) or return; my @rv; for my $obj ( values %{ $self->$meth } ) { #push @rv, $auth if check( # { $type => { allow => $list } }, # { $type => $auth->$type } # ); push @rv, $obj if allow( $obj->$type() => $list ); } return @rv; } } } =pod =head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) This method retrieves a Id tree identified by C<$name>. It takes the following arguments: =over 4 =item name The internal name for the source file to retrieve. =item uptodate A flag indicating whether the file-cache is up-to-date or not. =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =back Will get information from the config file by default. Returns a tree on success, false on failure. =cut sub __memory_retrieve_source { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $tmpl = { path => { default => $conf->get_conf('base') }, verbose => { default => $conf->get_conf('verbose') }, uptodate => { default => 0 }, }; my $args = check( $tmpl, \%hash ) or return; ### check if we can retrieve a frozen data structure with storable ### my $storable = can_load( modules => {'Storable' => '0.0'} ) if $conf->get_conf('storable'); return unless $storable; ### $stored is the name of the frozen data structure ### my $stored = $self->__memory_storable_file( $args->{path} ); if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); my $href = Storable::retrieve($stored); return $href; } else { return; } } =pod =head2 $cb->__memory_save_source([verbose => BOOL, path => $path]) This method saves all the parsed trees in Id format if C is available. It takes the following arguments: =over 4 =item path The absolute path to the directory holding the source files. =item verbose A boolean flag indicating whether or not to be verbose. =back Will get information from the config file by default. Returns true on success, false on failure. =cut sub __memory_save_source { my $self = shift; my %hash = @_; my $conf = $self->configure_object; my $tmpl = { path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, verbose => { default => $conf->get_conf('verbose') }, force => { default => 1 }, }; my $args = check( $tmpl, \%hash ) or return; my $aref = [qw[_mtree _atree]]; ### check if we can retrieve a frozen data structure with storable ### my $storable; $storable = can_load( modules => {'Storable' => '0.0'} ) if $conf->get_conf('storable'); return unless $storable; my $to_write = {}; foreach my $key ( @$aref ) { next unless ref( $self->$key ); $to_write->{$key} = $self->$key; } return unless keys %$to_write; ### $stored is the name of the frozen data structure ### my $stored = $self->__memory_storable_file( $args->{path} ); if (-e $stored && not -w $stored) { msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); return; } msg( loc("Writing compiled source information to disk. This might take a little while."), $args->{'verbose'} ); my $flag; unless( Storable::nstore( $to_write, $stored ) ) { error( loc("could not store %1!", $stored) ); $flag++; } return $flag ? 0 : 1; } sub __memory_storable_file { my $self = shift; my $conf = $self->configure_object; my $path = shift or return; ### check if we can retrieve a frozen data structure with storable ### my $storable = $conf->get_conf('storable') ? can_load( modules => {'Storable' => '0.0'} ) : 0; return unless $storable; ### $stored is the name of the frozen data structure ### ### changed to use File::Spec->catfile -jmb my $stored = File::Spec->rel2abs( File::Spec->catfile( $path, #base dir $conf->_get_source('stored') #file . '.s' . $Storable::VERSION #the version of storable . '.c' . $self->VERSION #the version of CPANPLUS . STORABLE_EXT #append a suffix ) ); return $stored; } # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: 1; CPANPLUS-0.9144/lib/CPANPLUS/Internals/Source/SQLite/0000755000175000017500000000000012251422462020717 5ustar bingosbingosCPANPLUS-0.9144/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm0000644000175000017500000000572612251421370022005 0ustar bingosbingospackage CPANPLUS::Internals::Source::SQLite::Tie; use strict; use warnings; use CPANPLUS::Error; use CPANPLUS::Module; use CPANPLUS::Module::Fake; use CPANPLUS::Module::Author::Fake; use CPANPLUS::Internals::Constants; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use vars qw[@ISA $VERSION]; $VERSION = "0.9144"; require Tie::Hash; push @ISA, 'Tie::StdHash'; sub TIEHASH { my $class = shift; my %hash = @_; my $tmpl = { dbh => { required => 1 }, table => { required => 1 }, key => { required => 1 }, cb => { required => 1 }, offset => { default => 0 }, }; my $args = check( $tmpl, \%hash ) or return; my $obj = bless { %$args, store => {} } , $class; return $obj; } sub FETCH { my $self = shift; my $key = shift or return; my $dbh = $self->{dbh}; my $cb = $self->{cb}; my $table = $self->{table}; ### did we look this one up before? if( my $obj = $self->{store}->{$key} ) { return $obj; } my $res = $dbh->query( "SELECT * from $table where $self->{key} = ?", $key ) or do { error( $dbh->error ); return; }; my $href = $res->hash; ### get rid of the primary key delete $href->{'id'}; ### no results? return unless keys %$href; ### expand author if needed ### XXX no longer generic :( if( $table eq 'module' ) { $href->{author} = $cb->author_tree( $href->{author } ) or return; } my $class = { module => 'CPANPLUS::Module', author => 'CPANPLUS::Module::Author', }->{ $table }; my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); return $obj; } sub STORE { my $self = shift; my $key = shift; my $val = shift; $self->{store}->{$key} = $val; } 1; sub FIRSTKEY { my $self = shift; my $dbh = $self->{'dbh'}; my $res = $dbh->query( "select $self->{key} from $self->{table} order by $self->{key} limit 1" ); $self->{offset} = 0; my $key = $res->flat->[0]; return $key; } sub NEXTKEY { my $self = shift; my $dbh = $self->{'dbh'}; my $res = $dbh->query( "select $self->{key} from $self->{table} ". "order by $self->{key} limit 1 offset $self->{offset}" ); $self->{offset} +=1; my $key = $res->flat->[0]; my $val = $self->FETCH( $key ); ### use each() semantics return wantarray ? ( $key, $val ) : $key; } sub EXISTS { !!$_[0]->FETCH( $_[1] ) } sub SCALAR { my $self = shift; my $dbh = $self->{'dbh'}; my $res = $dbh->query( "select count(*) from $self->{table}" ); return $res->flat; } ### intentionally left blank sub DELETE { } sub CLEAR { } CPANPLUS-0.9144/lib/CPANPLUS/Internals/Constants.pm0000644000175000017500000004072012251421370020630 0ustar bingosbingospackage CPANPLUS::Internals::Constants; use strict; use CPANPLUS::Error; use Config; use File::Spec; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; require Exporter; use vars qw[$VERSION @ISA @EXPORT]; use Package::Constants; $VERSION = "0.9144"; @ISA = qw[Exporter]; @EXPORT = Package::Constants->list( __PACKAGE__ ); sub constants { @EXPORT }; use constant INSTALLER_BUILD => 'CPANPLUS::Dist::Build'; use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; use constant INSTALLER_SAMPLE => 'CPANPLUS::Dist::Sample'; use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; use constant INSTALLER_AUTOBUNDLE => 'CPANPLUS::Dist::Autobundle'; use constant SHELL_DEFAULT => 'CPANPLUS::Shell::Default'; use constant SHELL_CLASSIC => 'CPANPLUS::Shell::Classic'; use constant CONFIG => 'CPANPLUS::Config'; use constant CONFIG_USER => 'CPANPLUS::Config::User'; use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System'; use constant CONFIG_BOXED => 'CPANPLUS::Config::Boxed'; use constant DEFAULT_SOURCE_ENGINE => 'CPANPLUS::Internals::Source::Memory'; use constant TARGET_INIT => 'init'; use constant TARGET_CREATE => 'create'; use constant TARGET_PREPARE => 'prepare'; use constant TARGET_INSTALL => 'install'; use constant TARGET_IGNORE => 'ignore'; use constant ON_WIN32 => $^O eq 'MSWin32'; use constant ON_NETWARE => $^O eq 'NetWare'; use constant ON_CYGWIN => $^O eq 'cygwin'; use constant ON_VMS => $^O eq 'VMS'; use constant DOT_CPANPLUS => ON_VMS ? '_cpanplus' : '.cpanplus'; use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush'; use constant UNKNOWN_DL_LOCATION => 'UNKNOWN-ORIGIN'; use constant NMAKE => 'nmake.exe'; use constant NMAKE_URL => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe'; use constant INSTALL_VIA_PACKAGE_MANAGER => sub { my $fmt = $_[0] or return; return 1 if $fmt ne INSTALLER_BUILD and $fmt ne INSTALLER_MM; }; use constant IS_CODEREF => sub { ref $_[-1] eq 'CODE' }; use constant IS_MODOBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Module') }; use constant IS_FAKE_MODOBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Module::Fake') }; use constant IS_AUTHOBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Module::Author') }; use constant IS_FAKE_AUTHOBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Module::Author::Fake') }; use constant IS_CONFOBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Configure') }; use constant IS_RVOBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Backend::RV') }; use constant IS_INTERNALS_OBJ => sub { UNIVERSAL::isa($_[-1], 'CPANPLUS::Internals') }; use constant IS_FILE => sub { return 1 if -e $_[-1] }; use constant FILE_EXISTS => sub { my $file = $_[-1]; return 1 if IS_FILE->($file); local $Carp::CarpLevel = $Carp::CarpLevel+2; error(loc( q[File '%1' does not exist], $file)); return; }; use constant FILE_READABLE => sub { my $file = $_[-1]; return 1 if -e $file && -r _; local $Carp::CarpLevel = $Carp::CarpLevel+2; error( loc( q[File '%1' is not readable ]. q[or does not exist], $file)); return; }; use constant IS_DIR => sub { return 1 if -d $_[-1] }; use constant DIR_EXISTS => sub { my $dir = $_[-1]; return 1 if IS_DIR->($dir); local $Carp::CarpLevel = $Carp::CarpLevel+2; error(loc(q[Dir '%1' does not exist], $dir)); return; }; ### On VMS, if the $Config{make} is either MMK ### or MMS, then the makefile is 'DESCRIP.MMS'. use constant MAKEFILE => sub { my $file = (ON_VMS and $Config::Config{make} =~ /MM[S|K]/i) ? 'DESCRIP.MMS' : 'Makefile'; return @_ ? File::Spec->catfile( @_, $file ) : $file; }; use constant MAKEFILE_PL => sub { return @_ ? File::Spec->catfile( @_, 'Makefile.PL' ) : 'Makefile.PL'; }; use constant BUILD_PL => sub { return @_ ? File::Spec->catfile( @_, 'Build.PL' ) : 'Build.PL'; }; use constant META_YML => sub { return @_ ? File::Spec->catfile( @_, 'META.yml' ) : 'META.yml'; }; use constant MYMETA_YML => sub { return @_ ? File::Spec->catfile( @_, 'MYMETA.yml' ) : 'MYMETA.yml'; }; use constant META_JSON => sub { return @_ ? File::Spec->catfile( @_, 'META.json' ) : 'META.json'; }; use constant MYMETA_JSON => sub { return @_ ? File::Spec->catfile( @_, 'MYMETA.json' ) : 'MYMETA.json'; }; use constant BLIB => sub { return @_ ? File::Spec->catfile(@_, 'blib') : 'blib'; }; use constant LIB => 'lib'; use constant LIB_DIR => sub { return @_ ? File::Spec->catdir(@_, LIB) : LIB; }; use constant AUTO => 'auto'; use constant LIB_AUTO_DIR => sub { return @_ ? File::Spec->catdir(@_, LIB, AUTO) : File::Spec->catdir(LIB, AUTO) }; use constant ARCH => 'arch'; use constant ARCH_DIR => sub { return @_ ? File::Spec->catdir(@_, ARCH) : ARCH; }; use constant ARCH_AUTO_DIR => sub { return @_ ? File::Spec->catdir(@_,ARCH,AUTO) : File::Spec->catdir(ARCH,AUTO) }; use constant BLIB_LIBDIR => sub { return @_ ? File::Spec->catdir( @_, BLIB->(), LIB ) : File::Spec->catdir( BLIB->(), LIB ); }; use constant BIN => 'bin'; use constant SCRIPT => 'script'; use constant CONFIG_USER_LIB_DIR => sub { require CPANPLUS::Internals::Utils; LIB_DIR->( CPANPLUS::Internals::Utils->_home_dir, DOT_CPANPLUS ); }; use constant CONFIG_USER_FILE => sub { File::Spec->catfile( CONFIG_USER_LIB_DIR->(), split('::', CONFIG_USER), ) . '.pm'; }; use constant CONFIG_SYSTEM_FILE => sub { require CPANPLUS::Internals; require File::Basename; my $dir = File::Basename::dirname( $INC{'CPANPLUS/Internals.pm'} ); ### XXX use constants File::Spec->catfile( $dir, qw[Config System.pm] ); }; use constant README => sub { my $obj = $_[0]; my $pkg = $obj->package_name; $pkg .= '-' . $obj->package_version . '.readme'; return $pkg; }; use constant META_EXT => 'meta'; use constant META => sub { my $obj = $_[0]; my $pkg = $obj->package_name; $pkg .= '-' . $obj->package_version . '.' . META_EXT; return $pkg; }; use constant OPEN_FILE => sub { my($file, $mode) = (@_, ''); my $fh; open $fh, "$mode" . $file or error(loc( "Could not open file '%1': %2", $file, $!)); return $fh if $fh; return; }; use constant OPEN_DIR => sub { my $dir = shift; my $dh; opendir $dh, $dir or error(loc( "Could not open dir '%1': %2", $dir, $! )); return $dh if $dh; return; }; use constant READ_DIR => sub { my $dir = shift; my $dh = OPEN_DIR->( $dir ) or return; ### exclude . and .. my @files = grep { $_ !~ /^\.{1,2}/ } readdir($dh); ### Remove trailing dot on VMS when ### using VMS syntax. if( ON_VMS ) { s/(? sub { my $file = $_[0] or return; $file =~ s/.gz$//i; return $file; }; use constant CHECKSUMS => 'CHECKSUMS'; use constant PGP_HEADER => '-----BEGIN PGP SIGNED MESSAGE-----'; use constant ENV_CPANPLUS_CONFIG => 'PERL5_CPANPLUS_CONFIG'; use constant ENV_CPANPLUS_IS_EXECUTING => 'PERL5_CPANPLUS_IS_EXECUTING'; use constant DEFAULT_EMAIL => 'cpanplus@example.com'; use constant CPANPLUS_UA => sub { ### for the version number ### require CPANPLUS::Internals; "CPANPLUS/$CPANPLUS::Internals::VERSION" }; use constant TESTERS_URL => sub { 'http://cpantesters.org/distro/'. uc(substr($_[0],0,1)) .'/'. $_[0] . '.yaml'; }; use constant TESTERS_DETAILS_URL => sub { 'http://cpantesters.org/distro/'. uc(substr($_[0],0,1)) .'/'. $_[0]; }; use constant CREATE_FILE_URI => sub { my $dir = $_[0] or return; return $dir =~ m|^/| ? 'file://' . $dir : 'file:///' . $dir; }; use constant EMPTY_DSLIP => ' '; use constant CUSTOM_AUTHOR_ID => 'LOCAL'; use constant DOT_SHELL_DEFAULT_RC => '.shell-default.rc'; use constant SOURCE_SQLITE_DB => 'db.sql'; use constant PREREQ_IGNORE => 0; use constant PREREQ_INSTALL => 1; use constant PREREQ_ASK => 2; use constant PREREQ_BUILD => 3; use constant BOOLEANS => [0,1]; use constant CALLING_FUNCTION => sub { my $lvl = $_[0] || 0; return join '::', (caller(2+$lvl))[3] }; use constant PERL_CORE => 'perl'; use constant PERL_WRAPPER => 'use strict; BEGIN { my $old = select STDERR; $|++; select $old; $|++; $0 = shift(@ARGV); my $rv = do($0); die $@ if $@; }'; use constant STORABLE_EXT => '.stored'; use constant GET_XS_FILES => sub { my $dir = $_[0] or return; require File::Find; my @files; File::Find::find( sub { push @files, $File::Find::name if $File::Find::name =~ /\.xs$/i }, $dir ); return @files; }; use constant INSTALL_LOG_FILE => sub { my $obj = shift or return; my $name = $obj->name; $name =~ s/::/-/g; $name .= '-'. $obj->version; $name .= '-'. scalar(time) . '.log'; return $name; }; use constant ON_OLD_CYGWIN => do { ON_CYGWIN and $] < 5.008 ? loc( "Your perl version for %1 is too low; ". "Require %2 or higher for this function", $^O, '5.8.0' ) : ''; }; ### XXX these 2 are probably obsolete -- check & remove; use constant DOT_EXISTS => '.exists'; use constant QUOTE_PERL_ONE_LINER => sub { my $line = shift or return; ### use double quotes on these systems return qq["$line"] if ON_WIN32 || ON_NETWARE || ON_VMS; ### single quotes on the rest return qq['$line']; }; 1; # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: CPANPLUS-0.9144/lib/CPANPLUS/Module.pm0000644000175000017500000015314712251421370016152 0ustar bingosbingospackage CPANPLUS::Module; use strict; use vars qw[@ISA $VERSION]; $VERSION = "0.9144"; use CPANPLUS::Dist; use CPANPLUS::Error; use CPANPLUS::Module::Signature; use CPANPLUS::Module::Checksums; use CPANPLUS::Internals::Constants; use FileHandle; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use IPC::Cmd qw[can_run run]; use File::Find qw[find]; use Params::Check qw[check]; use File::Basename qw[dirname]; use Module::Load::Conditional qw[can_load check_install]; $Params::Check::VERBOSE = 1; @ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums]; =pod =head1 NAME CPANPLUS::Module - CPAN module objects for CPANPLUS =head1 SYNOPSIS ### get a module object from the CPANPLUS::Backend object my $mod = $cb->module_tree('Some::Module'); ### accessors $mod->version; $mod->package; ### methods $mod->fetch; $mod->extract; $mod->install; =head1 DESCRIPTION C creates objects from the information in the source files. These can then be used to query and perform actions on, like fetching or installing. These objects should only be created internally. For C objects, there's the C class. To obtain a module object consult the C documentation. =cut my $tmpl = { module => { default => '', required => 1 }, # full module name version => { default => '0.0' }, # version number path => { default => '', required => 1 }, # extended path on the # cpan mirror, like # /author/id/K/KA/KANE comment => { default => ''}, # comment on module package => { default => '', required => 1 }, # package name, like # 'bar-baz-1.03.tgz' description => { default => '' }, # description of the # module dslip => { default => EMPTY_DSLIP }, # dslip information _id => { required => 1 }, # id of the Internals # parent object _status => { no_override => 1 }, # stores status object author => { default => '', required => 1, allow => IS_AUTHOBJ }, # module author mtime => { default => '' }, }; ### some of these will be resolved by wrapper functions that ### do Clever Things to find the actual value, so don't create ### an autogenerated sub for that just here, take an alternate ### name to allow for a wrapper { my %rename = ( dslip => '_dslip' ); ### autogenerate accessors ### for my $key ( keys %$tmpl ) { no strict 'refs'; my $sub = $rename{$key} || $key; *{__PACKAGE__."::$sub"} = sub { $_[0]->{$key} = $_[1] if @_ > 1; return $_[0]->{$key}; } } } =pod =head1 CLASS METHODS =head2 accessors () Returns a list of all accessor methods to the object =cut ### *name is an alias, include it explicitly sub accessors { return ('name', keys %$tmpl) }; =head1 ACCESSORS An objects of this class has the following accessors: =over 4 =item name Name of the module. =item module Name of the module. =item version Version of the module. Defaults to '0.0' if none was provided. =item path Extended path on the mirror. =item comment Any comment about the module -- largely unused. =item package The name of the package. =item description Description of the module -- only registered modules have this. =item dslip The five character dslip string, that represents meta-data of the module -- again, only registered modules have this. =cut sub dslip { my $self = shift; ### if this module has relevant dslip info, return it return $self->_dslip if $self->_dslip ne EMPTY_DSLIP; ### if not, look at other modules in the same package, ### see if *they* have any dslip info for my $mod ( $self->contains ) { return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP; } ### ok, really no dslip info found, return the default return EMPTY_DSLIP; } =pod =item status The C object associated with this object. (see below). =item author The C object associated with this object. =item parent The C object that spawned this module object. =back =cut ### Alias ->name to ->module, for human beings. *name = *module; sub parent { my $self = shift; my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); return $obj; } =head1 STATUS ACCESSORS C caches a lot of results from method calls and saves data it collected along the road for later reuse. C uses this internally, but it is also available for the end user. You can get a status object by calling: $modobj->status You can then query the object as follows: =over 4 =item installer_type The installer type used for this distribution. Will be one of 'makemaker' or 'build'. This determines whether C or C will be used to build this distribution. =item dist_cpan The dist object used to do the CPAN-side of the installation. Either a C or C object. =item dist The custom dist object used to do the operating specific side of the installation, if you've chosen to use this. For example, if you've chosen to install using the C format, this may be a C object. Undefined if you didn't specify a separate format to install through. =item prereqs | requires A hashref of prereqs this distribution was found to have. Will look something like this: { Carp => 0.01, strict => 0 } Might be undefined if the distribution didn't have any prerequisites. =item configure_requires Like prereqs, but these are necessary to be installed before the build process can even begin. =item signature Flag indicating, if a signature check was done, whether it was OK or not. =item extract The directory this distribution was extracted to. =item fetch The location this distribution was fetched to. =item readme The text of this distributions README file. =item uninstall Flag indicating if an uninstall call was done successfully. =item created Flag indicating if the C call to your dist object was done successfully. =item installed Flag indicating if the C call to your dist object was done successfully. =item checksums The location of this distributions CHECKSUMS file. =item checksum_ok Flag indicating if the checksums check was done successfully. =item checksum_value The checksum value this distribution is expected to have =back =head1 METHODS =head2 $self = CPANPLUS::Module->new( OPTIONS ) This method returns a C object. Normal users should never call this method directly, but instead use the C to obtain module objects. This example illustrates a C call with all required arguments: CPANPLUS::Module->new( module => 'Foo', path => 'authors/id/A/AA/AAA', package => 'Foo-1.0.tgz', author => $author_object, _id => INTERNALS_OBJECT_ID, ); Every accessor is also a valid option to pass to C. Returns a module object on success and false on failure. =cut sub new { my($class, %hash) = @_; ### don't check the template for sanity ### -- we know it's good and saves a lot of performance local $Params::Check::SANITY_CHECK_TEMPLATE = 0; my $object = check( $tmpl, \%hash ) or return; bless $object, $class; return $object; } ### only create status objects when they're actually asked for sub status { my $self = shift; return $self->_status if $self->_status; my $acc = Object::Accessor->new; $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs signature extract fetch readme uninstall created installed prepared checksums files checksum_ok checksum_value _fetch_from configure_requires ] ); ### create an alias from 'requires' to 'prereqs', so it's more in ### line with 'configure_requires'; $acc->mk_aliases( requires => 'prereqs' ); $self->_status( $acc ); return $self->_status; } ### flush the cache of this object ### sub _flush { my $self = shift; $self->status->mk_flush; return 1; } =head2 $mod->package_name( [$package_string] ) Returns the name of the package a module is in. For C that might be C. =head2 $mod->package_version( [$package_string] ) Returns the version of the package a module is in. For a module in the package C this would be C<1.1>. =head2 $mod->package_extension( [$package_string] ) Returns the suffix added by the compression method of a package a certain module is in. For a module in C, this would be C. =head2 $mod->package_is_perl_core Returns a boolean indicating of the package a particular module is in, is actually a core perl distribution. =head2 $mod->module_is_supplied_with_perl_core( [version => $]] ) Returns a boolean indicating whether C of this module was supplied with the current running perl's core package. =head2 $mod->is_bundle Returns a boolean indicating if the module you are looking at, is actually a bundle. Bundles are identified as modules whose name starts with C. =head2 $mod->is_autobundle; Returns a boolean indicating if the module you are looking at, is actually an autobundle as generated by C<< $cb->autobundle >>. =head2 $mod->is_third_party Returns a boolean indicating whether the package is a known third-party module (i.e. it's not provided by the standard Perl distribution and is not available on the CPAN, but on a third party software provider). See L for more details. =head2 $mod->third_party_information Returns a reference to a hash with more information about a third-party module. See the documentation about C in L for more details. =cut { ### fetches the test reports for a certain module ### my %map = ( name => 0, version => 1, extension => 2, ); while ( my($type, $index) = each %map ) { my $name = 'package_' . $type; no strict 'refs'; *$name = sub { my $self = shift; my $val = shift || $self->package; my @res = $self->parent->_split_package_string( package => $val ); ### return the corresponding index from the result return $res[$index] if @res; return; }; } sub package_is_perl_core { my $self = shift; my $cb = $self->parent; ### check if the package looks like a perl core package return 1 if $self->package_name eq PERL_CORE; ### address #44562: ::Module->package_is_perl_code : problem comparing ### version strings -- use $cb->_vcmp to avoid warnings when version ### have _ in them my $core = $self->module_is_supplied_with_perl_core; ### ok, so it's found in the core, BUT it could be dual-lifed if (defined $core) { ### if the package is newer than installed, then it's dual-lifed return if $cb->_vcmp($self->version, $self->installed_version) > 0; ### if the package is newer or equal to the corelist, ### then it's dual-lifed return if $cb->_vcmp( $self->version, $core ) >= 0; ### otherwise, it's older than corelist, thus unsuitable. return 1; } ### not in corelist, not a perl core package. return; } sub module_is_supplied_with_perl_core { my $self = shift; my $ver = shift || $]; ### allow it to be called as a package function as well like: ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config') ### so that we can check the status of modules that aren't released ### to CPAN, but are part of the core. my $name = ref $self ? $self->module : $self; ### check Module::CoreList to see if it's a core package require Module::CoreList; ### Address #41157: Module::module_is_supplied_with_perl_core() ### broken for perl 5.10: Module::CoreList's version key for the ### hash has a different number of trailing zero than $] aka ### $PERL_VERSION. my $core; if ( exists $Module::CoreList::version{ 0+$ver }->{ $name } ) { $core = $Module::CoreList::version{ 0+$ver }->{ $name }; $core = 0 unless $core; } return $core; } ### make sure Bundle-Foo also gets flagged as bundle sub is_bundle { my $self = shift; ### cpan'd bundle return 1 if $self->module =~ /^bundle(?:-|::)/i; ### autobundle return 1 if $self->is_autobundle; ### neither return; } ### full path to a generated autobundle sub is_autobundle { my $self = shift; my $conf = $self->parent->configure_object; my $prefix = $conf->_get_build('autobundle_prefix'); return 1 if $self->module eq $prefix; return; } sub is_third_party { my $self = shift; return unless can_load( modules => { 'Module::ThirdParty' => 0 } ); return Module::ThirdParty::is_3rd_party( $self->name ); } sub third_party_information { my $self = shift; return unless $self->is_third_party; return Module::ThirdParty::module_information( $self->name ); } } =pod =head2 $clone = $self->clone Clones the current module object for tinkering with. It will have a clean C object, as well as a fake C object. =cut { ### accessors don't change during run time, so only compute once my @acc = grep !/status/, __PACKAGE__->accessors(); sub clone { my $self = shift; ### clone the object ### my %data = map { $_ => $self->$_ } @acc; my $obj = CPANPLUS::Module::Fake->new( %data ); return $obj; } } =pod =head2 $where = $self->fetch Fetches the module from a CPAN mirror. Look at L for details on the options you can pass. =cut sub fetch { my $self = shift; my $cb = $self->parent; ### custom args my %args = ( module => $self ); ### if a custom fetch location got specified before, add that here $args{fetch_from} = $self->status->_fetch_from if $self->status->_fetch_from; my $where = $cb->_fetch( @_, %args ) or return; ### do an md5 check ### if( !$self->status->_fetch_from and $cb->configure_object->get_conf('md5') and $self->package ne CHECKSUMS ) { unless( $self->_validate_checksum ) { error( loc( "Checksum error for '%1' -- will not trust package", $self->package) ); return; } } return $where; } =pod =head2 $path = $self->extract Extracts the fetched module. Look at L for details on the options you can pass. =cut sub extract { my $self = shift; my $cb = $self->parent; unless( $self->status->fetch ) { error( loc( "You have not fetched '%1' yet -- cannot extract", $self->module) ); return; } ### can't extract these, so just use the basedir for the file if( $self->is_autobundle ) { ### this is expected to be set after an extract call $self->get_installer_type; return $self->status->extract( dirname( $self->status->fetch ) ); } return $cb->_extract( @_, module => $self ); } =head2 $type = $self->get_installer_type([prefer_makefile => BOOL]) Gets the installer type for this module. This may either be C or C. If C is unavailable or no installer type is available, it will fall back to C. If both are available, it will pick the one indicated by your config, or by the C option you can pass to this function. Returns the installer type on success, and false on error. =cut sub get_installer_type { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; my ($prefer_makefile,$verbose); my $tmpl = { prefer_makefile => { default => $conf->get_conf('prefer_makefile'), store => \$prefer_makefile, allow => BOOLEANS }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; check( $tmpl, \%hash ) or return; my $type; ### autobundles use their own installer, so return that if( $self->is_autobundle ) { $type = INSTALLER_AUTOBUNDLE; } else { my $extract = $self->status->extract(); unless( $extract ) { error(loc( "Cannot determine installer type of unextracted module '%1'", $self->module )); return; } ### check if it's a makemaker or a module::build type dist ### my $found_build = -e BUILD_PL->( $extract ); my $found_makefile = -e MAKEFILE_PL->( $extract ); $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; $type = INSTALLER_BUILD if $found_build && !$found_makefile; $type = INSTALLER_MM if $prefer_makefile && $found_makefile; $type = INSTALLER_MM if $found_makefile && !$found_build; # Special case Module::Build to always use INSTALLER_MM $type = INSTALLER_MM if $self->package =~ m{^Module-Build-\d}; } ### ok, so it's a 'build' installer, but you don't /have/ module build ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? if( $type and $type eq INSTALLER_BUILD and ( not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD ) or not $cb->module_tree( INSTALLER_BUILD ) ->is_uptodate( version => '0.60' ) ) ) { ### XXX this is for recording purposes only. We *have* to install ### these before even creating a dist object, or we'll get an error ### saying 'no such dist type'; ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? my $href = $self->status->configure_requires || {}; my $deps = { INSTALLER_BUILD, '0.60', %$href }; $self->status->configure_requires( $deps ); msg(loc("This module requires '%1' and '%2' to be installed first. ". "Adding these modules to your prerequisites list", 'Module::Build', INSTALLER_BUILD ), $verbose ); ### ok, actually we found neither ### } elsif ( !$type ) { error( loc( "Unable to find '%1' or '%2' for '%3'; ". "Will default to '%4' but might be unable ". "to install!", BUILD_PL->(), MAKEFILE_PL->(), $self->module, INSTALLER_MM ) ); $type = INSTALLER_MM; } return $self->status->installer_type( $type ) if $type; return; } =pod =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]); Create a distribution object, ready to be installed. Distribution type defaults to your config settings The optional C hashref is passed on to the specific distribution types' C method after being dereferenced. Returns a distribution object on success, false on failure. See C for details. =cut sub dist { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; ### have you determined your installer type yet? if not, do it here, ### we need the info $self->get_installer_type unless $self->status->installer_type; my($type,$args,$target); my $tmpl = { format => { default => $conf->get_conf('dist_type') || $self->status->installer_type, store => \$type }, target => { default => TARGET_CREATE, store => \$target }, args => { default => {}, store => \$args }, }; check( $tmpl, \%hash ) or return; ### ok, check for $type. Do we have it? unless( CPANPLUS::Dist->has_dist_type( $type ) ) { ### ok, we don't have it. Is it C::D::Build? if so we can install the ### whole thing now ### XXX we _could_ do this for any type we don't have actually... if( $type eq INSTALLER_BUILD ) { msg(loc("Bootstrapping installer '%1'", $type)); ### don't propagate the format, it's the one we're trying to ### bootstrap, so it'll be an infinite loop if we do $cb->module_tree( $type )->install( target => $target, %$args ) or do { error(loc("Could not bootstrap installer '%1' -- ". "can not continue", $type)); return; }; ### re-scan for available modules now CPANPLUS::Dist->rescan_dist_types; unless( CPANPLUS::Dist->has_dist_type( $type ) ) { error(loc("Newly installed installer type '%1' should be ". "available, but is not! -- aborting", $type)); return; } else { msg(loc("Installer '%1' successfully bootstrapped", $type)); } ### some other plugin you don't have. Abort } else { error(loc("Installer type '%1' not found. Please verify your ". "installation -- aborting", $type )); return; } } ### make sure we don't overwrite it, just in case we came ### back from a ->save_state. This allows restoration to ### work correctly my( $dist, $dist_cpan ); unless( $dist = $self->status->dist ) { $dist = $type->new( module => $self ) or return; $self->status->dist( $dist ); } unless( $dist_cpan = $self->status->dist_cpan ) { $dist_cpan = $type eq $self->status->installer_type ? $self->status->dist : $self->status->installer_type->new( module => $self ); $self->status->dist_cpan( $dist_cpan ); } DIST: { ### just wanted the $dist object? last DIST if $target eq TARGET_INIT; ### first prepare the dist $dist->prepare( %$args ) or return; $self->status->prepared(1); ### you just wanted us to prepare? last DIST if $target eq TARGET_PREPARE; $dist->create( %$args ) or return; $self->status->created(1); } return $dist; } =pod =head2 $bool = $mod->prepare( ) Convenience method around C that prepares a module without actually building it. This is equivalent to invoking C with C set to C Returns true on success, false on failure. =cut sub prepare { my $self = shift; return $self->install( @_, target => TARGET_PREPARE ); } =head2 $bool = $mod->create( ) Convenience method around C that creates a module. This is equivalent to invoking C with C set to C Returns true on success, false on failure. =cut sub create { my $self = shift; return $self->install( @_, target => TARGET_CREATE ); } =head2 $bool = $mod->test( ) Convenience wrapper around C that tests a module, without installing it. It's the equivalent to invoking C with C set to C and C set to C<0>. Returns true on success, false on failure. =cut sub test { my $self = shift; return $self->install( @_, target => TARGET_CREATE, skiptest => 0 ); } =pod =head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]); Installs the current module. This includes fetching it and extracting it, if this hasn't been done yet, as well as creating a distribution object for it. This means you can pass it more arguments than described above, which will be passed on to the relevant methods as they are called. See C, C and C for details. Returns true on success, false on failure. =cut sub install { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; my $args; my $target; my $format; { ### so we can use the rest of the args to the create calls etc ### local $Params::Check::NO_DUPLICATES = 1; local $Params::Check::ALLOW_UNKNOWN = 1; ### targets 'dist' and 'test' are now completely ignored ### my $tmpl = { ### match this allow list with Dist->_resolve_prereqs target => { default => TARGET_INSTALL, store => \$target, allow => [TARGET_PREPARE, TARGET_CREATE, TARGET_INSTALL, TARGET_INIT ] }, force => { default => $conf->get_conf('force'), }, verbose => { default => $conf->get_conf('verbose'), }, format => { default => $conf->get_conf('dist_type'), store => \$format }, }; $args = check( $tmpl, \%hash ) or return; } ### if this target isn't 'install', we will need to at least 'create' ### every prereq, so it can build ### XXX prereq_target of 'prepare' will do weird things here, and is ### not supported. $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL; ### check if it's already uptodate ### if( $target eq TARGET_INSTALL and !$args->{'force'} and !$self->package_is_perl_core() and # separate rules apply ( $self->status->installed() or $self->is_uptodate ) and !INSTALL_VIA_PACKAGE_MANAGER->($format) ) { msg(loc("Module '%1' already up to date, won't install without force", $self->module), $args->{'verbose'} ); return $self->status->installed(1); } # if it's a non-installable core package, abort the install. if( $self->package_is_perl_core() ) { # if the installed is newer, say so. if( $self->installed_version > $self->version ) { error(loc("The core Perl %1 module '%2' (%3) is more ". "recent than the latest release on CPAN (%4). ". "Aborting install.", $], $self->module, $self->installed_version, $self->version ) ); # if the installed matches, say so. } elsif( $self->installed_version == $self->version ) { error(loc("The core Perl %1 module '%2' (%3) can only ". "be installed by Perl itself. ". "Aborting install.", $], $self->module, $self->installed_version ) ); # otherwise, the installed is older; say so. } else { error(loc("The core Perl %1 module '%2' can only be ". "upgraded from %3 to %4 by Perl itself (%5). ". "Aborting install.", $], $self->module, $self->installed_version, $self->version, $self->package ) ); } return; ### it might be a known 3rd party module } elsif ( $self->is_third_party ) { my $info = $self->third_party_information; error(loc( "%1 is a known third-party module.\n\n". "As it isn't available on the CPAN, CPANPLUS can't install " . "it automatically. Therefore you need to install it manually " . "before proceeding.\n\n". "%2 is part of %3, published by %4, and should be available ". "for download at the following address:\n\t%5", $self->name, $self->name, $info->{name}, $info->{author}, $info->{url} )); return; } ### fetch it if need be ### unless( $self->status->fetch ) { my $params; for (qw[prefer_bin fetchdir]) { $params->{$_} = $args->{$_} if exists $args->{$_}; } for (qw[force verbose]) { $params->{$_} = $args->{$_} if defined $args->{$_}; } $self->fetch( %$params ) or return; } ### extract it if need be ### unless( $self->status->extract ) { my $params; for (qw[prefer_bin extractdir]) { $params->{$_} = $args->{$_} if exists $args->{$_}; } for (qw[force verbose]) { $params->{$_} = $args->{$_} if defined $args->{$_}; } $self->extract( %$params ) or return; } $args->{'prereq_format'} = $format if $format; $format ||= $self->status->installer_type; unless( $format ) { error( loc( "Don't know what installer to use; " . "Couldn't find either '%1' or '%2' in the extraction " . "directory '%3' -- will be unable to install", BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) ); $self->status->installed(0); return; } ### do SIGNATURE checks? ### ### XXX check status and not recheck EVERY time? if( $conf->get_conf('signature') ) { unless( $self->check_signature( verbose => $args->{verbose} ) ) { error( loc( "Signature check failed for module '%1' ". "-- Not trusting this module, aborting install", $self->module ) ); $self->status->signature(0); ### send out test report on broken sig if( $conf->get_conf('cpantest') ) { $cb->_send_report( module => $self, failed => 1, buffer => CPANPLUS::Error->stack_as_string, verbose => $args->{verbose}, force => $args->{force}, ) or error(loc("Failed to send test report for '%1'", $self->module ) ); } return; } else { ### signature OK ### $self->status->signature(1); } } ### a target of 'create' basically means not to run make test ### ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1. #$args->{'skiptest'} = 1 if $target eq 'create'; ### bundle rules apply ### if( $self->is_bundle ) { ### check what we need to install ### my @prereqs = $self->bundle_modules(); unless( @prereqs ) { error( loc( "Bundle '%1' does not specify any modules to install", $self->module ) ); ### XXX mark an error here? ### } } my $dist = $self->dist( format => $format, target => $target, args => $args ); unless( $dist ) { error( loc( "Unable to create a new distribution object for '%1' " . "-- cannot continue", $self->module ) ); return; } return 1 if $target ne TARGET_INSTALL; my $ok = $dist->install( %$args ) ? 1 : 0; $self->status->installed($ok); return 1 if $ok; return; } =pod =head2 @list = $self->bundle_modules() Returns a list of module objects the Bundle specifies. This requires you to have extracted the bundle already, using the C method. Returns false on error. =cut sub bundle_modules { my $self = shift; my $cb = $self->parent; unless( $self->is_bundle ) { error( loc("'%1' is not a bundle", $self->module ) ); return; } my @files; ### autobundles are special files generated by CPANPLUS. If we can ### read the file, we can determine the prereqs if( $self->is_autobundle ) { my $where; unless( $where = $self->status->fetch ) { error(loc("Don't know where '%1' was fetched to", $self->package)); return; } push @files, $where ### regular bundle::* upload } else { my $dir; unless( $dir = $self->status->extract ) { error(loc("Don't know where '%1' was extracted to", $self->module)); return; } find( { wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, no_chdir => 1, }, $dir ); } my $prereqs = {}; my @list; my $seen = {}; for my $file ( @files ) { my $fh = FileHandle->new($file) or( error(loc("Could not open '%1' for reading: %2", $file,$!)), next ); my $flag; while( local $_ = <$fh> ) { ### quick hack to read past the header of the file ### last if $flag && m|^=head|i; ### from perldoc cpan: ### =head1 CONTENTS ### In this pod section each line obeys the format ### Module_Name [Version_String] [- optional text] $flag = 1 if m|^=head1 CONTENTS|i; if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { my $module = $1; my $version = $cb->_version_to_number( version => $2 ); my $obj = $cb->module_tree($module); unless( $obj ) { error(loc("Cannot find bundled module '%1'", $module), loc("-- it does not seem to exist") ); next; } ### make sure we list no duplicates ### unless( $seen->{ $obj->module }++ ) { push @list, $obj; $prereqs->{ $module } = $cb->_version_to_number( version => $version ); } } } } ### store the prereqs we just found ### $self->status->prereqs( $prereqs ); return @list; } =pod =head2 $text = $self->readme Fetches the readme belonging to this module and stores it under C<< $obj->status->readme >>. Returns the readme as a string on success and returns false on failure. =cut sub readme { my $self = shift; my $conf = $self->parent->configure_object; ### did we already dl the readme once? ### return $self->status->readme() if $self->status->readme(); ### this should be core ### return unless can_load( modules => { FileHandle => '0.0' }, verbose => 1, ); ### get a clone of the current object, with a fresh status ### my $obj = $self->clone or return; ### munge the package name my $pkg = README->( $obj ); $obj->package($pkg); my $file; { ### disable checksum fetches on readme downloads my $tmp = $conf->get_conf( 'md5' ); $conf->set_conf( md5 => 0 ); $file = $obj->fetch; $conf->set_conf( md5 => $tmp ); return unless $file; } ### read the file into a scalar, to store in the original object ### my $fh = new FileHandle; unless( $fh->open($file) ) { error( loc( "Could not open file '%1': %2", $file, $! ) ); return; } my $in = do{ local $/; <$fh> }; $fh->close; return $self->status->readme( $in ); } =pod =head2 $version = $self->installed_version() Returns the currently installed version of this module, if any. =head2 $where = $self->installed_file() Returns the location of the currently installed file of this module, if any. =head2 $dir = $self->installed_dir() Returns the directory (or more accurately, the C<@INC> handle) from which this module was loaded, if any. =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) Returns a boolean indicating if this module is uptodate or not. =cut ### uptodate/installed functions { my $map = { # hashkey, alternate rv installed_version => ['version', 0 ], installed_file => ['file', ''], installed_dir => ['dir', ''], is_uptodate => ['uptodate', 0 ], }; while( my($method, $aref) = each %$map ) { my($key,$alt_rv) = @$aref; no strict 'refs'; *$method = sub { ### never use the @INC hooks to find installed versions of ### modules -- they're just there in case they're not on the ### perl install, but the user shouldn't trust them for *other* ### modules! ### XXX CPANPLUS::inc is now obsolete, so this should not ### be needed anymore #local @INC = CPANPLUS::inc->original_inc; my $self = shift; ### make sure check_install is not looking in %INC, as ### that may contain some of our sneakily loaded modules ### that aren't installed as such. -- kane local $Module::Load::Conditional::CHECK_INC_HASH = 0; ### this should all that is required for deprecated core modules local $Module::Load::Conditional::DEPRECATED = 1; my $href = check_install( module => $self->module, version => $self->version, @_, ); ### Don't trust modules which are the result of @INC hooks ### FatPacker uses this trickery and it causes WTF moments return $alt_rv if defined $href->{dir} && ref $href->{dir}; return $href->{$key} || $alt_rv; } } } =pod =head2 $href = $self->details() Returns a hashref with key/value pairs offering more information about a particular module. For example, for C it might look like this: Author Jarkko Hietaniemi (jhi@iki.fi) Description High resolution time, sleep, and alarm Development Stage Released Installed File /usr/local/perl/lib/Time/Hires.pm Interface Style plain Functions, no references used Language Used C and perl, a C compiler will be needed Package Time-HiRes-1.65.tar.gz Public License Unknown Support Level Developer Version Installed 1.52 Version on CPAN 1.65 =cut sub details { my $self = shift; my $conf = $self->parent->configure_object(); my $cb = $self->parent; my %hash = @_; my $res = { Author => loc("%1 (%2)", $self->author->author(), $self->author->email() ), Package => $self->package, Description => $self->description || loc('None given'), 'Version on CPAN' => $self->version, }; ### check if we have the module installed ### if so, add version have and version on cpan $res->{'Version Installed'} = $self->installed_version if $self->installed_version; $res->{'Installed File'} = $self->installed_file if $self->installed_file; my $i = 0; for my $item( split '', $self->dslip ) { $res->{ $cb->_dslip_defs->[$i]->[0] } = $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown'); $i++; } return $res; } =head2 @list = $self->contains() Returns a list of module objects that represent the modules also present in the package of this module. For example, for C this might return: Archive::Tar Archive::Tar::Constant Archive::Tar::File =cut sub contains { my $self = shift; my $cb = $self->parent; my $pkg = $self->package; my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); return @mods; } =pod =head2 @list_of_hrefs = $self->fetch_report() This function queries the CPAN testers database at I for test results of specified module objects, module names or distributions. Look at L for details on the options you can pass and the return value to expect. =cut sub fetch_report { my $self = shift; my $cb = $self->parent; return $cb->_query_report( @_, module => $self ); } =pod =head2 $bool = $self->uninstall([type => [all|man|prog]) This function uninstalls the specified module object. You can install 2 types of files, either C pages or Cram files. Alternately you can specify C to uninstall both (which is the default). Returns true on success and false on failure. Do note that this does an uninstall via the so-called C<.packlist>, so if you used a module installer like say, C or C, you should not use this, but use your package manager instead. =cut sub uninstall { my $self = shift; my $conf = $self->parent->configure_object(); my %hash = @_; my ($type,$verbose); my $tmpl = { type => { default => 'all', allow => [qw|man prog all|], store => \$type }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, force => { default => $conf->get_conf('force') }, }; ### XXX add a warning here if your default install dist isn't ### makefile or build -- that means you are using a package manager ### and this will not do what you think! my $args = check( $tmpl, \%hash ) or return; if( $conf->get_conf('dist_type') and ( ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or ($conf->get_conf('dist_type') ne INSTALLER_MM)) ) { msg(loc("You have a default installer type set (%1) ". "-- you should probably use that package manager to " . "uninstall modules", $conf->get_conf('dist_type')), $verbose); } ### check if we even have the module installed -- no point in continuing ### otherwise unless( $self->installed_version ) { error( loc( "Module '%1' is not installed, so cannot uninstall", $self->module ) ); return; } ### nothing to uninstall ### my $files = $self->files( type => $type ) or return; my $dirs = $self->directory_tree( type => $type ) or return; my $sudo = $conf->get_program('sudo'); ### just in case there's no file; M::B doesn't provide .packlists yet ### my $pack = $self->packlist; $pack = $pack->[0]->packlist_file() if $pack; ### first remove the files, then the dirs if they are empty ### my $flag = 0; for my $file( @$files, $pack ) { next unless defined $file && -f $file; msg(loc("Unlinking '%1'", $file), $verbose); my @cmd = ($^X, "-eunlink+q[$file]"); unshift @cmd, $sudo if $sudo; my $buffer; unless ( run( command => \@cmd, verbose => $verbose, buffer => \$buffer ) ) { error(loc("Failed to unlink '%1': '%2'",$file, $buffer)); $flag++; } } for my $dir ( sort @$dirs ) { local *DIR; opendir DIR, $dir or next; my @count = readdir(DIR); close DIR; next unless @count == 2; # . and .. msg(loc("Removing '%1'", $dir), $verbose); ### this fails on my win2k machines.. it indeed leaves the ### dir, but it's not a critical error, since the files have ### been removed. --kane #unless( rmdir $dir ) { # error( loc( "Could not remove '%1': %2", $dir, $! ) ) # unless $^O eq 'MSWin32'; #} my @cmd = ($^X, "-e", "rmdir q[$dir]"); unshift @cmd, $sudo if $sudo; my $buffer; unless ( run( command => \@cmd, verbose => $verbose, buffer => \$buffer ) ) { error(loc("Failed to rmdir '%1': %2",$dir,$buffer)); $flag++; } } $self->status->uninstall(!$flag); $self->status->installed( $flag ? 1 : undef); return !$flag; } =pod =head2 @modobj = $self->distributions() Returns a list of module objects representing all releases for this module on success, false on failure. =cut sub distributions { my $self = shift; my %hash = @_; my @list = $self->author->distributions( %hash, module => $self ) or return; ### it's another release then by the same author ### return grep { $_->package_name eq $self->package_name } @list; } =pod =head2 @list = $self->files () Returns a list of files used by this module, if it is installed. =head2 @list = $self->directory_tree () Returns a list of directories used by this module. =head2 @list = $self->packlist () Returns the C object for this module. =head2 @list = $self->validate () Returns a list of files that are missing for this modules, but are present in the .packlist file. =cut for my $sub (qw[files directory_tree packlist validate]) { no strict 'refs'; *$sub = sub { return shift->_extutils_installed( @_, method => $sub ); } } ### generic method to call an ExtUtils::Installed method ### sub _extutils_installed { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my $home = $cb->_home_dir; # may be needed to fix up prefixes my %hash = @_; my ($verbose,$type,$method); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose, }, type => { default => 'all', allow => [qw|prog man all|], store => \$type, }, method => { required => 1, store => \$method, allow => [qw|files directory_tree packlist validate|], }, }; my $args = check( $tmpl, \%hash ) or return; ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we ### find we're being used by them { my $err = ON_OLD_CYGWIN; if($err) { error($err); return }; } return unless can_load( modules => { 'ExtUtils::Installed' => '0.0' }, verbose => $verbose, ); my @config_names = ( ### lib { lib => 'privlib', # perl-only arch => 'archlib', # compiled code prefix => 'prefix', # prefix to both }, ### site { lib => 'sitelib', arch => 'sitearch', prefix => 'siteprefix', }, ### vendor { lib => 'vendorlib', arch => 'vendorarch', prefix => 'vendorprefix', }, ); ### search in your regular @INC, and anything you added to your config. ### this lets EU::Installed find .packlists that are *not* in the standard ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438 ### make sure the archname path is also added, as that's where the .packlist ### files are written my @libs; for my $lib ( @{ $conf->get_conf('lib') } ) { require Config; ### and just the standard dir push @libs, $lib; ### figure out what an MM prefix expands to. Basically, it's the ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8 ### minus the site wide prefix, ie: /opt ### this lets users add the dir they have set as their EU::MM PREFIX ### to our 'lib' config and it Just Works ### the arch specific dir, ie: ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level ### XXX is this the right thing to do? ### we add all 6 dir combos for prefixes: ### /foo/lib ### /foo/lib/arch ### /foo/site/lib ### /foo/site/lib/arch ### /foo/vendor/lib ### /foo/vendor/lib/arch for my $href ( @config_names ) { for my $key ( qw[lib arch] ) { ### look up the config value -- use EXP for the EXPANDED ### version, so no ~ etc are found in there my $dir = $Config::Config{ $href->{ $key } .'exp' } or next; my $prefix = $Config::Config{ $href->{prefix} }; ### prefix may be relative to home, and contain a ~ ### if so, fix it up. $prefix =~ s/^~/$home/; ### remove the prefix from it, so we can append to our $lib $dir =~ s/^\Q$prefix\E//; ### do the appending push @libs, File::Spec->catdir( $lib, $dir ); } } } my $inst; unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) { error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); ### in case it's being used directly... ### return; } { ### EU::Installed can die =/ my @files; eval { @files = $inst->$method( $self->module, $type ) }; if( $@ ) { chomp $@; error( loc("Could not get '%1' for '%2': %3", $method, $self->module, $@ ) ); return; } return wantarray ? @files : \@files; } } =head2 $bool = $self->add_to_includepath; Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows you to add the module from its build dir to your path. It also adds the current modules C and/or C