From: Rafael Garcia-Suarez Date: Sun, 4 Nov 2007 12:28:45 +0000 (+0000) Subject: Upgrade CPANPLUS to 0.83_08 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5879cbe1053352a3e452f61cecfdf074d36680f5;p=p5sagit%2Fp5-mst-13.2.git Upgrade CPANPLUS to 0.83_08 p4raw-id: //depot/perl@32218 --- diff --git a/lib/CPANPLUS.pm b/lib/CPANPLUS.pm index 22cd8d0..d8fbea5 100644 --- a/lib/CPANPLUS.pm +++ b/lib/CPANPLUS.pm @@ -13,7 +13,7 @@ BEGIN { use vars qw( @EXPORT @ISA $VERSION ); @EXPORT = qw( shell fetch get install ); @ISA = qw( Exporter ); - $VERSION = "0.83_02"; #have to hardcode or cpan.org gets unhappy + $VERSION = "0.83_08"; #have to hardcode or cpan.org gets unhappy } ### purely for backward compatibility, so we can call it from the commandline: diff --git a/lib/CPANPLUS/Backend.pm b/lib/CPANPLUS/Backend.pm index 8752b71..75beb2e 100644 --- a/lib/CPANPLUS/Backend.pm +++ b/lib/CPANPLUS/Backend.pm @@ -132,7 +132,27 @@ sub module_tree { if( @_ ) { my @rv; for my $name ( grep { defined } @_) { - push @rv, $modtree->{$name} || ''; + + ### 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 { @@ -230,16 +250,19 @@ sub search { my $conf = $self->configure_object; my %hash = @_; - local $Params::Check::ALLOW_UNKNOWN = 1; + my ($type); + my $args = do { + local $Params::Check::NO_DUPLICATES = 0; + local $Params::Check::ALLOW_UNKNOWN = 1; - my ($data,$type); - my $tmpl = { - type => { required => 1, allow => [CPANPLUS::Module->accessors(), - CPANPLUS::Module::Author->accessors()], store => \$type }, - allow => { required => 1, default => [ ], strict_type => 1 }, - }; + my $tmpl = { + type => { required => 1, allow => [CPANPLUS::Module->accessors(), + CPANPLUS::Module::Author->accessors()], store => \$type }, + allow => { required => 1, default => [ ], strict_type => 1 }, + }; - my $args = check( $tmpl, \%hash ) or return; + check( $tmpl, \%hash ) + } or return; ### figure out whether it was an author or a module search ### when ambiguous, it'll be an author search. diff --git a/lib/CPANPLUS/Dist/MM.pm b/lib/CPANPLUS/Dist/MM.pm index 2e01ef1..e549ca5 100644 --- a/lib/CPANPLUS/Dist/MM.pm +++ b/lib/CPANPLUS/Dist/MM.pm @@ -305,7 +305,7 @@ sub prepare { ### since cpanp-run-perl uses 'do' to execute the file, and do() ### checks your @INC.. so, if there's _another_ makefile.pl in ### your @INC, it will execute that one... - my $makefile_pl = $cb->_safe_path( path => MAKEFILE_PL->( $dir ) ); + my $makefile_pl = MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ); ### setting autoflush to true fixes issue from rt #8047 ### XXX this means that we need to keep the path to CPANPLUS diff --git a/lib/CPANPLUS/Internals.pm b/lib/CPANPLUS/Internals.pm index f57facc..6bc6813 100644 --- a/lib/CPANPLUS/Internals.pm +++ b/lib/CPANPLUS/Internals.pm @@ -40,7 +40,7 @@ use vars qw[@ISA $VERSION]; CPANPLUS::Internals::Report ]; -$VERSION = "0.83_02"; +$VERSION = "0.83_08"; =pod diff --git a/lib/CPANPLUS/Internals/Constants.pm b/lib/CPANPLUS/Internals/Constants.pm index 00bf2c5..bfd4439 100644 --- a/lib/CPANPLUS/Internals/Constants.pm +++ b/lib/CPANPLUS/Internals/Constants.pm @@ -230,8 +230,14 @@ use constant READ_DIR => sub { my $dh = OPEN_DIR->( $dir ) or return; ### exclude . and .. - my @files = grep { $_ !~ /^\.{1,2}/ } + my @files = grep { $_ !~ /^\.{1,2}/ } readdir($dh); + + ### Remove trailing dot on VMS when + ### using VMS syntax. + if( ON_VMS ) { + s/(? sub { my $dir = $_[0] or return; return $dir =~ m|^/| - ? 'file:/' . $dir - : 'file://' . $dir; + ? 'file://' . $dir + : 'file:///' . $dir; }; +use constant EMPTY_DSLIP => ' '; + use constant CUSTOM_AUTHOR_ID => 'LOCAL'; diff --git a/lib/CPANPLUS/Internals/Extract.pm b/lib/CPANPLUS/Internals/Extract.pm index 8063b90..84a48a5 100644 --- a/lib/CPANPLUS/Internals/Extract.pm +++ b/lib/CPANPLUS/Internals/Extract.pm @@ -201,11 +201,13 @@ sub _extract { my $dir; for my $try ( File::Spec->rel2abs( - $self->_safe_path( path => - File::Spec->catdir( $to, - $mod->package_name .'-'. - $mod->package_version - ) ) ), + ### _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; diff --git a/lib/CPANPLUS/Internals/Fetch.pm b/lib/CPANPLUS/Internals/Fetch.pm index b8ad371..54d6015 100644 --- a/lib/CPANPLUS/Internals/Fetch.pm +++ b/lib/CPANPLUS/Internals/Fetch.pm @@ -214,23 +214,75 @@ sub _fetch { for my $host ( @{$conf->get_conf('hosts')} ) { $found_host++; - my $mirror_path = File::Spec::Unix->catfile( - $host->{'path'}, $remote_file - ); - - ### build pretty print uri ### my $where; - if( $host->{'scheme'} eq 'file' ) { + + ### 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 doesnt 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; + + ### XXX i'm not sure what cases this is addressing. + ### this comes straight from dmq's file:// patches + ### for win32. --kane + if( $host_dirs[0] ) { + unshift @host_dirs, $vol; + } 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->rel2abs( - File::Spec::Unix->catdir( - grep { defined $_ && length $_ } - $host->{'host'}, - $mirror_path - ) - ) - ); - } else { + 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, diff --git a/lib/CPANPLUS/Internals/Report.pm b/lib/CPANPLUS/Internals/Report.pm index cbe20a6..cbe76ff 100644 --- a/lib/CPANPLUS/Internals/Report.pm +++ b/lib/CPANPLUS/Internals/Report.pm @@ -52,8 +52,11 @@ 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.08', + 'File::Fetch' => '0.13_02', 'YAML::Tiny' => '0.0', 'File::Temp' => '0.0', }; diff --git a/lib/CPANPLUS/Internals/Search.pm b/lib/CPANPLUS/Internals/Search.pm index 2a711ab..85e1678 100644 --- a/lib/CPANPLUS/Internals/Search.pm +++ b/lib/CPANPLUS/Internals/Search.pm @@ -314,24 +314,7 @@ sub _all_installed { return if $seen{$mod}++; - ### 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/^$mod$/i], - ) - : $self->module_tree($mod) - }; + my $modobj = $self->module_tree($mod); ### seperate return, a list context return with one '' ### in it, is also true! diff --git a/lib/CPANPLUS/Internals/Source.pm b/lib/CPANPLUS/Internals/Source.pm index d1308f6..0e7ee1f 100644 --- a/lib/CPANPLUS/Internals/Source.pm +++ b/lib/CPANPLUS/Internals/Source.pm @@ -820,7 +820,7 @@ sub _create_mod_tree { # 'foo-bar-baz-1.03.tar.gz' description => $dslip_tree->{ $data[0] }->{'description'}, dslip => $dslip, - _id => $self->_id, #id of this internals object + _id => $self->_id, # id of this internals object ); } #for @@ -1107,10 +1107,15 @@ sub _remove_custom_module_source { ### use uri => local, instead of the other way around my %files = reverse $self->__list_custom_module_sources; - my $file = $files{ $uri } or do { - error(loc("No such custom source '%1'", $uri)); - 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{ $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; @@ -1242,8 +1247,13 @@ sub __update_custom_module_source { 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 - $files{ $remote } or do { + $file or do { error(loc("Remote source '%1' unknown -- needs '%2' argument", $remote, 'local')); return; @@ -1275,11 +1285,17 @@ sub __update_custom_module_source { } 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 => File::Spec->catdir( - File::Spec::Unix->splitdir( $ff->path ) - ), + path => $ff_path, to => $local, verbose => $verbose, ) or return; @@ -1347,7 +1363,7 @@ sub __write_custom_module_index { ### make sure to remove the leading slash as well. my $copy = $File::Find::name; my $re = quotemeta($path); - $copy =~ s|^$path[\\/]?||i; + $copy =~ s|^$re[\\/]?||i; push @files, $copy; @@ -1434,7 +1450,11 @@ Returns true on success, false on failure. ### and now add it to the modlue tree -- this MAY ### override things of course - if( $self->module_tree( $mod->module ) ) { + 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); } diff --git a/lib/CPANPLUS/Internals/Utils.pm b/lib/CPANPLUS/Internals/Utils.pm index 3f38aaa..b3e6534 100644 --- a/lib/CPANPLUS/Internals/Utils.pm +++ b/lib/CPANPLUS/Internals/Utils.pm @@ -351,8 +351,11 @@ sub _host_to_uri { check( $tmpl, \%hash ) or return; - ### it's an URI, so unixify the path - $path = File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); + ### 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 ); } @@ -429,6 +432,10 @@ sub _safe_path { ### Fixing this is a 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. diff --git a/lib/CPANPLUS/Module.pm b/lib/CPANPLUS/Module.pm index 96030d3..fb6be9b 100644 --- a/lib/CPANPLUS/Module.pm +++ b/lib/CPANPLUS/Module.pm @@ -66,7 +66,7 @@ my $tmpl = { # 'bar-baz-1.03.tgz' description => { default => '' }, # description of the # module - dslip => { default => ' ' }, # dslip information + dslip => { default => EMPTY_DSLIP }, # dslip information _id => { required => 1 }, # id of the Internals # parent object _status => { no_override => 1 }, # stores status object @@ -75,15 +75,28 @@ my $tmpl = { mtime => { default => '' }, }; -### autogenerate accessors ### -for my $key ( keys %$tmpl ) { - no strict 'refs'; - *{__PACKAGE__."::$key"} = sub { - $_[0]->{$key} = $_[1] if @_ > 1; - return $_[0]->{$key}; +### 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 @@ -136,6 +149,27 @@ Description of the module -- only registered modules have this. 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. @@ -1172,7 +1206,7 @@ sub contains { my $self = shift; my $cb = $self->parent; my $pkg = $self->package; - + my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); return @mods; diff --git a/lib/CPANPLUS/Selfupdate.pm b/lib/CPANPLUS/Selfupdate.pm index bea8e12..efb7685 100644 --- a/lib/CPANPLUS/Selfupdate.pm +++ b/lib/CPANPLUS/Selfupdate.pm @@ -40,7 +40,7 @@ CPANPLUS::Selfupdate my $Modules = { dependencies => { - 'File::Fetch' => '0.08', # win32 ftp support + 'File::Fetch' => '0.13_02', # win32 file:// support 'File::Spec' => '0.82', 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open 'Locale::Maketext::Simple' => '0.01', @@ -48,9 +48,10 @@ CPANPLUS::Selfupdate 'Module::Load' => '0.10', 'Module::Load::Conditional' => '0.18', # Better parsing: #23995, # uses version.pm for <=> - 'version' => '0.70', # needed for M::L::C + 'version' => '0.73', # needed for M::L::C # addresses #24630 and # #24675 + # Address ~0 overflow issue 'Params::Check' => '0.22', 'Package::Constants' => '0.01', 'Term::UI' => '0.05', @@ -83,7 +84,6 @@ CPANPLUS::Selfupdate cpantest => [ { 'YAML::Tiny' => '0.0', - 'File::Fetch' => '0.08', 'Test::Reporter' => '1.34', }, sub { diff --git a/lib/CPANPLUS/Shell/Default.pm b/lib/CPANPLUS/Shell/Default.pm index 2a2e375..66d3184 100644 --- a/lib/CPANPLUS/Shell/Default.pm +++ b/lib/CPANPLUS/Shell/Default.pm @@ -26,7 +26,7 @@ local $Data::Dumper::Indent = 1; # for dumpering from ! BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.83_02"; + $VERSION = "0.83_08"; } load CPANPLUS::Shell; diff --git a/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm index e055fbf..ad4701a 100644 --- a/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm +++ b/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm @@ -76,7 +76,11 @@ sub _uri_from_cache { my %files = reverse $Cb->list_custom_sources; ### it's an URI we know - if( my $local = $files{ $uri } ) { + ### 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; diff --git a/lib/CPANPLUS/bin/cpan2dist b/lib/CPANPLUS/bin/cpan2dist index 41349f4..8c913ba 100644 --- a/lib/CPANPLUS/bin/cpan2dist +++ b/lib/CPANPLUS/bin/cpan2dist @@ -37,7 +37,8 @@ GetOptions( $opts, 'logfile=s', 'timeout=s', 'dist-opts=s%', 'set-config=s%', 'default-banlist!', 'set-program=s%', - 'default-ignorelist!', 'edit-metafile!' + 'default-ignorelist!', 'edit-metafile!', + 'install!' ); die usage() if exists $opts->{'help'}; @@ -325,7 +326,8 @@ for my $name (@modules) { } - my $dist = eval { + my $target = $opts->{'install'} ? 'install' : 'create'; + my $dist = eval { local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS } if $timeout; @@ -334,8 +336,8 @@ for my $name (@modules) { my $dist_opts = $opts->{'dist-opts'} || {}; my $rv = $obj->install( - prereq_target => 'create', - target => 'create', + prereq_target => $target, + target => $target, keep_source => $keep, prereq_build => $prereqbuild, @@ -450,6 +452,8 @@ Options: ### take no argument: --help Show this help message + --install Install this package (and any prerequisites you built) + after building it. --skiptest Skip tests. Can be negated using --noskiptest --force Force operation. Can be negated using --noforce --verbose Be verbose. Can be negated using --noverbose @@ -520,6 +524,9 @@ Examples: ### don't bother running tests cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI + ### build a debian package of DBI and it's prerequisites and install them + cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI + ### Build a package, whose format is determined by your config, of ### the local tarball, reloading cpanplus' indices first and using ### the tarballs Makefile.PL if it has one. diff --git a/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t b/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t index 2b3ad5a..18011fd 100644 --- a/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t +++ b/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t @@ -34,10 +34,14 @@ rmdir $Dir if -d $Dir; ### test _chdir ### { ok( $Class->_chdir( dir => $Dir), "Chdir to '$Dir'" ); - is( File::Spec->rel2abs(cwd()), File::Spec->rel2abs(File::Spec->catdir($Cwd,$Dir)), + + my $abs_re = quotemeta File::Spec->rel2abs(File::Spec->catdir($Cwd,$Dir)); + like( File::Spec->rel2abs(cwd()), qr/$abs_re/i, " Cwd() is '$Dir'"); + + my $cwd_re = quotemeta $Cwd; ok( $Class->_chdir( dir => $Cwd), "Chdir back to '$Cwd'" ); - like( File::Spec->rel2abs(cwd()), qr/$Cwd/i, + like( File::Spec->rel2abs(cwd()), qr/$cwd_re/i, " Cwd() is '$Cwd'" ); } diff --git a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t index d2ce5cd..606c274 100644 --- a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t +++ b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t @@ -94,7 +94,15 @@ ok( scalar keys %$mt, "Moduletree loaded successfully" ); my %files = $cb->$meth; ok( scalar(keys(%files)), " Got list of sources" ); - ok( $files{ $src_file }," Found proper entry" ); + + ### 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 diff --git a/lib/CPANPLUS/t/04_CPANPLUS-Module.t b/lib/CPANPLUS/t/04_CPANPLUS-Module.t index 54236e4..7c1c8fa 100644 --- a/lib/CPANPLUS/t/04_CPANPLUS-Module.t +++ b/lib/CPANPLUS/t/04_CPANPLUS-Module.t @@ -22,7 +22,7 @@ my $CB = CPANPLUS::Backend->new( $Conf ); ### start with fresh sources ### ok( $CB->reload_indices( update_source => 0 ), "Rebuilding trees" ); -my $AuthName = 'EUNOXS'; +my $AuthName = TEST_CONF_AUTHOR; my $Auth = $CB->author_tree( $AuthName ); my $ModName = TEST_CONF_MODULE; my $Mod = $CB->module_tree( $ModName ); @@ -173,6 +173,19 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); } } +### 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" ); + } +} + { ### details() test ### my $href = { 'Support Level' => 'Developer', diff --git a/lib/CPANPLUS/t/15_CPANPLUS-Shell.t b/lib/CPANPLUS/t/15_CPANPLUS-Shell.t index 09ab382..2a7e8c6 100644 --- a/lib/CPANPLUS/t/15_CPANPLUS-Shell.t +++ b/lib/CPANPLUS/t/15_CPANPLUS-Shell.t @@ -23,6 +23,14 @@ 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; @@ -55,6 +63,7 @@ isa_ok( $Shell, $Default, " Object" ); 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 @@ -85,13 +94,17 @@ isa_ok( $Shell, $Default, " Object" ); '/? ?' => 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/ }, - "/cs --contents $cs_uri" => qr/$TestAuth/, + "/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/, - "/cs --write $cs_path" => qr/Wrote remote source index/, + + ### --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/, ); diff --git a/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t index 58f18fc..315cea6 100644 --- a/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t +++ b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t @@ -21,12 +21,17 @@ use File::Spec (); my $conf = gimme_conf(); my $cb = CPANPLUS::Backend->new( $conf ); -my $noperms = ($< and not $conf->get_program('sudo')) && - ($conf->get_conf('makemakerflags') or - not -w $Config{installsitelib} ); my $File = 'Bar.pm'; my $Verbose = @ARGV ? 1 : 0; +### 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 @@ -121,10 +126,8 @@ $cb->_flush( list => [qw|lib|] ); SKIP: { - skip(q[No install tests under core perl], 10) if $ENV{PERL_CORE}; - - skip(q[Probably no permissions to install, skipping], 10) - if $noperms; + skip(q[No install tests under core perl], 10) if $ENV{PERL_CORE}; + skip(q[Possibly no permission to install, skipping], 10) if $noperms; ### XXX new EU::I should be forthcoming pending this patch from Steffen ### Mueller on p5p: http://www.xray.mpe.mpg.de/mailing-lists/ \ @@ -136,8 +139,9 @@ SKIP: { diag('other dirs than those in %Config. See bug #6871 on rt.cpan.org ' ); diag('for details'); - diag(q[Note: 'sudo' might ask for your password to do the install test]) - if $conf->get_program('sudo'); + ### 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 diff --git a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t index 1f71307..00c8173 100644 --- a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t +++ b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t @@ -24,6 +24,10 @@ my $conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $conf ); my $ModName = TEST_CONF_MODULE; my $ModPrereq = TEST_CONF_PREREQ; + +### divide by many -- possibly ~0 is unsigned, and we cause an overflow, +### as happens to version.pm 0.7203 among others. +my $HighVersion = ~0/1000; my $Mod = $CB->module_tree($ModName); my $int_ver = $CPANPLUS::Internals::VERSION; @@ -104,7 +108,7 @@ my $map = { pre_hook => sub { my $mod = shift; my $clone = $mod->clone; - $clone->status->prereqs( { $ModPrereq => ~0 } ); + $clone->status->prereqs({ $ModPrereq => $HighVersion }); return $clone; }, failed => 1, @@ -274,9 +278,7 @@ my $map = { { my $clone = $Mod->clone; - ### divide by two -- possibly ~0 is unsigned, and we cause an overflow, - ### as happens to version.pm 0.7203 among others. - my $prereqs = { $ModPrereq => ~0/2 }; + my $prereqs = { $ModPrereq => $HighVersion }; $clone->status->prereqs( $prereqs ); diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed index 1015e11..c9546f8 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed -Created at Tue Oct 9 17:23:14 2007 +Created at Sun Nov 4 11:24:49 2007 ######################################################################### __UU__ M'XL("%_EO$4``S`Q;6%I;')C+G1X=`!+S,E,+%9P#8T(5@`#)=>*DM"2S)QB diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed index 55e297c..0c22cdc 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed -Created at Tue Oct 9 17:23:14 2007 +Created at Sun Nov 4 11:24:49 2007 ######################################################################### __UU__ M'XL("!1%OT4"`T)U;F1L92U&;V\M0F%R+3`N,#$N=&%R`.V7:V_:,!2&^8I_ diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed index 28bec40..71e0feb 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed -Created at Tue Oct 9 17:23:14 2007 +Created at Sun Nov 4 11:24:50 2007 ######################################################################### __UU__ M'XL("/8X34("`T9O;RU"87(M,"XP,2YT87(`[9KQ;]I&%,?Y^?Z*1YE$(A5C diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed index d720eaa..8a25510 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed -Created at Tue Oct 9 17:23:14 2007 +Created at Sun Nov 4 11:24:50 2007 ######################################################################### __UU__ M'XL(`'3DO44``^W/,0J`,`Q`T1RE)Y"T-O4XXN"DB%2]OR(*NNC4[;_E#\F0 diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed index 12b23d8..cc106ad 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed -Created at Tue Oct 9 17:23:14 2007 +Created at Sun Nov 4 11:24:50 2007 ######################################################################### __UU__ M'XL("`DY34("`T9O;RU"87(M,"XP,2YT87(`[5IK3]M(%,U7YE='0`E=-1:]LP$`?P=WV* -M>]C#"K&L.IB"GA9GR=B6=&6=:=^*9ET345LRTKE>]NDG-2OMPK)VA\$@GW[Z -M'\A+TZ*$QQ)%KYH[M<'`-9(R;>#T@UC]=?74`UNB7N;Y.(Z\1]_RQG7Y_&)V -MGG=.#RV&_(CR'D/C34_&V:A=[%O`J@X#W+K!:C`6M/'8D/,[>/-@JH&VSH?< -MZ)S-73MT-OR.TC\#)G"//D1X$I=IRSY:0JM19TOG)!349S`]QW,K/:H -M`O_LT)K-.V5-I^+,;!7Y;!YGHK3]5)R5)5NI0%G=ZQ1$PA7J"4P%?%(6"B$* -M$*4LXG,&'];?&%LZ)V6EO)2+6LKK2S@HP<5I>B_JZ\L\-F>Q-TN+G)3GFY_/ -M@'7U+V!=O0HX_W)(/`'IVPM$&N(XL:A?)`[C_P=1Q9L5[[@\1AT0^_;L;])\ -'0`G=-1;],P$`#@=_^* +M>^`!I,;Q4D63_$136@2T8Z)$VQORXEMKD=B1?5DHOQY[9=JH*#!.EB+9Y\]W +M5KPT+4IX"%'TJOFJMABX1E*F#9R^$:L_K1YS8$?4RSP?QY'WZ%O>N"Z?7\XN +M\L[IH<60GU#>8&B\ZQ&G:L7>6T&K4V=)Y";.!7*<(-=PB-3OP;B!C +M,4P.AT<(0;MFZ-"22N5Q=N4-12*K]NFTKM4FT*C2YI=W4/"I*%[!S1YF5GM4 +M@7]P:,WVM;*F4[%GMHI\-H\]4=I^)L[+DJU4H*SN=2I$PA7J"4P%O%<6"B$* +M$*4LXCB'M^O/C"V=D[)27LI%+>7U!HY"<'&6OHOZ>I/'Y"SF9FF2D_)\^_T) +ML*[^!*RK?P(N/AX3CT!:^PN1FCA-+.IG$%)NAIO_(8YOX!E$%7_.^$SD*>J( +B.*1GOY/FHSY5QWT4OTKI?95 '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'; @@ -136,12 +137,25 @@ sub gimme_conf { ### during tests. They might hold broken/incorrect data ### for our test suite. Bug [perl #43629] showed this. my $conf = CPANPLUS::Configure->new( load_configs => 0 ); + + ### 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'; + $conf->set_conf( hosts => [ { - path => File::Spec->rel2abs(TEST_CONF_CPAN_DIR), + path => $abs_test_dir, scheme => 'file', } ], ); - $conf->set_conf( base => 'dummy-cpanplus' ); + $conf->set_conf( base => File::Spec->rel2abs('dummy-cpanplus') ); $conf->set_conf( dist_type => '' ); $conf->set_conf( signature => 0 ); $conf->set_conf( verbose => 1 ) if $ENV{ $Env }; @@ -241,28 +255,31 @@ sub _clean_test_dir { my $path = File::Spec->catfile( $dir, $file ); - ### 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 ); - ### directory, rmtree it if( -d $path ) { - print "# Deleting directory '$path'\n" if $verbose; - eval { rmtree( $path ) }; - warn "Could not delete '$path' while cleaning up '$dir'" if $@; + + ### 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 {