In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/bfab049986675c47a6b5030ff9c8f39c28e7945e?hp=4d5d35d9def298c0adab2e34a187efa998cea923>
- Log ----------------------------------------------------------------- commit bfab049986675c47a6b5030ff9c8f39c28e7945e Author: Chris 'BinGOs' Williams <[email protected]> Date: Sun Jul 19 12:28:00 2015 +0100 Fix test that fails with new warny File::Path M t/op/threads-dirh.t commit 139271cd3e9cb3cf25072ebdd400e52275c61b96 Author: Chris 'BinGOs' Williams <[email protected]> Date: Sun Jul 19 12:06:09 2015 +0100 Update File-Path to CPAN version 2.11 [DELTA] 2.11 2015-07-17 - Change argument check error from croak to carp since there are some dependent modules using non-standard options. The error check will move back to croak when dependent modules have the opportunity to correct the argument. 2.10_005 2015-07-17 - Better argument checking and reporting of failure for unrecognized options. - RT 71562 Document automount race condition limitation and workaround - RT 99230 Document multithreaded application limitation and that the limitation may be removed in a future release. 2.10_004 2015-07-10 - Remove use of English.pm since it breaks many older Perls - Fix a unit test skip count for users who have not installed Test::Output 2.10_003 2015-07-08 - Administrative changes to MANIFEST and MANIFEST.SKIP - Style changes to Path.pm for easier reading of code - Removal of pod.t - Use English.pm to make variables like $! more fluent for code readers 2.10_002 2015-06-26 - RT 42139. Add better SKIP test emit for VMS. - RT 85360. Fix typos and better .gitignore and MANIFEST.SKIP settings. - RT 51588. Added patch elements but unable to verify on VMS. 2.10_001 2015-06-24 - RT 39949. Report errors on lstat failure. - RT 53178. Deprecate UNIVERSAL::isa usage - RT 70657. Test added. - RT 70938. Documentation fix for Windows native relative usage - RT 72256. Option added for setting permission (chmod) - RT 73840. Fix taint/untaint bug. - RT 95150. Add CPAN metadata for source tree location. - RT 103512. Documentation language fix. M Porting/Maintainers.pl M cpan/File-Path/lib/File/Path.pm M cpan/File-Path/t/Path.t commit db95646430f250935e9615b04eecb9c0d138c515 Author: Chris 'BinGOs' Williams <[email protected]> Date: Sun Jul 19 12:01:48 2015 +0100 Update libnet to CPAN version 3.07 [DELTA] 3.07 2015-07-17 - Net::FTP::rmdir() has been made more robust by making use of the MLSD command in addition to the NLST command since the latter is known not to be processed correctly by some FTP servers. [Chris Lindee, CPAN RT#100694] - Net::FTP, Net::NNTP, Net::POP3 and Net::SMTP can now restrict domain to IPv4 even if IPv6 is available by using the new Domain or Family argument. Net::NNTP now supports the LocalPort argument in addition to LocalAddr. Net::POP3 now supports the LocalAddr and LocalPort arguments in addition to ResvPort (which is retained for backwards compatibility). [Steffen Ullrich, PR#18] - Fixed a bug in Net::Cmd::datasend() which caused octets in [\x80-\xFF] stored in a "binary string" to be replaced with their UTF-8 encodings if the string happened to be stored internally in an "upgraded" state (i.e. with the UTF-8 flag on). (As noted below, strings passed to datasend() should always be encoded first, and therefore not stored in such a state anyway, but it is all too easy for perl to change this internal state unless the encodeing is done at the very last minute before calling datasend(), so it helps if datasend() plays more nicely in this case. In particular, it was wrong of datasend() to treat upgraded and downgraded strings differently when their contents were identical at the Perl level.) This bugfix results in a breaking change to the case of a "text string" with characters in U+0080..U+00FF stored internally in an upgraded state since those characters are likewise no longer encoded to UTF-8 by datasend(), but callers of datasend() should not have been relying on this behaviour anyway: In general, datasend() has no idea what encoding is required for output so callers should always encode the data to be output to whatever encoding is required first. This has now been clarified in the documentation. Finally, a text string with characters >= U+0100 will now cause a "Wide character in print" warning from datasend() since such characters cannot be output as bytes and datasend() no longer encodes to UTF-8. In this case, UTF-8 bytes will still be output as before since that happens to be the internal representation of such characters, but the warning is new. Callers should heed this warning and encode such strings to whatever encoding is required before calling datasend(), as noted above. [Ricardo Signes, CPAN RT#104433] M Porting/Maintainers.pl M cpan/libnet/Makefile.PL M cpan/libnet/lib/Net/Cmd.pm M cpan/libnet/lib/Net/Config.pm M cpan/libnet/lib/Net/Domain.pm M cpan/libnet/lib/Net/FTP.pm M cpan/libnet/lib/Net/FTP/A.pm M cpan/libnet/lib/Net/FTP/E.pm M cpan/libnet/lib/Net/FTP/I.pm M cpan/libnet/lib/Net/FTP/L.pm M cpan/libnet/lib/Net/FTP/dataconn.pm M cpan/libnet/lib/Net/NNTP.pm M cpan/libnet/lib/Net/Netrc.pm M cpan/libnet/lib/Net/POP3.pm M cpan/libnet/lib/Net/SMTP.pm M cpan/libnet/lib/Net/Time.pm M cpan/libnet/t/datasend.t ----------------------------------------------------------------------- Summary of changes: Porting/Maintainers.pl | 6 +- cpan/File-Path/lib/File/Path.pm | 544 ++++++++++++++++++++++++------------ cpan/File-Path/t/Path.t | 237 ++++++++++++++-- cpan/libnet/Makefile.PL | 5 +- cpan/libnet/lib/Net/Cmd.pm | 38 ++- cpan/libnet/lib/Net/Config.pm | 4 +- cpan/libnet/lib/Net/Domain.pm | 2 +- cpan/libnet/lib/Net/FTP.pm | 53 +++- cpan/libnet/lib/Net/FTP/A.pm | 2 +- cpan/libnet/lib/Net/FTP/E.pm | 2 +- cpan/libnet/lib/Net/FTP/I.pm | 2 +- cpan/libnet/lib/Net/FTP/L.pm | 2 +- cpan/libnet/lib/Net/FTP/dataconn.pm | 2 +- cpan/libnet/lib/Net/NNTP.pm | 41 ++- cpan/libnet/lib/Net/Netrc.pm | 2 +- cpan/libnet/lib/Net/POP3.pm | 33 ++- cpan/libnet/lib/Net/SMTP.pm | 36 ++- cpan/libnet/lib/Net/Time.pm | 2 +- cpan/libnet/t/datasend.t | 9 +- t/op/threads-dirh.t | 2 +- 20 files changed, 731 insertions(+), 293 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index c258f7d..4a7debb 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -533,11 +533,13 @@ use File::Glob qw(:case); }, 'File::Path' => { - 'DISTRIBUTION' => 'DLAND/File-Path-2.09.tar.gz', + 'DISTRIBUTION' => 'RICHE/File-Path-2.11.tar.gz', 'FILES' => q[cpan/File-Path], 'EXCLUDED' => [ qw( eg/setup-extra-tests t/pod.t + t/Path-Class.t + README.md ) ], 'MAP' => { @@ -705,7 +707,7 @@ use File::Glob qw(:case); }, 'libnet' => { - 'DISTRIBUTION' => 'SHAY/libnet-3.06.tar.gz', + 'DISTRIBUTION' => 'SHAY/libnet-3.07.tar.gz', 'FILES' => q[cpan/libnet], 'EXCLUDED' => [ qw( Configure diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm index 23751d5..3ee17bc 100644 --- a/cpan/File-Path/lib/File/Path.pm +++ b/cpan/File-Path/lib/File/Path.pm @@ -8,30 +8,38 @@ use File::Basename (); use File::Spec (); BEGIN { - if ($] < 5.006) { + if ( $] < 5.006 ) { + # can't say 'opendir my $dh, $dirname' # need to initialise $dh - eval "use Symbol"; + eval 'use Symbol'; } } use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = '2.09'; +$VERSION = '2.11'; +$VERSION = eval $VERSION; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @EXPORT_OK = qw(make_path remove_tree); -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; +BEGIN { + for (qw(VMS MacOS MSWin32 os2)) { + no strict 'refs'; + *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 }; + } -# These OSes complain if you want to remove a file that you have no -# write permission to: -my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); + # These OSes complain if you want to remove a file that you have no + # write permission to: + *_FORCE_WRITABLE = ( + grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2) + ) ? sub () { 1 } : sub () { 0 }; -# Unix-like systems need to stat each directory in order to detect -# race condition. MS-Windows is immune to this particular attack. -my $Need_Stat_Check = !($^O eq 'MSWin32'); + # Unix-like systems need to stat each directory in order to detect + # race condition. MS-Windows is immune to this particular attack. + *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 }; +} sub _carp { require Carp; @@ -48,109 +56,152 @@ sub _error { my $message = shift; my $object = shift; - if ($arg->{error}) { + if ( $arg->{error} ) { $object = '' unless defined $object; $message .= ": $!" if $!; - push @{${$arg->{error}}}, {$object => $message}; + push @{ ${ $arg->{error} } }, { $object => $message }; } else { - _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); + _carp( defined($object) ? "$message for $object: $!" : "$message: $!" ); } } +sub __is_arg { + my ($arg) = @_; + + # If client code blessed an array ref to HASH, this will not work + # properly. We could have done $arg->isa() wrapped in eval, but + # that would be expensive. This implementation should suffice. + # We could have also used Scalar::Util:blessed, but we choose not + # to add this dependency + return ( ref $arg eq 'HASH' ); +} + sub make_path { - push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + push @_, {} unless @_ and __is_arg( $_[-1] ); goto &mkpath; } sub mkpath { - my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + my $old_style = !( @_ and __is_arg( $_[-1] ) ); my $arg; my $paths; if ($old_style) { - my ($verbose, $mode); - ($paths, $verbose, $mode) = @_; - $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + my ( $verbose, $mode ); + ( $paths, $verbose, $mode ) = @_; + $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); $arg->{verbose} = $verbose; - $arg->{mode} = defined $mode ? $mode : 0777; + $arg->{mode} = defined $mode ? $mode : oct '777'; } else { + my %args_permitted = map { $_ => 1 } ( qw| + chmod + error + group + mask + mode + owner + uid + user + verbose + | ); + my @bad_args = (); $arg = pop @_; - $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; - $arg->{mode} = 0777 unless exists $arg->{mode}; - ${$arg->{error}} = [] if exists $arg->{error}; - $arg->{owner} = delete $arg->{user} if exists $arg->{user}; - $arg->{owner} = delete $arg->{uid} if exists $arg->{uid}; - if (exists $arg->{owner} and $arg->{owner} =~ /\D/) { - my $uid = (getpwnam $arg->{owner})[2]; - if (defined $uid) { + for my $k (sort keys %{$arg}) { + push @bad_args, $k unless $args_permitted{$k}; + } + _carp("Unrecognized option(s) passed to make_path(): @bad_args") + if @bad_args; + $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; + $arg->{mode} = oct '777' unless exists $arg->{mode}; + ${ $arg->{error} } = [] if exists $arg->{error}; + $arg->{owner} = delete $arg->{user} if exists $arg->{user}; + $arg->{owner} = delete $arg->{uid} if exists $arg->{uid}; + if ( exists $arg->{owner} and $arg->{owner} =~ /\D/ ) { + my $uid = ( getpwnam $arg->{owner} )[2]; + if ( defined $uid ) { $arg->{owner} = $uid; } else { - _error($arg, "unable to map $arg->{owner} to a uid, ownership not changed"); + _error( $arg, +"unable to map $arg->{owner} to a uid, ownership not changed" + ); delete $arg->{owner}; } } - if (exists $arg->{group} and $arg->{group} =~ /\D/) { - my $gid = (getgrnam $arg->{group})[2]; - if (defined $gid) { + if ( exists $arg->{group} and $arg->{group} =~ /\D/ ) { + my $gid = ( getgrnam $arg->{group} )[2]; + if ( defined $gid ) { $arg->{group} = $gid; } else { - _error($arg, "unable to map $arg->{group} to a gid, group ownership not changed"); + _error( $arg, +"unable to map $arg->{group} to a gid, group ownership not changed" + ); delete $arg->{group}; } } - if (exists $arg->{owner} and not exists $arg->{group}) { - $arg->{group} = -1; # chown will leave group unchanged + if ( exists $arg->{owner} and not exists $arg->{group} ) { + $arg->{group} = -1; # chown will leave group unchanged } - if (exists $arg->{group} and not exists $arg->{owner}) { - $arg->{owner} = -1; # chown will leave owner unchanged + if ( exists $arg->{group} and not exists $arg->{owner} ) { + $arg->{owner} = -1; # chown will leave owner unchanged } $paths = [@_]; } - return _mkpath($arg, $paths); + return _mkpath( $arg, $paths ); } sub _mkpath { my $arg = shift; my $paths = shift; - my(@created,$path); - foreach $path (@$paths) { + my ( @created ); + foreach my $path ( @{$paths} ) { next unless defined($path) and length($path); - $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT + $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT + # Logic wants Unix paths, so go with the flow. - if ($Is_VMS) { + if (_IS_VMS) { next if $path eq '/'; $path = VMS::Filespec::unixify($path); } next if -d $path; my $parent = File::Basename::dirname($path); - unless (-d $parent or $path eq $parent) { - push(@created,_mkpath($arg, [$parent])); + unless ( -d $parent or $path eq $parent ) { + push( @created, _mkpath( $arg, [$parent] ) ); } print "mkdir $path\n" if $arg->{verbose}; - if (mkdir($path,$arg->{mode})) { - push(@created, $path); - if (exists $arg->{owner}) { - # NB: $arg->{group} guaranteed to be set during initialisation - if (!chown $arg->{owner}, $arg->{group}, $path) { - _error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}"); + if ( mkdir( $path, $arg->{mode} ) ) { + push( @created, $path ); + if ( exists $arg->{owner} ) { + + # NB: $arg->{group} guaranteed to be set during initialisation + if ( !chown $arg->{owner}, $arg->{group}, $path ) { + _error( $arg, +"Cannot change ownership of $path to $arg->{owner}:$arg->{group}" + ); + } + } + if ( exists $arg->{chmod} ) { + if ( !chmod $arg->{chmod}, $path ) { + _error( $arg, + "Cannot change permissions of $path to $arg->{chmod}" ); } } } else { my $save_bang = $!; - my ($e, $e1) = ($save_bang, $^E); + my ( $e, $e1 ) = ( $save_bang, $^E ); $e .= "; $e1" if $e ne $e1; + # allow for another process to have created it meanwhile - if (!-d $path) { + if ( ! -d $path ) { $! = $save_bang; - if ($arg->{error}) { - push @{${$arg->{error}}}, {$path => $e}; + if ( $arg->{error} ) { + push @{ ${ $arg->{error} } }, { $path => $e }; } else { _croak("mkdir $path: $e"); @@ -162,15 +213,15 @@ sub _mkpath { } sub remove_tree { - push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + push @_, {} unless @_ and __is_arg( $_[-1] ); goto &rmtree; } sub _is_subdir { - my($dir, $test) = @_; + my ( $dir, $test ) = @_; - my($dv, $dd) = File::Spec->splitpath($dir, 1); - my($tv, $td) = File::Spec->splitpath($test, 1); + my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 ); + my ( $tv, $td ) = File::Spec->splitpath( $test, 1 ); # not on same volume return 0 if $dv ne $tv; @@ -181,33 +232,46 @@ sub _is_subdir { # @t can't be a subdir if it's shorter than @d return 0 if @t < @d; - return join('/', @d) eq join('/', splice @t, 0, +@d); + return join( '/', @d ) eq join( '/', splice @t, 0, +@d ); } sub rmtree { - my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + my $old_style = !( @_ and __is_arg( $_[-1] ) ); my $arg; my $paths; if ($old_style) { - my ($verbose, $safe); - ($paths, $verbose, $safe) = @_; + my ( $verbose, $safe ); + ( $paths, $verbose, $safe ) = @_; $arg->{verbose} = $verbose; - $arg->{safe} = defined $safe ? $safe : 0; + $arg->{safe} = defined $safe ? $safe : 0; - if (defined($paths) and length($paths)) { - $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + if ( defined($paths) and length($paths) ) { + $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); } else { - _carp ("No root path(s) specified\n"); + _carp("No root path(s) specified\n"); return 0; } } else { + my %args_permitted = map { $_ => 1 } ( qw| + error + keep_root + result + safe + verbose + | ); + my @bad_args = (); $arg = pop @_; - ${$arg->{error}} = [] if exists $arg->{error}; - ${$arg->{result}} = [] if exists $arg->{result}; + for my $k (sort keys %{$arg}) { + push @bad_args, $k unless $args_permitted{$k}; + } + _carp("Unrecognized option(s) passed to remove_tree(): @bad_args") + if @bad_args; + ${ $arg->{error} } = [] if exists $arg->{error}; + ${ $arg->{result} } = [] if exists $arg->{result}; $paths = [@_]; } @@ -216,28 +280,30 @@ sub rmtree { my @clean_path; $arg->{cwd} = getcwd() or do { - _error($arg, "cannot fetch initial working directory"); + _error( $arg, "cannot fetch initial working directory" ); return 0; }; - for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint + for ( $arg->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint for my $p (@$paths) { + # need to fixup case and map \ to / on Windows - my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p; - my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd}; + my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p; + my $ortho_cwd = + _IS_MSWIN32 ? _slash_lc( $arg->{cwd} ) : $arg->{cwd}; my $ortho_root_length = length($ortho_root); - $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']' - if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) { + $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']' + if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { local $! = 0; - _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p); + _error( $arg, "cannot remove path when cwd is $arg->{cwd}", $p ); next; } - if ($Is_MacOS) { - $p = ":$p" unless $p =~ /:/; - $p .= ":" unless $p =~ /:\z/; + if (_IS_MACOS) { + $p = ":$p" unless $p =~ /:/; + $p .= ":" unless $p =~ /:\z/; } - elsif ($^O eq 'MSWin32') { + elsif ( _IS_MSWIN32 ) { $p =~ s{[/\\]\z}{}; } else { @@ -246,12 +312,12 @@ sub rmtree { push @clean_path, $p; } - @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do { - _error($arg, "cannot stat initial working directory", $arg->{cwd}); + @{$arg}{qw(device inode perm)} = ( lstat $arg->{cwd} )[ 0, 1 ] or do { + _error( $arg, "cannot stat initial working directory", $arg->{cwd} ); return 0; }; - return _rmtree($arg, \@clean_path); + return _rmtree( $arg, \@clean_path ); } sub _rmtree { @@ -262,74 +328,94 @@ sub _rmtree { my $curdir = File::Spec->curdir(); my $updir = File::Spec->updir(); - my (@files, $root); - ROOT_DIR: - foreach $root (@$paths) { + my ( @files, $root ); + ROOT_DIR: + foreach my $root (@$paths) { + # since we chdir into each directory, it may not be obvious # to figure out where we are if we generate a message about # a file name. We therefore construct a semi-canonical # filename, anchored from the directory being unlinked (as # opposed to being truly canonical, anchored from the root (/). - my $canon = $arg->{prefix} - ? File::Spec->catfile($arg->{prefix}, $root) - : $root - ; + my $canon = + $arg->{prefix} + ? File::Spec->catfile( $arg->{prefix}, $root ) + : $root; - my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; + my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] + or ( _error( $arg, "$root", $root ) and next ROOT_DIR ); if ( -d _ ) { - $root = VMS::Filespec::vmspath(VMS::Filespec::pathify($root)) if $Is_VMS; + $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) ) + if _IS_VMS; + + if ( !chdir($root) ) { - if (!chdir($root)) { # see if we can escalate privileges to get in # (e.g. funny protection mask such as -w- instead of rwx) - $perm &= 07777; - my $nperm = $perm | 0700; - if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { - _error($arg, "cannot make child directory read-write-exec", $canon); + $perm &= oct '7777'; + my $nperm = $perm | oct '700'; + if ( + !( + $arg->{safe} + or $nperm == $perm + or chmod( $nperm, $root ) + ) + ) + { + _error( $arg, + "cannot make child directory read-write-exec", $canon ); next ROOT_DIR; } - elsif (!chdir($root)) { - _error($arg, "cannot chdir to child", $canon); + elsif ( !chdir($root) ) { + _error( $arg, "cannot chdir to child", $canon ); next ROOT_DIR; } } - my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do { - _error($arg, "cannot stat current working directory", $canon); + my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ] + or do { + _error( $arg, "cannot stat current working directory", $canon ); next ROOT_DIR; - }; + }; - if ($Need_Stat_Check) { - ($ldev eq $cur_dev and $lino eq $cur_inode) - or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); + if (_NEED_STAT_CHECK) { + ( $ldev eq $cur_dev and $lino eq $cur_inode ) + or _croak( +"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting." + ); } - $perm &= 07777; # don't forget setuid, setgid, sticky bits - my $nperm = $perm | 0700; + $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits + my $nperm = $perm | oct '700'; # notabene: 0700 is for making readable in the first place, # it's also intended to change it to writable in case we have - # to recurse in which case we are better than rm -rf for + # to recurse in which case we are better than rm -rf for # subtrees with strange permissions - if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) { - _error($arg, "cannot make directory read+writeable", $canon); + if ( + !( + $arg->{safe} + or $nperm == $perm + or chmod( $nperm, $curdir ) + ) + ) + { + _error( $arg, "cannot make directory read+writeable", $canon ); $nperm = $perm; } my $d; $d = gensym() if $] < 5.006; - if (!opendir $d, $curdir) { - _error($arg, "cannot opendir", $canon); + if ( !opendir $d, $curdir ) { + _error( $arg, "cannot opendir", $canon ); @files = (); } else { - no strict 'refs'; - if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { - # Blindly untaint dir names if taint mode is - # active, or any perl < 5.006 + if ( !defined ${^TAINT} or ${^TAINT} ) { + # Blindly untaint dir names if taint mode is active @files = map { /\A(.*)\z/s; $1 } readdir $d; } else { @@ -338,63 +424,85 @@ sub _rmtree { closedir $d; } - if ($Is_VMS) { + if (_IS_VMS) { + # Deleting large numbers of files from VMS Files-11 # filesystems is faster if done in reverse ASCIIbetical order. # include '.' to '.;' from blead patch #31775 - @files = map {$_ eq '.' ? '.;' : $_} reverse @files; + @files = map { $_ eq '.' ? '.;' : $_ } reverse @files; } - @files = grep {$_ ne $updir and $_ ne $curdir} @files; + @files = grep { $_ ne $updir and $_ ne $curdir } @files; if (@files) { + # remove the contained files before the directory itself my $narg = {%$arg}; - @{$narg}{qw(device inode cwd prefix depth)} - = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1); - $count += _rmtree($narg, \@files); + @{$narg}{qw(device inode cwd prefix depth)} = + ( $cur_dev, $cur_inode, $updir, $canon, $arg->{depth} + 1 ); + $count += _rmtree( $narg, \@files ); } # restore directory permissions of required now (in case the rmdir # below fails), while we are still in the directory and may do so # without a race via '.' - if ($nperm != $perm and not chmod($perm, $curdir)) { - _error($arg, "cannot reset chmod", $canon); + if ( $nperm != $perm and not chmod( $perm, $curdir ) ) { + _error( $arg, "cannot reset chmod", $canon ); } # don't leave the client code in an unexpected directory - chdir($arg->{cwd}) - or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); + chdir( $arg->{cwd} ) + or + _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); # ensure that a chdir upwards didn't take us somewhere other # than we expected (see CVE-2002-0435) - ($cur_dev, $cur_inode) = (stat $curdir)[0,1] - or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); - - if ($Need_Stat_Check) { - ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode) - or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); + ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ] + or _croak( + "cannot stat prior working directory $arg->{cwd}: $!, aborting." + ); + + if (_NEED_STAT_CHECK) { + ( $arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode ) + or _croak( "previous directory $arg->{cwd} " + . "changed before entering $canon, " + . "expected dev=$ldev ino=$lino, " + . "actual dev=$cur_dev ino=$cur_inode, aborting." + ); } - if ($arg->{depth} or !$arg->{keep_root}) { - if ($arg->{safe} && - ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + if ( $arg->{depth} or !$arg->{keep_root} ) { + if ( $arg->{safe} + && ( _IS_VMS + ? !&VMS::Filespec::candelete($root) + : !-w $root ) ) + { print "skipped $root\n" if $arg->{verbose}; next ROOT_DIR; } - if ($Force_Writeable and !chmod $perm | 0700, $root) { - _error($arg, "cannot make directory writeable", $canon); + if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) { + _error( $arg, "cannot make directory writeable", $canon ); } print "rmdir $root\n" if $arg->{verbose}; - if (rmdir $root) { - push @{${$arg->{result}}}, $root if $arg->{result}; + if ( rmdir $root ) { + push @{ ${ $arg->{result} } }, $root if $arg->{result}; ++$count; } else { - _error($arg, "cannot remove directory", $canon); - if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) - ) { - _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + _error( $arg, "cannot remove directory", $canon ); + if ( + _FORCE_WRITABLE + && !chmod( $perm, + ( _IS_VMS ? VMS::Filespec::fileify($root) : $root ) + ) + ) + { + _error( + $arg, + sprintf( "cannot restore permissions to 0%o", + $perm ), + $canon + ); } } } @@ -402,36 +510,47 @@ sub _rmtree { else { # not a directory $root = VMS::Filespec::vmsify("./$root") - if $Is_VMS - && !File::Spec->file_name_is_absolute($root) - && ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax - - if ($arg->{safe} && - ($Is_VMS ? !&VMS::Filespec::candelete($root) - : !(-l $root || -w $root))) + if _IS_VMS + && !File::Spec->file_name_is_absolute($root) + && ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax + + if ( + $arg->{safe} + && ( + _IS_VMS + ? !&VMS::Filespec::candelete($root) + : !( -l $root || -w $root ) + ) + ) { print "skipped $root\n" if $arg->{verbose}; next ROOT_DIR; } - my $nperm = $perm & 07777 | 0600; - if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) { - _error($arg, "cannot make file writeable", $canon); + my $nperm = $perm & oct '7777' | oct '600'; + if ( _FORCE_WRITABLE + and $nperm != $perm + and not chmod $nperm, $root ) + { + _error( $arg, "cannot make file writeable", $canon ); } print "unlink $canon\n" if $arg->{verbose}; + # delete all versions under VMS - for (;;) { - if (unlink $root) { - push @{${$arg->{result}}}, $root if $arg->{result}; + for ( ; ; ) { + if ( unlink $root ) { + push @{ ${ $arg->{result} } }, $root if $arg->{result}; } else { - _error($arg, "cannot unlink file", $canon); - $Force_Writeable and chmod($perm, $root) or - _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + _error( $arg, "cannot unlink file", $canon ); + _FORCE_WRITABLE and chmod( $perm, $root ) + or _error( $arg, + sprintf( "cannot restore permissions to 0%o", $perm ), + $canon ); last; } ++$count; - last unless $Is_VMS && lstat $root; + last unless _IS_VMS && lstat $root; } } } @@ -439,6 +558,7 @@ sub _rmtree { } sub _slash_lc { + # fix up slashes and case on MSWin32 so that we can determine that # c:\path\to\dir is underneath C:/Path/To my $path = shift; @@ -447,6 +567,7 @@ sub _slash_lc { } 1; + __END__ =head1 NAME @@ -462,28 +583,31 @@ This document describes version 2.09 of File::Path, released use File::Path qw(make_path remove_tree); - make_path('foo/bar/baz', '/zug/zwang'); - make_path('foo/bar/baz', '/zug/zwang', { + @created = make_path('foo/bar/baz', '/zug/zwang'); + @created = make_path('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711, }); + make_path('foo/bar/baz', '/zug/zwang', { + chmod => 0777, + }); - remove_tree('foo/bar/baz', '/zug/zwang'); - remove_tree('foo/bar/baz', '/zug/zwang', { + $removed_count = remove_tree('foo/bar/baz', '/zug/zwang'); + $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', { verbose => 1, error => \my $err_list, }); # legacy (interface promoted before v2.00) - mkpath('/foo/bar/baz'); - mkpath('/foo/bar/baz', 1, 0711); - mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); - rmtree('foo/bar/baz', 1, 1); - rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); + @created = mkpath('/foo/bar/baz'); + @created = mkpath('/foo/bar/baz', 1, 0711); + @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + $removed_count = rmtree('foo/bar/baz', 1, 1); + $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); # legacy (interface promoted before v2.06) - mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); - rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); =head1 DESCRIPTION @@ -522,6 +646,13 @@ the permissions will not be modified. C<mask> is recognised as an alias for this parameter. +=item chmod => $num + +Takes a numeric mode to apply to each created directory (not +modified by the current C<umask>). If the directory already exists +(and thus does not need to be created), the permissions will +not be modified. + =item verbose => $bool If present, will cause C<make_path> to print the name of each directory @@ -535,7 +666,7 @@ be used to store any errors that are encountered. See the L</"ERROR HANDLING"> section for more information. If this parameter is not used, certain error conditions may raise -a fatal error that will cause the program will halt, unless trapped +a fatal error that will cause the program to halt, unless trapped in an C<eval> block. =item owner => $owner @@ -550,7 +681,7 @@ as username is assumed. An error will be issued if the username cannot be mapped to a uid, or the uid does not exist, or the process lacks the privileges to change ownership. -Ownwership of directories that already exist will not be changed. +Ownership of directories that already exist will not be changed. C<user> and C<uid> are aliases of C<owner>. @@ -562,7 +693,7 @@ as group name is assumed. An error will be issued if the group name cannot be mapped to a gid, or the gid does not exist, or the process lacks the privileges to change group ownership. -Group ownwership of directories that already exist will not be changed. +Group ownership of directories that already exist will not be changed. make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'}; @@ -586,7 +717,7 @@ return value of the function is otherwise identical to make_path(). The C<remove_tree> function deletes the given directories and any files and subdirectories they might contain, much like the Unix -command C<rm -r> or C<del /s> on Windows. +command C<rm -r> or the Windows commands C<rmdir /s> and C<rd /s>. The function accepts a list of directories to be removed. Its behaviour may be tuned by an optional hashref @@ -709,7 +840,7 @@ An example usage looks like: Note that if no errors are encountered, C<$err> will reference an empty array. This means that C<$err> will always end up TRUE; so you -need to test C<@$err> to determine if errors occured. +need to test C<@$err> to determine if errors occurred. =head2 NOTES @@ -947,15 +1078,43 @@ to examining directory trees. =back -=head1 BUGS +=head1 BUGS AND LIMITATIONS + +The following describes F<File::Path> limitations and how to report bugs. + +=head2 MULTITHREAD APPLICATIONS + +F<File::Path> B<rmtree> and B<remove_tree> will not work with multithreaded +applications due to its use of B<chdir>. At this time, no warning or error +results and you will certainly encounter unexpected results. -Please report all bugs on the RT queue: +The implementation that surfaces this limitation may change in a future +release. + +=head2 NFS Mount Points + +F<File::Path> is not responsible for triggering the automounts, mirror mounts, +and the contents of network mounted filesystems. If your NFS implementation +requires an action to be performed on the filesystem in order for +F<File::Path> to perform operations, it is strongly suggested you assure +filesystem availability by reading the root of the mounted filesystem. + +=head2 REPORTING BUGS + +Please report all bugs on the RT queue, either via the web interface: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> +or by email: + + [email protected] + +In either case, please B<attach> patches to the bug report rather than +including them inline in the web post or the body of the email. + You can also send pull requests to the Github repository: -L<https://github.com/dland/File-Path> +L<https://github.com/rpcme/File-Path> =head1 ACKNOWLEDGEMENTS @@ -969,13 +1128,34 @@ Gisle Aas made a number of improvements to the documentation for =head1 AUTHORS -Tim Bunce and Charles Bailey. Currently maintained by David Landgren -<F<[email protected]>>. +Prior authors and maintainers: Tim Bunce, Charles Bailey, and +David Landgren <F<[email protected]>>. + +Current maintainers are Richard Elberger <F<[email protected]>> and +James (Jim) Keenan <F<[email protected]>>. + +=head1 CONTRIBUTORS + +Contributors to File::Path, in alphabetical order. + +=over 1 + +=item <F<[email protected]>> + +=item Richard Elberger <F<[email protected]>> + +=item Ryan Yee <F<[email protected]>> + +=item Skye Shaw <F<[email protected]>> + +=item Tom Lutz <F<[email protected]>> + +=back =head1 COPYRIGHT -This module is copyright (C) Charles Bailey, Tim Bunce and -David Landgren 1995-2013. All rights reserved. +This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren, +James Keenan, and Richard Elberger 1995-2015. All rights reserved. =head1 LICENSE diff --git a/cpan/File-Path/t/Path.t b/cpan/File-Path/t/Path.t index a33c15a..ea4d2b5 100644 --- a/cpan/File-Path/t/Path.t +++ b/cpan/File-Path/t/Path.t @@ -1,13 +1,18 @@ +#! /usr/bin/env perl # Path.t -- tests for module File::Path use strict; -use Test::More tests => 129; +use Test::More tests => 159; use Config; +use Fcntl ':mode'; BEGIN { + # 1 use_ok('Cwd'); + # 2 use_ok('File::Path', qw(rmtree mkpath make_path remove_tree)); + # 3 use_ok('File::Spec::Functions'); } @@ -24,10 +29,13 @@ for my $perm (0111,0777) { chmod $perm, "mhx", $path; my $oct = sprintf('0%o', $perm); + # 4 ok(-d "mhx", "mkdir parent dir $oct"); + # 5 ok(-d $path, "mkdir child dir $oct"); rmtree("mhx"); + # 6 ok(! -e "mhx", "mhx does not exist $oct"); } @@ -49,6 +57,7 @@ my @dir = ( # create them my @created = mkpath([@dir]); +# 7 is(scalar(@created), 7, "created list of directories"); # pray for no race conditions blowing them out from under us @@ -72,10 +81,12 @@ SKIP: { skip "cannot remove a file we failed to create", 1 unless $file_count == 1; my $count = rmtree($file_name); +# 8 is($count, 1, "rmtree'ed a file"); } @created = mkpath(''); +# 9 is(scalar(@created), 0, "Can't create a directory named ''"); my $dir; @@ -101,13 +112,16 @@ sub count { open my $f, '>', 'foo.dat'; close $f; my $before = count(curdir()); +# 10 cmp_ok($before, '>', 0, "baseline $before"); gisle('1st', 1); +# 11 is(count(curdir()), $before + 1, "first after $before"); $before = count(curdir()); gisle('2nd', 1); +# 12 is(count(curdir()), $before + 1, "second after $before"); chdir updir(); @@ -120,11 +134,13 @@ sub count { open my $f, '>', 'foo.dat'; close $f; my $before = count(curdir()); +# 13 cmp_ok($before, '>', 0, "ARGV $before"); { local @ARGV = (1); mkpath('3rd', !shift, 0755); } +# 14 is(count(curdir()), $before + 1, "third after $before"); $before = count(curdir()); @@ -132,6 +148,7 @@ sub count { local @ARGV = (1); mkpath('4th', !shift, 0755); } +# 15 is(count(curdir()), $before + 1, "fourth after $before"); chdir updir(); @@ -152,16 +169,21 @@ SKIP: { rmtree($dir, {error => \$error}); my $nr_err = @$error; +# 16 is($nr_err, 1, "ancestor error"); if ($nr_err) { my ($file, $message) = each %{$error->[0]}; +# 17 is($file, $dir, "ancestor named"); my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2; $^O eq 'MSWin32' and $message =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e; +# 18 is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason"); +# 19 ok(-d $dir2, "child not removed"); +# 20 ok(-d $dir, "ancestor not removed"); } else { @@ -172,14 +194,18 @@ SKIP: { } chdir $cwd; rmtree($dir); +# 21 ok(!(-d $dir), "ancestor now removed"); }; my $count = rmtree({error => \$error}); +# 22 is( $count, 0, 'rmtree of nothing, count of zero' ); +# 23 is( scalar(@$error), 0, 'no diagnostic captured' ); @created = mkpath($tmp_base, 0); +# 24 is(scalar(@created), 0, "skipped making existing directories (old style 1)") or diag("unexpectedly recreated @created"); @@ -187,10 +213,13 @@ $dir = catdir($tmp_base,'C'); # mkpath returns unix syntax filespecs on VMS $dir = VMS::Filespec::unixify($dir) if $Is_VMS; @created = make_path($tmp_base, $dir); +# 25 is(scalar(@created), 1, "created directory (new style 1)"); +# 26 is($created[0], $dir, "created directory (new style 1) cross-check"); @created = mkpath($tmp_base, 0, 0700); +# 27 is(scalar(@created), 0, "skipped making existing directories (old style 2)") or diag("unexpectedly recreated @created"); @@ -198,14 +227,18 @@ $dir2 = catdir($tmp_base,'D'); # mkpath returns unix syntax filespecs on VMS $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS; @created = make_path($tmp_base, $dir, $dir2); +# 28 is(scalar(@created), 1, "created directory (new style 2)"); +# 29 is($created[0], $dir2, "created directory (new style 2) cross-check"); $count = rmtree($dir, 0); +# 30 is($count, 1, "removed directory unsafe mode"); $count = rmtree($dir2, 0, 1); my $removed = $Is_VMS ? 0 : 1; +# 31 is($count, $removed, "removed directory safe mode"); # mkdir foo ./E/../Y @@ -213,11 +246,15 @@ is($count, $removed, "removed directory safe mode"); # existence of E is neither here nor there $dir = catdir($tmp_base, 'E', updir(), 'Y'); @created =mkpath($dir); +# 32 cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of .."); +# 33 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of .."); +# 34 ok( -d catdir($tmp_base, 'Y'), "directory after parent" ); @created = make_path(catdir(curdir(), $tmp_base)); +# 35 is(scalar(@created), 0, "nothing created") or diag(@created); @@ -232,11 +269,14 @@ rmtree( $dir, $dir2, } ); +# 36 is(scalar(@$error), 0, "no errors unlinking a and z"); +# 37 is(scalar(@$list), 4, "list contains 4 elements") or diag("@$list"); - +# 38 ok(-d $dir, "dir a still exists"); +# 39 ok(-d $dir2, "dir z still exists"); $dir = catdir($tmp_base,'F'); @@ -244,26 +284,38 @@ $dir = catdir($tmp_base,'F'); $dir = VMS::Filespec::unixify($dir) if $Is_VMS; @created = mkpath($dir, undef, 0770); +# 40 is(scalar(@created), 1, "created directory (old style 2 verbose undef)"); +# 41 is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check"); +# 42 is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef"); @created = mkpath($dir, undef); +# 43 is(scalar(@created), 1, "created directory (old style 2a verbose undef)"); +# 44 is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check"); +# 45 is(rmtree($dir, undef), 1, "removed directory 2a verbose undef"); @created = mkpath($dir, 0, undef); +# 46 is(scalar(@created), 1, "created directory (old style 3 mode undef)"); +# 47 is($created[0], $dir, "created directory (old style 3 mode undef) cross-check"); +# 48 is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef"); $dir = catdir($tmp_base,'G'); $dir = VMS::Filespec::unixify($dir) if $Is_VMS; @created = mkpath($dir, undef, 0200); +# 49 is(scalar(@created), 1, "created write-only dir"); +# 50 is($created[0], $dir, "created write-only directory cross-check"); +# 51 is(rmtree($dir), 1, "removed write-only dir"); # borderline new-style heuristics @@ -278,23 +330,49 @@ $dir = catdir('a', 'd1'); $dir2 = catdir('a', 'd2'); @created = make_path( $dir, 0, $dir2 ); +# 52 is(scalar @created, 3, 'new-style 3 dirs created'); $count = remove_tree( $dir, 0, $dir2, ); +# 53 is($count, 3, 'new-style 3 dirs removed'); @created = make_path( $dir, $dir2, 1 ); +# 54 is(scalar @created, 3, 'new-style 3 dirs created (redux)'); $count = remove_tree( $dir, $dir2, 1 ); +# 55 is($count, 3, 'new-style 3 dirs removed (redux)'); @created = make_path( $dir, $dir2 ); +# 56 is(scalar @created, 2, 'new-style 2 dirs created'); $count = remove_tree( $dir, $dir2 ); +# 57 is($count, 2, 'new-style 2 dirs removed'); +$dir = catdir("a\nb", 'd1'); +$dir2 = catdir("a\nb", 'd2'); + + + +SKIP: { + # Better to search for *nix derivatives? + # Not sure what else doesn't support newline in paths + skip "This is a MSWin32 platform", 2 + if $^O eq 'MSWin32'; + + @created = make_path( $dir, $dir2 ); +# 58 + is(scalar @created, 3, 'new-style 3 dirs created in parent with newline'); + + $count = remove_tree( $dir, $dir2 ); +# 59 + is($count, 2, 'new-style 2 dirs removed in parent with newline'); +} + if (chdir updir()) { pass("chdir parent"); } @@ -303,32 +381,36 @@ else { } SKIP: { - skip "This is not a MSWin32 platform", 1 + skip "This is not a MSWin32 platform", 3 unless $^O eq 'MSWin32'; - my $UNC_path_taint = $ENV{PERL_FILE_PATH_UNC_TESTDIR}; - skip "PERL_FILE_PATH_UNC_TESTDIR environment variable not set", 1 - unless defined($UNC_path_taint); + my $UNC_path = catdir(getcwd(), $tmp_base, 'uncdir'); + #dont compute a SMB path with $ENV{COMPUTERNAME}, since SMB may be turned off + #firewalled, disabled, blocked, or no NICs are on and there the PC has no + #working TCPIP stack, \\?\ will always work + $UNC_path = '\\\\?\\'.$UNC_path; +# 60 + is(mkpath($UNC_path), 1, 'mkpath on Win32 UNC path returns made 1 dir'); +# 61 + ok(-d $UNC_path, 'mkpath on Win32 UNC path made dir'); - my ($UNC_path) = ($UNC_path_taint =~ m{^([/\\]{2}\w+[/\\]\w+[/\\]\w+)$}); - - skip "PERL_FILE_PATH_UNC_TESTDIR environment variable does not point to a directory", 1 - unless -d $UNC_path; - my $removed = rmtree($UNC_path); +# 62 cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path"); } SKIP: { # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319 - skip "Don't need Force_Writeable semantics on $^O", 4 + skip "Don't need Force_Writeable semantics on $^O", 6 if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); - skip "Symlinks not available", 4 unless $Config{d_symlink}; + skip "Symlinks not available", 6 unless $Config{d_symlink}; $dir = 'bug487319'; $dir2 = 'bug487319-symlink'; @created = make_path($dir, {mask => 0700}); - is(scalar @created, 1, 'bug 487319 setup'); +# 63 + is( scalar @created, 1, 'bug 487319 setup' ); symlink($dir, $dir2); +# 64 ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2); chmod 0500, $dir; @@ -336,29 +418,39 @@ SKIP: { remove_tree($dir2); my $mask = (stat $dir)[2]; +# 65 is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)'); # now try a file - my $file = catfile($dir, 'file'); + #my $file = catfile($dir, 'file'); + my $file = 'bug487319-file'; + my $file2 = 'bug487319-file-symlink'; open my $out, '>', $file; close $out; +# 66 + ok(-e $file, 'file exists'); chmod 0500, $file; $mask_initial = (stat $file)[2]; - my $file2 = catfile($dir, 'symlink'); symlink($file, $file2); +# 67 + ok(-e $file2, 'file2 exists'); remove_tree($file2); $mask = (stat $file)[2]; +# 68 is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)'); remove_tree($dir); + remove_tree($file); } # see what happens if a file exists where we want a directory SKIP: { - my $entry = catdir($tmp_base, "file"); + my $entry = catfile($tmp_base, "file"); + skip "VMS can have a file and a directory with the same name.", 4 + if $Is_VMS; skip "Cannot create $entry", 4 unless open OUT, "> $entry"; print OUT "test file, safe to delete\n", scalar(localtime), "\n"; close OUT; @@ -433,6 +525,34 @@ SKIP: { ok(!-e $dir, "blow it away via \@ARGV"); } +SKIP : { + my $skip_count = 19; + #this test will fail on Windows, as per: http://perldoc.perl.org/perlport.html#chmod + skip "Windows chmod test skipped", $skip_count + if $^O eq 'MSWin32'; + my $mode; + my $octal_mode; + my @inputs = ( + 0777, 0700, 0070, 0007, + 0333, 0300, 0030, 0003, + 0111, 0100, 0010, 0001, + 0731, 0713, 0317, 0371, 0173, 0137, + 00 ); + my $input; + my $octal_input; + $dir = catdir($tmp_base, 'chmod_test'); + + foreach (@inputs) { + $input = $_; + @created = mkpath($dir, {chmod => $input}); + $mode = (stat($dir))[2]; + $octal_mode = S_IMODE($mode); + $octal_input = sprintf "%04o", S_IMODE($input); + is($octal_mode,$input, "create a new directory with chmod $input ($octal_input)"); + rmtree( $dir ); + } +} + SKIP: { my $skip_count = 8; # DRY skip "getpwent() not implemented on $^O", $skip_count @@ -508,7 +628,7 @@ unable to map $max_group to a gid, group ownership not changed: .* at \S+ line \ } SKIP: { - skip 'Test::Output not available', 14 + skip 'Test::Output not available', 18 unless $has_Test_Output; SKIP: { @@ -517,14 +637,14 @@ SKIP: { unless -e $dir; $dir = catdir('EXTRA', '3', 'U'); - stderr_like( + stderr_like( sub {rmtree($dir, {verbose => 0})}, qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+}, q(rmtree can't chdir into root dir) ); $dir = catdir('EXTRA', '3'); - stderr_like( + stderr_like( sub {rmtree($dir, {})}, qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+) cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 @@ -533,7 +653,7 @@ cannot remove directory for [^:]+: .* at \1 line \2}, 'rmtree with file owned by root' ); - stderr_like( + stderr_like( sub {rmtree('EXTRA', {})}, qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+) cannot remove directory for [^:]+: .* at \1 line \2 @@ -567,6 +687,7 @@ cannot remove directory for [^:]+: .* at \1 line \2}, stderr_is( sub { make_path() }, '', "make_path no args does not carp" ); stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" ); + stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" ); stdout_is( sub {@created = mkpath($dir, 1)}, @@ -598,6 +719,66 @@ cannot remove directory for [^:]+: .* at \1 line \2}, 'mkpath verbose (new style 2)' ); + stdout_is( + sub {$count = rmtree([$dir, $dir2], 1, 1)}, + "rmdir $dir\nrmdir $dir2\n", + 'again: rmtree verbose (old style)' + ); + + stdout_is( + sub { + @created = make_path( + $dir, + $dir2, + { verbose => 1, mode => 0711 } + ); + }, + "mkdir $dir\nmkdir $dir2\n", + 'make_path verbose with final hashref' + ); + + # { + # local $@; + # eval { + # @created = make_path( + # $dir, + # $dir2, + # { verbose => 1, mode => 0711, foo => 1, bar => 1 } + # ); + # }; + # like($@, + # qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/, + # 'make_path with final hashref failed due to unrecognized options' + # ); + # } + # + # { + # local $@; + # eval { + # @created = remove_tree( + # $dir, + # $dir2, + # { verbose => 1, foo => 1, bar => 1 } + # ); + # }; + # like($@, + # qr/Unrecognized option\(s\) passed to remove_tree\(\):.*?bar.*?foo/, + # 'remove_tree with final hashref failed due to unrecognized options' + # ); + # } + + stdout_is( + sub { + @created = remove_tree( + $dir, + $dir2, + { verbose => 1 } + ); + }, + "rmdir $dir\nrmdir $dir2\n", + 'remove_tree verbose with final hashref' + ); + SKIP: { $file = catdir($dir2, "file"); skip "Cannot create $file", 2 unless open OUT, "> $file"; @@ -642,11 +823,11 @@ SKIP: { rmtree($tmp_base, {result => \$list} ); is(ref($list), 'ARRAY', "received a final list of results"); ok( !(-d $tmp_base), "test base directory gone" ); - + my $p = getcwd(); my $x = "x$$"; my $xx = $x . "x"; - + # setup ok(mkpath($xx), "make $xx"); ok(chdir($xx), "... and chdir $xx"); @@ -654,9 +835,17 @@ SKIP: { ok(chdir($p), "... now chdir $p"); ok(rmtree($xx), "... and finally rmtree $xx"); } - + # create and delete directory my $px = catdir($p, $x); ok(mkpath($px), 'create and delete directory 2.07'); ok(rmtree($px), '.. rmtree fails in File-Path-2.07'); } + +my $windows_dir = 'C:\Path\To\Dir'; +my $expect = 'c:/path/to/dir'; +is( + File::Path::_slash_lc($windows_dir), + $expect, + "Windows path unixified as expected" +); diff --git a/cpan/libnet/Makefile.PL b/cpan/libnet/Makefile.PL index af24976..872eac8 100644 --- a/cpan/libnet/Makefile.PL +++ b/cpan/libnet/Makefile.PL @@ -7,7 +7,7 @@ # Makefile creation script. # # COPYRIGHT -# Copyright (C) 2014 Steve Hay. All rights reserved. +# Copyright (C) 2014, 2015 Steve Hay. All rights reserved. # # LICENCE # This script is free software; you can redistribute it and/or modify it under @@ -66,7 +66,7 @@ MAIN: { ABSTRACT => 'Collection of network protocol modules', AUTHOR => 'Graham Barr <[email protected]>, Steve Hay <[email protected]>', LICENSE => 'perl_5', - VERSION => '3.06', + VERSION => '3.07', META_MERGE => { 'meta-spec' => { @@ -206,6 +206,7 @@ MAIN: { 'Time::Local' => '0', 'constant' => '0', 'strict' => '0', + 'utf8' => '0', 'vars' => '0' }, diff --git a/cpan/libnet/lib/Net/Cmd.pm b/cpan/libnet/lib/Net/Cmd.pm index f56e904..3bf5ec6 100644 --- a/cpan/libnet/lib/Net/Cmd.pm +++ b/cpan/libnet/lib/Net/Cmd.pm @@ -2,7 +2,7 @@ # # Versions up to 2.29_1 Copyright (c) 1995-2006 Graham Barr <[email protected]>. # All rights reserved. -# Changes in Version 2.29_2 onwards Copyright (C) 2013-2014 Steve Hay. All +# Changes in Version 2.29_2 onwards Copyright (C) 2013-2015 Steve Hay. All # rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General @@ -27,22 +27,7 @@ BEGIN { } } -BEGIN { - if (!eval { require utf8 }) { - *is_utf8 = sub { 0 }; - } - elsif (eval { utf8::is_utf8(undef); 1 }) { - *is_utf8 = \&utf8::is_utf8; - } - elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) { - *is_utf8 = \&Encode::is_utf8; - } - else { - *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ }; - } -} - -our $VERSION = "3.06"; +our $VERSION = "3.07"; our @ISA = qw(Exporter); our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); @@ -429,9 +414,17 @@ sub datasend { my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; my $line = join("", @$arr); - # encode to individual utf8 bytes if - # $line is a string (in internal UTF-8) - utf8::encode($line) if is_utf8($line); + # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with + # the substitutions below when dealing with strings stored internally in + # UTF-8, so downgrade them (if possible). + # Data passed to datasend() should be encoded to octets upstream already so + # shouldn't even have the UTF-8 flag on to start with, but if it so happens + # that the octets are stored in an upgraded string (as can sometimes occur) + # then they would still downgrade without fail anyway. + # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to + # downgrade. We fail silently in that case, and a "Wide character in print" + # warning will be emitted later by syswrite(). + utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009; return 0 if $cmd->_is_closed; @@ -722,6 +715,8 @@ is pending then C<CMD_PENDING> is returned. Send data to the remote server, converting LF to CRLF. Any line starting with a '.' will be prefixed with another '.'. C<DATA> may be an array or a reference to an array. +The C<DATA> passed in must be encoded by the caller to octets of whatever +encoding is required, e.g. by using the Encode module's C<encode()> function. =item dataend () @@ -794,6 +789,9 @@ Unget a line of text from the server. Send data to the remote server without performing any conversions. C<DATA> is a scalar. +As with C<datasend()>, the C<DATA> passed in must be encoded by the caller +to octets of whatever encoding is required, e.g. by using the Encode module's +C<encode()> function. =item read_until_dot () diff --git a/cpan/libnet/lib/Net/Config.pm b/cpan/libnet/lib/Net/Config.pm index a705065..fe8ce8a 100644 --- a/cpan/libnet/lib/Net/Config.pm +++ b/cpan/libnet/lib/Net/Config.pm @@ -20,7 +20,7 @@ use Socket qw(inet_aton inet_ntoa); our @EXPORT = qw(%NetConfig); our @ISA = qw(Net::LocalCfg Exporter); -our $VERSION = "3.06"; +our $VERSION = "3.07"; our($CONFIGURE, $LIBNET_CFG); @@ -134,7 +134,7 @@ __END__ Net::Config - Local configuration data for libnet -=head1 SYNOPSYS +=head1 SYNOPSIS use Net::Config qw(%NetConfig); diff --git a/cpan/libnet/lib/Net/Domain.pm b/cpan/libnet/lib/Net/Domain.pm index 0fde92d..3109f43 100644 --- a/cpan/libnet/lib/Net/Domain.pm +++ b/cpan/libnet/lib/Net/Domain.pm @@ -21,7 +21,7 @@ use Net::Config; our @ISA = qw(Exporter); our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); -our $VERSION = "3.06"; +our $VERSION = "3.07"; my ($host, $domain, $fqdn) = (undef, undef, undef); diff --git a/cpan/libnet/lib/Net/FTP.pm b/cpan/libnet/lib/Net/FTP.pm index 8b74663..7700bb3 100644 --- a/cpan/libnet/lib/Net/FTP.pm +++ b/cpan/libnet/lib/Net/FTP.pm @@ -2,7 +2,7 @@ # # Versions up to 2.77_2 Copyright (c) 1995-2004 Graham Barr <[email protected]>. # All rights reserved. -# Changes in Version 2.77_3 onwards Copyright (C) 2013-2014 Steve Hay. All +# Changes in Version 2.77_3 onwards Copyright (C) 2013-2015 Steve Hay. All # rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General @@ -25,9 +25,10 @@ use Net::Config; use Socket; use Time::Local; -our $VERSION = '3.06'; +our $VERSION = '3.07'; our $IOCLASS; +my $family_key; BEGIN { # Code for detecting if we can use SSL my $ssl_class = eval { @@ -55,6 +56,10 @@ BEGIN { sub can_inet6 { $inet6_class }; $IOCLASS = $ssl_class || $inet6_class || 'IO::Socket::INET'; + $family_key = + ( $ssl_class ? $ssl_class->can_ipv6 : $inet6_class || '' ) + eq 'IO::Socket::IP' + ? 'Family' : 'Domain'; } our @ISA = ('Exporter','Net::Cmd',$IOCLASS); @@ -120,6 +125,7 @@ sub new { PeerAddr => $peer, PeerPort => $arg{Port} || ($arg{SSL} ? 'ftps(990)' : 'ftp(21)'), LocalAddr => $arg{'LocalAddr'}, + $family_key => $arg{Domain} || $arg{Family}, Proto => 'tcp', Timeout => defined $arg{Timeout} ? $arg{Timeout} : 120, %tlsargs, @@ -131,6 +137,7 @@ sub new { ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240); ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'}; + ${*$ftp}{'net_ftp_domain'} = $arg{Domain} || $arg{Family}; ${*$ftp}{'net_ftp_firewall'} = $fire if (defined $fire); @@ -662,8 +669,12 @@ sub rmdir { or !$recurse; # Try to delete the contents - # Get a list of all the files in the directory - my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir); + # Get a list of all the files in the directory, excluding the current and parent directories + my @filelist = map { /^(?:\S+;)+ (.+)$/ ? ($1) : () } grep { !/^(?:\S+;)*type=[cp]dir;/ } $ftp->_list_cmd("MLSD", $dir); + + # Fallback to using the less well-defined NLST command if MLSD fails + @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir) + unless @filelist; return unless @filelist; # failed, it is probably not a directory @@ -889,6 +900,7 @@ sub _eprt { Listen => 1, Timeout => $ftp->timeout, LocalAddr => $ftp->sockhost, + $family_key => $ftp->sockdomain, can_ssl() ? ( %{ ${*$ftp}{net_ftp_tlsargs} }, SSL_startHandshake => 0, @@ -1035,6 +1047,7 @@ sub _dataconn { PeerAddr => $pasv->[0], PeerPort => $pasv->[1], LocalAddr => ${*$ftp}{net_ftp_localaddr}, + $family_key => ${*$ftp}{net_ftp_domain}, Timeout => $ftp->timeout, can_ssl() ? ( SSL_startHandshake => 0, @@ -1142,7 +1155,7 @@ sub _data_cmd { my $data = $ftp->_dataconn(); if (CMD_INFO == $ftp->response()) { $data->reading - if $data && $cmd =~ /RETR|LIST|NLST/; + if $data && $cmd =~ /RETR|LIST|NLST|MLSD/; return $data; } $data->_close if $data; @@ -1181,7 +1194,7 @@ sub _data_cmd { my $data = $ftp->_dataconn(); $data->reading - if $data && $cmd =~ /RETR|LIST|NLST/; + if $data && $cmd =~ /RETR|LIST|NLST|MLSD/; return $data; } @@ -1435,10 +1448,15 @@ Net::FTP - FTP Client class =head1 DESCRIPTION C<Net::FTP> is a class implementing a simple FTP client in Perl as -described in RFC959. It provides wrappers for a subset of the RFC959 -commands. +described in RFC959. It provides wrappers for the commonly used subset of the +RFC959 commands. +If L<IO::Socket::IP> or L<IO::Socket::INET6> is installed it also provides +support for IPv6 as defined in RFC2428. +And with L<IO::Socket::SSL> installed it provides support for implicit FTPS +and explicit FTPS as defined in RFC4217. -The Net::FTP class is a subclass of Net::Cmd and IO::Socket::INET. +The Net::FTP class is a subclass of Net::Cmd and (depending on avaibility) of +IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. =head1 OVERVIEW @@ -1539,8 +1557,15 @@ simply invokes the C<hash()> method for you, so that hash marks are displayed for all transfers. You can, of course, call C<hash()> explicitly whenever you'd like. -B<LocalAddr> - Local address to use for all socket connections, this -argument will be passed to L<IO::Socket::INET> +B<LocalAddr> - Local address to use for all socket connections. This +argument will be passed to the super class, i.e. L<IO::Socket::INET> +or L<IO::Socket::IP>. + +B<Domain> - Domain to use, i.e. AF_INET or AF_INET6. This +argument will be passed to the IO::Socket super class. +This can be used to enforce IPv4 even with L<IO::Socket::IP> +which would default to IPv6. +B<Family> is accepted as alternative name for B<Domain>. If the constructor fails undef will be returned and an error message will be in $@ @@ -1592,8 +1617,8 @@ Only C<LEVEL>s "C" (clear) and "P" (private) are supported. =item host () -Returns the value used by the constructor, and passed to IO::Socket::INET, -to connect to the host. +Returns the value used by the constructor, and passed to the IO::Socket super +class to connect to the host. =item account( ACCT ) @@ -2014,7 +2039,7 @@ Roderick Schertler <[email protected]> - for various inputs =head1 COPYRIGHT Versions up to 2.77_2 Copyright (c) 1995-2004 Graham Barr. All rights reserved. -Changes in Version 2.77_3 onwards Copyright (C) 2013-2014 Steve Hay. All rights +Changes in Version 2.77_3 onwards Copyright (C) 2013-2015 Steve Hay. All rights reserved. This module is free software; you can redistribute it and/or modify it under the diff --git a/cpan/libnet/lib/Net/FTP/A.pm b/cpan/libnet/lib/Net/FTP/A.pm index 7eee970..f3375c6 100644 --- a/cpan/libnet/lib/Net/FTP/A.pm +++ b/cpan/libnet/lib/Net/FTP/A.pm @@ -13,7 +13,7 @@ use Carp; use Net::FTP::dataconn; our @ISA = qw(Net::FTP::dataconn); -our $VERSION = "3.06"; +our $VERSION = "3.07"; our $buf; diff --git a/cpan/libnet/lib/Net/FTP/E.pm b/cpan/libnet/lib/Net/FTP/E.pm index ad36441..56075f6 100644 --- a/cpan/libnet/lib/Net/FTP/E.pm +++ b/cpan/libnet/lib/Net/FTP/E.pm @@ -8,6 +8,6 @@ use warnings; use Net::FTP::I; our @ISA = qw(Net::FTP::I); -our $VERSION = "3.06"; +our $VERSION = "3.07"; 1; diff --git a/cpan/libnet/lib/Net/FTP/I.pm b/cpan/libnet/lib/Net/FTP/I.pm index c5603c6..bb18ff8 100644 --- a/cpan/libnet/lib/Net/FTP/I.pm +++ b/cpan/libnet/lib/Net/FTP/I.pm @@ -13,7 +13,7 @@ use Carp; use Net::FTP::dataconn; our @ISA = qw(Net::FTP::dataconn); -our $VERSION = "3.06"; +our $VERSION = "3.07"; our $buf; diff --git a/cpan/libnet/lib/Net/FTP/L.pm b/cpan/libnet/lib/Net/FTP/L.pm index 4c52970..d96a39b 100644 --- a/cpan/libnet/lib/Net/FTP/L.pm +++ b/cpan/libnet/lib/Net/FTP/L.pm @@ -8,6 +8,6 @@ use warnings; use Net::FTP::I; our @ISA = qw(Net::FTP::I); -our $VERSION = "3.06"; +our $VERSION = "3.07"; 1; diff --git a/cpan/libnet/lib/Net/FTP/dataconn.pm b/cpan/libnet/lib/Net/FTP/dataconn.pm index 980e21d..81e3a61 100644 --- a/cpan/libnet/lib/Net/FTP/dataconn.pm +++ b/cpan/libnet/lib/Net/FTP/dataconn.pm @@ -13,7 +13,7 @@ use Carp; use Errno; use Net::Cmd; -our $VERSION = '3.06'; +our $VERSION = '3.07'; $Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn"; our @ISA = $Net::FTP::IOCLASS; diff --git a/cpan/libnet/lib/Net/NNTP.pm b/cpan/libnet/lib/Net/NNTP.pm index 75f7bf1..7499204 100644 --- a/cpan/libnet/lib/Net/NNTP.pm +++ b/cpan/libnet/lib/Net/NNTP.pm @@ -2,7 +2,7 @@ # # Versions up to 2.24_1 Copyright (c) 1995-1997 Graham Barr <[email protected]>. # All rights reserved. -# Changes in Version 2.25 onwards Copyright (C) 2013-2014 Steve Hay. All rights +# Changes in Version 2.25 onwards Copyright (C) 2013-2015 Steve Hay. All rights # reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General @@ -21,7 +21,7 @@ use Net::Cmd; use Net::Config; use Time::Local; -our $VERSION = "3.06"; +our $VERSION = "3.07"; # Code for detecting if we can use SSL my $ssl_class = eval { @@ -35,16 +35,19 @@ my $nossl_warn = !$ssl_class && 'To use SSL please install IO::Socket::SSL with version>=2.007'; # Code for detecting if we can use IPv6 +my $family_key = 'Domain'; my $inet6_class = eval { require IO::Socket::IP; no warnings 'numeric'; - IO::Socket::IP->VERSION(0.20); + IO::Socket::IP->VERSION(0.20) || die; + $family_key = 'Family'; } && 'IO::Socket::IP' || eval { require IO::Socket::INET6; no warnings 'numeric'; IO::Socket::INET6->VERSION(2.62); } && 'IO::Socket::INET6'; + sub can_ssl { $ssl_class }; sub can_inet6 { $inet6_class }; @@ -81,9 +84,10 @@ sub new { $connect{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg); } - foreach my $o (qw(LocalAddr Timeout)) { + foreach my $o (qw(LocalAddr LocalPort Timeout)) { $connect{$o} = $arg{$o} if exists $arg{$o}; } + $connect{$family_key} = $arg{Domain} || $arg{Family}; $connect{Timeout} = 120 unless defined $connect{Timeout}; $connect{PeerPort} = $arg{Port} || 'nntp(119)'; foreach my $h (@{$hosts}) { @@ -799,8 +803,11 @@ Net::NNTP - NNTP Client class C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described in RFC977 and RFC4642. +With L<IO::Socket::SSL> installed it also provides support for implicit and +explicit TLS encryption, i.e. NNTPS or NNTP+STARTTLS. -The Net::NNTP class is a subclass of Net::Cmd and IO::Socket::INET. +The Net::NNTP class is a subclass of Net::Cmd and (depending on avaibility) of +IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. =head1 CONSTRUCTOR @@ -843,10 +850,12 @@ so that the remote server becomes innd. If the C<Reader> option is given with a value of zero, then this command will not be sent and the connection will be left talking to nnrpd. -B<LocalAddr> - If multiple IP addresses are present on the client host -with a valid route to the destination, you can specify the address your -C<Net::NNTP> connects from and this way override the operating system's -pick. +B<LocalAddr> and B<LocalPort> - These parameters are passed directly +to IO::Socket to allow binding the socket to a specific local address and port. + +B<Domain> - This parameter is passed directly to IO::Socket and makes it +possible to enforce IPv4 connections even if L<IO::Socket::IP> is used as super +class. Alternatively B<Family> can be used. =back @@ -947,15 +956,17 @@ implementation) from the server. Returns the text or undef upon failure. The C<ihave> command informs the server that the client has an article whose id is C<MSGID>. If the server desires a copy of that -article, and C<MESSAGE> has been given the it will be sent. +article and C<MESSAGE> has been given then it will be sent. Returns I<true> if the server desires the article and C<MESSAGE> was -successfully sent,if specified. +successfully sent, if specified. If C<MESSAGE> is not specified then the message must be sent using the C<datasend> and C<dataend> methods from L<Net::Cmd> -C<MESSAGE> can be either an array of lines or a reference to an array. +C<MESSAGE> can be either an array of lines or a reference to an array +and must be encoded by the caller to octets of whatever encoding is required, +e.g. by using the Encode module's C<encode()> function. =item last () @@ -1028,7 +1039,9 @@ is allowed then the message will be sent. If C<MESSAGE> is not specified then the message must be sent using the C<datasend> and C<dataend> methods from L<Net::Cmd> -C<MESSAGE> can be either an array of lines or a reference to an array. +C<MESSAGE> can be either an array of lines or a reference to an array +and must be encoded by the caller to octets of whatever encoding is required, +e.g. by using the Encode module's C<encode()> function. The message, either sent via C<datasend> or as the C<MESSAGE> parameter, must be in the format as described by RFC822 and must @@ -1279,7 +1292,7 @@ Steve Hay E<lt>F<[email protected]>E<gt> is now maintaining libnet as of version =head1 COPYRIGHT Versions up to 2.24_1 Copyright (c) 1995-1997 Graham Barr. All rights reserved. -Changes in Version 2.25 onwards Copyright (C) 2013-2014 Steve Hay. All rights +Changes in Version 2.25 onwards Copyright (C) 2013-2015 Steve Hay. All rights reserved. This module is free software; you can redistribute it and/or modify it under the diff --git a/cpan/libnet/lib/Net/Netrc.pm b/cpan/libnet/lib/Net/Netrc.pm index efa38cb..4b721be 100644 --- a/cpan/libnet/lib/Net/Netrc.pm +++ b/cpan/libnet/lib/Net/Netrc.pm @@ -18,7 +18,7 @@ use warnings; use Carp; use FileHandle; -our $VERSION = "3.06"; +our $VERSION = "3.07"; our $TESTING; diff --git a/cpan/libnet/lib/Net/POP3.pm b/cpan/libnet/lib/Net/POP3.pm index 2c38819..791b1d2 100644 --- a/cpan/libnet/lib/Net/POP3.pm +++ b/cpan/libnet/lib/Net/POP3.pm @@ -2,7 +2,7 @@ # # Versions up to 2.29 Copyright (c) 1995-2004 Graham Barr <[email protected]>. # All rights reserved. -# Changes in Version 2.29_01 onwards Copyright (C) 2013-2014 Steve Hay. All +# Changes in Version 2.29_01 onwards Copyright (C) 2013-2015 Steve Hay. All # rights reserved. # This module is free software; you can redistribute it and/or modify it under **** PATCH TRUNCATED AT 2000 LINES -- 245 NOT SHOWN **** -- Perl5 Master Repository
