diff --git a/PathTools-3.47-Update-to-3.56.patch b/PathTools-3.47-Update-to-3.56.patch new file mode 100644 index 0000000..a671395 --- /dev/null +++ b/PathTools-3.47-Update-to-3.56.patch @@ -0,0 +1,4832 @@ +diff -ruN PathTools-3.47/lib/File/Spec/Cygwin.pm PathTools-core/lib/File/Spec/Cygwin.pm +--- PathTools-3.47/lib/File/Spec/Cygwin.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/Cygwin.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -4,7 +4,7 @@ + use vars qw(@ISA $VERSION); + require File::Spec::Unix; + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + @ISA = qw(File::Spec::Unix); +diff -ruN PathTools-3.47/lib/File/Spec/Epoc.pm PathTools-core/lib/File/Spec/Epoc.pm +--- PathTools-3.47/lib/File/Spec/Epoc.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/Epoc.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -3,7 +3,7 @@ + use strict; + use vars qw($VERSION @ISA); + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + require File::Spec::Unix; +diff -ruN PathTools-3.47/lib/File/Spec/Functions.pm PathTools-core/lib/File/Spec/Functions.pm +--- PathTools-3.47/lib/File/Spec/Functions.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/Functions.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -5,7 +5,7 @@ + + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + require Exporter; +diff -ruN PathTools-3.47/lib/File/Spec/Mac.pm PathTools-core/lib/File/Spec/Mac.pm +--- PathTools-3.47/lib/File/Spec/Mac.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/Mac.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -4,7 +4,7 @@ + use vars qw(@ISA $VERSION); + require File::Spec::Unix; + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + @ISA = qw(File::Spec::Unix); +diff -ruN PathTools-3.47/lib/File/Spec/OS2.pm PathTools-core/lib/File/Spec/OS2.pm +--- PathTools-3.47/lib/File/Spec/OS2.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/OS2.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -4,7 +4,7 @@ + use vars qw(@ISA $VERSION); + require File::Spec::Unix; + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + @ISA = qw(File::Spec::Unix); +diff -ruN PathTools-3.47/lib/File/Spec/Unix.pm PathTools-core/lib/File/Spec/Unix.pm +--- PathTools-3.47/lib/File/Spec/Unix.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/Unix.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -3,12 +3,15 @@ + use strict; + use vars qw($VERSION); + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + my $xs_version = $VERSION; + $VERSION =~ tr/_//; + +-unless (defined &canonpath) { +- eval { ++#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl ++if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { ++ eval {#eval is questionable since we are handling potential errors like ++ #"Cwd object version 3.48 does not match bootstrap parameter 3.50 ++ #at lib/DynaLoader.pm line 216." by having this eval + if ( $] >= 5.006 ) { + require XSLoader; + XSLoader::load("Cwd", $xs_version); +diff -ruN PathTools-3.47/lib/File/Spec/VMS.pm PathTools-core/lib/File/Spec/VMS.pm +--- PathTools-3.47/lib/File/Spec/VMS.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/VMS.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -4,7 +4,7 @@ + use vars qw(@ISA $VERSION); + require File::Spec::Unix; + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + @ISA = qw(File::Spec::Unix); +@@ -144,8 +144,7 @@ + return $self->SUPER::catdir($spath, $sdir) + } + +- $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; +- $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); ++ $rslt = vmspath( unixify($spath) . '/' . unixify($sdir)); + + # Special case for VMS absolute directory specs: these will have + # had device prepended during trip through Unix syntax in +@@ -195,7 +194,7 @@ + if ($spath =~ /^(?]+\)\Z(?!\n)/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } else { +- $rslt = $self->eliminate_macros($spath); ++ $rslt = unixify($spath); + $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); + $rslt = vmsify($rslt) unless $unix_rpt; + } +@@ -204,7 +203,7 @@ + # Only passed a single file? + my $xfile = (defined($file) && length($file)) ? $file : ''; + +- $rslt = $unix_rpt ? $file : vmsify($file); ++ $rslt = $unix_rpt ? $xfile : vmsify($xfile); + } + return $self->canonpath($rslt) unless $unix_rpt; + +@@ -439,12 +438,16 @@ + sub abs2rel { + my $self = shift; + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) +- if grep m{/}, @_; ++ if ((grep m{/}, @_) && !(grep m{(?_cwd() unless defined $base and length $base; + +- for ($path, $base) { $_ = $self->canonpath($_) } ++ # If there is no device or directory syntax on $base, make sure it ++ # is treated as a directory. ++ $base = VMS::Filespec::vmspath($base) unless $base =~ m{(?rel2abs($_) } + + # Are we even starting $path on the same (node::)device as $base? Note that + # logical paths or nodename differences may be on the "same device" +@@ -460,8 +463,6 @@ + my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); + return $path unless lc($path_volume) eq lc($base_volume); + +- for ($path, $base) { $_ = $self->rel2abs($_) } +- + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my $pathchunks = @pathchunks; +@@ -545,123 +546,11 @@ + } + + +-# eliminate_macros() and fixpath() are MakeMaker-specific methods +-# which are used inside catfile() and catdir(). MakeMaker has its own +-# copies as of 6.06_03 which are the canonical ones. We leave these +-# here, in peace, so that File::Spec continues to work with MakeMakers +-# prior to 6.06_03. +-# +-# Please consider these two methods deprecated. Do not patch them, +-# patch the ones in ExtUtils::MM_VMS instead. +-# +-# Update: MakeMaker 6.48 is still using these routines on VMS. +-# so they need to be kept up to date with ExtUtils::MM_VMS. +- +-sub eliminate_macros { +- my($self,$path) = @_; +- return '' unless (defined $path) && ($path ne ''); +- $self = {} unless ref $self; +- +- if ($path =~ /\s/) { +- return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; +- } +- +- my $npath = unixify($path); +- # sometimes unixify will return a string with an off-by-one trailing null +- $npath =~ s{\0$}{}; +- +- my($complex) = 0; +- my($head,$macro,$tail); +- +- # perform m##g in scalar context so it acts as an iterator +- while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { +- if (defined $self->{$2}) { +- ($head,$macro,$tail) = ($1,$2,$3); +- if (ref $self->{$macro}) { +- if (ref $self->{$macro} eq 'ARRAY') { +- $macro = join ' ', @{$self->{$macro}}; +- } +- else { +- print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), +- "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; +- $macro = "\cB$macro\cB"; +- $complex = 1; +- } +- } +- else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } +- $npath = "$head$macro$tail"; +- } +- } +- if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } +- $npath; +-} +- +-# Deprecated. See the note above for eliminate_macros(). +- +-# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros +-# in any directory specification, in order to avoid juxtaposing two +-# VMS-syntax directories when MM[SK] is run. Also expands expressions which +-# are all macro, so that we can tell how long the expansion is, and avoid +-# overrunning DCL's command buffer when MM[KS] is running. +- +-# fixpath() checks to see whether the result matches the name of a +-# directory in the current default directory and returns a directory or +-# file specification accordingly. C<$is_dir> can be set to true to +-# force fixpath() to consider the path to be a directory or false to force +-# it to be a file. +- +-sub fixpath { +- my($self,$path,$force_path) = @_; +- return '' unless $path; +- $self = bless {}, $self unless ref $self; +- my($fixedpath,$prefix,$name); +- +- if ($path =~ /\s/) { +- return join ' ', +- map { $self->fixpath($_,$force_path) } +- split /\s+/, $path; +- } +- +- if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { +- if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { +- $fixedpath = vmspath($self->eliminate_macros($path)); +- } +- else { +- $fixedpath = vmsify($self->eliminate_macros($path)); +- } +- } +- elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { +- my($vmspre) = $self->eliminate_macros("\$($prefix)"); +- # is it a dir or just a name? +- $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; +- $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; +- $fixedpath = vmspath($fixedpath) if $force_path; +- } +- else { +- $fixedpath = $path; +- $fixedpath = vmspath($fixedpath) if $force_path; +- } +- # No hints, so we try to guess +- if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { +- $fixedpath = vmspath($fixedpath) if -d $fixedpath; +- } +- +- # Trim off root dirname if it's had other dirs inserted in front of it. +- $fixedpath =~ s/\.000000([\]>])/$1/; +- # Special case for VMS absolute directory specs: these will have had device +- # prepended during trip through Unix syntax in eliminate_macros(), since +- # Unix syntax has no way to express "absolute from the top of this device's +- # directory tree". +- if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } +- $fixedpath; +-} +- +- + =back + + =head1 COPYRIGHT + +-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. ++Copyright (c) 2004-14 by the Perl 5 Porters. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. +diff -ruN PathTools-3.47/lib/File/Spec/Win32.pm PathTools-core/lib/File/Spec/Win32.pm +--- PathTools-3.47/lib/File/Spec/Win32.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec/Win32.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -5,7 +5,7 @@ + use vars qw(@ISA $VERSION); + require File::Spec::Unix; + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + @ISA = qw(File::Spec::Unix); +diff -ruN PathTools-3.47/lib/File/Spec.pm PathTools-core/lib/File/Spec.pm +--- PathTools-3.47/lib/File/Spec.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/lib/File/Spec.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -3,7 +3,7 @@ + use strict; + use vars qw(@ISA $VERSION); + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + $VERSION =~ tr/_//; + + my %module = (MacOS => 'Mac', +--- PathTools-3.47/Cwd.pm 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/Cwd.pm 2015-03-30 23:20:34.000000000 +0200 +@@ -1,177 +1,9 @@ + package Cwd; +- +-=head1 NAME +- +-Cwd - get pathname of current working directory +- +-=head1 SYNOPSIS +- +- use Cwd; +- my $dir = getcwd; +- +- use Cwd 'abs_path'; +- my $abs_path = abs_path($file); +- +-=head1 DESCRIPTION +- +-This module provides functions for determining the pathname of the +-current working directory. It is recommended that getcwd (or another +-*cwd() function) be used in I code to ensure portability. +- +-By default, it exports the functions cwd(), getcwd(), fastcwd(), and +-fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. +- +- +-=head2 getcwd and friends +- +-Each of these functions are called without arguments and return the +-absolute path of the current working directory. +- +-=over 4 +- +-=item getcwd +- +- my $cwd = getcwd(); +- +-Returns the current working directory. +- +-Exposes the POSIX function getcwd(3) or re-implements it if it's not +-available. +- +-=item cwd +- +- my $cwd = cwd(); +- +-The cwd() is the most natural form for the current architecture. For +-most systems it is identical to `pwd` (but without the trailing line +-terminator). +- +-=item fastcwd +- +- my $cwd = fastcwd(); +- +-A more dangerous version of getcwd(), but potentially faster. +- +-It might conceivably chdir() you out of a directory that it can't +-chdir() you back into. If fastcwd encounters a problem it will return +-undef but will probably leave you in a different directory. For a +-measure of extra security, if everything appears to have worked, the +-fastcwd() function will check that it leaves you in the same directory +-that it started in. If it has changed it will C with the message +-"Unstable directory path, current directory changed +-unexpectedly". That should never happen. +- +-=item fastgetcwd +- +- my $cwd = fastgetcwd(); +- +-The fastgetcwd() function is provided as a synonym for cwd(). +- +-=item getdcwd +- +- my $cwd = getdcwd(); +- my $cwd = getdcwd('C:'); +- +-The getdcwd() function is also provided on Win32 to get the current working +-directory on the specified drive, since Windows maintains a separate current +-working directory for each drive. If no drive is specified then the current +-drive is assumed. +- +-This function simply calls the Microsoft C library _getdcwd() function. +- +-=back +- +- +-=head2 abs_path and friends +- +-These functions are exported only on request. They each take a single +-argument and return the absolute pathname for it. If no argument is +-given they'll use the current working directory. +- +-=over 4 +- +-=item abs_path +- +- my $abs_path = abs_path($file); +- +-Uses the same algorithm as getcwd(). Symbolic links and relative-path +-components ("." and "..") are resolved to return the canonical +-pathname, just like realpath(3). +- +-=item realpath +- +- my $abs_path = realpath($file); +- +-A synonym for abs_path(). +- +-=item fast_abs_path +- +- my $abs_path = fast_abs_path($file); +- +-A more dangerous, but potentially faster version of abs_path. +- +-=back +- +-=head2 $ENV{PWD} +- +-If you ask to override your chdir() built-in function, +- +- use Cwd qw(chdir); +- +-then your PWD environment variable will be kept up to date. Note that +-it will only be kept up to date if all packages which use chdir import +-it from Cwd. +- +- +-=head1 NOTES +- +-=over 4 +- +-=item * +- +-Since the path separators are different on some operating systems ('/' +-on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec +-modules wherever portability is a concern. +- +-=item * +- +-Actually, on Mac OS, the C, C and C +-functions are all aliases for the C function, which, on Mac OS, +-calls `pwd`. Likewise, the C function is an alias for +-C. +- +-=back +- +-=head1 AUTHOR +- +-Originally by the perl5-porters. +- +-Maintained by Ken Williams +- +-=head1 COPYRIGHT +- +-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. +- +-This program is free software; you can redistribute it and/or modify +-it under the same terms as Perl itself. +- +-Portions of the C code in this library are copyright (c) 1994 by the +-Regents of the University of California. All rights reserved. The +-license on this code is compatible with the licensing of the rest of +-the distribution - please see the source code in F for the +-details. +- +-=head1 SEE ALSO +- +-L +- +-=cut +- + use strict; + use Exporter; + use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + +-$VERSION = '3.47'; ++$VERSION = '3.56'; + my $xs_version = $VERSION; + $VERSION =~ tr/_//; + +@@ -242,8 +74,10 @@ + + + # If loading the XS stuff doesn't work, we can fall back to pure perl +-unless (defined &getcwd) { +- eval { ++if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { ++ eval {#eval is questionable since we are handling potential errors like ++ #"Cwd object version 3.48 does not match bootstrap parameter 3.50 ++ #at lib/DynaLoader.pm line 216." by having this eval + if ( $] >= 5.006 ) { + require XSLoader; + XSLoader::load( __PACKAGE__, $xs_version); +@@ -333,14 +167,15 @@ + # are safe. This prevents _backtick_pwd() consulting $ENV{PATH} + # so everything works under taint mode. + my $pwd_cmd; +-foreach my $try ('/bin/pwd', +- '/usr/bin/pwd', +- '/QOpenSys/bin/pwd', # OS/400 PASE. +- ) { +- +- if( -x $try ) { +- $pwd_cmd = $try; +- last; ++if($^O ne 'MSWin32') { ++ foreach my $try ('/bin/pwd', ++ '/usr/bin/pwd', ++ '/QOpenSys/bin/pwd', # OS/400 PASE. ++ ) { ++ if( -x $try ) { ++ $pwd_cmd = $try; ++ last; ++ } + } + } + +@@ -356,7 +191,8 @@ + $pwd_cmd = "$Config::Config{targetsh} -c pwd" + } + else { +- $pwd_cmd = "$Config::Config{sh} -c pwd" ++ my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh'); ++ $pwd_cmd = "$sh -c pwd" + } + } + +@@ -515,7 +351,13 @@ + + sub chdir { + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) +- $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; ++ if ($^O eq "cygwin") { ++ $newdir =~ s|\A///+|//|; ++ $newdir =~ s|(?<=[^/])//+|/|g; ++ } ++ elsif ($^O ne 'MSWin32') { ++ $newdir =~ s|///*|/|g; ++ } + chdir_init() unless $chdir_init; + my $newpwd; + if ($^O eq 'MSWin32') { +@@ -853,3 +695,171 @@ + *realpath = \&abs_path; + + 1; ++__END__ ++ ++=head1 NAME ++ ++Cwd - get pathname of current working directory ++ ++=head1 SYNOPSIS ++ ++ use Cwd; ++ my $dir = getcwd; ++ ++ use Cwd 'abs_path'; ++ my $abs_path = abs_path($file); ++ ++=head1 DESCRIPTION ++ ++This module provides functions for determining the pathname of the ++current working directory. It is recommended that getcwd (or another ++*cwd() function) be used in I code to ensure portability. ++ ++By default, it exports the functions cwd(), getcwd(), fastcwd(), and ++fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. ++ ++ ++=head2 getcwd and friends ++ ++Each of these functions are called without arguments and return the ++absolute path of the current working directory. ++ ++=over 4 ++ ++=item getcwd ++ ++ my $cwd = getcwd(); ++ ++Returns the current working directory. ++ ++Exposes the POSIX function getcwd(3) or re-implements it if it's not ++available. ++ ++=item cwd ++ ++ my $cwd = cwd(); ++ ++The cwd() is the most natural form for the current architecture. For ++most systems it is identical to `pwd` (but without the trailing line ++terminator). ++ ++=item fastcwd ++ ++ my $cwd = fastcwd(); ++ ++A more dangerous version of getcwd(), but potentially faster. ++ ++It might conceivably chdir() you out of a directory that it can't ++chdir() you back into. If fastcwd encounters a problem it will return ++undef but will probably leave you in a different directory. For a ++measure of extra security, if everything appears to have worked, the ++fastcwd() function will check that it leaves you in the same directory ++that it started in. If it has changed it will C with the message ++"Unstable directory path, current directory changed ++unexpectedly". That should never happen. ++ ++=item fastgetcwd ++ ++ my $cwd = fastgetcwd(); ++ ++The fastgetcwd() function is provided as a synonym for cwd(). ++ ++=item getdcwd ++ ++ my $cwd = getdcwd(); ++ my $cwd = getdcwd('C:'); ++ ++The getdcwd() function is also provided on Win32 to get the current working ++directory on the specified drive, since Windows maintains a separate current ++working directory for each drive. If no drive is specified then the current ++drive is assumed. ++ ++This function simply calls the Microsoft C library _getdcwd() function. ++ ++=back ++ ++ ++=head2 abs_path and friends ++ ++These functions are exported only on request. They each take a single ++argument and return the absolute pathname for it. If no argument is ++given they'll use the current working directory. ++ ++=over 4 ++ ++=item abs_path ++ ++ my $abs_path = abs_path($file); ++ ++Uses the same algorithm as getcwd(). Symbolic links and relative-path ++components ("." and "..") are resolved to return the canonical ++pathname, just like realpath(3). ++ ++=item realpath ++ ++ my $abs_path = realpath($file); ++ ++A synonym for abs_path(). ++ ++=item fast_abs_path ++ ++ my $abs_path = fast_abs_path($file); ++ ++A more dangerous, but potentially faster version of abs_path. ++ ++=back ++ ++=head2 $ENV{PWD} ++ ++If you ask to override your chdir() built-in function, ++ ++ use Cwd qw(chdir); ++ ++then your PWD environment variable will be kept up to date. Note that ++it will only be kept up to date if all packages which use chdir import ++it from Cwd. ++ ++ ++=head1 NOTES ++ ++=over 4 ++ ++=item * ++ ++Since the path separators are different on some operating systems ('/' ++on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec ++modules wherever portability is a concern. ++ ++=item * ++ ++Actually, on Mac OS, the C, C and C ++functions are all aliases for the C function, which, on Mac OS, ++calls `pwd`. Likewise, the C function is an alias for ++C. ++ ++=back ++ ++=head1 AUTHOR ++ ++Originally by the perl5-porters. ++ ++Maintained by Ken Williams ++ ++=head1 COPYRIGHT ++ ++Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. ++ ++This program is free software; you can redistribute it and/or modify ++it under the same terms as Perl itself. ++ ++Portions of the C code in this library are copyright (c) 1994 by the ++Regents of the University of California. All rights reserved. The ++license on this code is compatible with the licensing of the rest of ++the distribution - please see the source code in F for the ++details. ++ ++=head1 SEE ALSO ++ ++L ++ ++=cut +--- PathTools-3.47/Cwd.xs 2014-05-23 18:39:28.000000000 +0200 ++++ PathTools-core/Cwd.xs 2015-03-30 23:20:34.000000000 +0200 +@@ -1,3 +1,7 @@ ++/* ++ * ex: set ts=8 sts=4 sw=4 et: ++ */ ++ + #define PERL_NO_GET_CONTEXT + + #include "EXTERN.h" +@@ -11,6 +15,10 @@ + # include + #endif + ++/* For special handling of os390 sysplexed systems */ ++#define SYSNAME "$SYSNAME" ++#define SYSNAME_LEN (sizeof(SYSNAME) - 1) ++ + /* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13) + * Renamed here to bsd_realpath() to avoid library conflicts. + */ +@@ -68,144 +76,159 @@ + bsd_realpath(const char *path, char resolved[MAXPATHLEN]) + { + char *p, *q, *s; +- size_t left_len, resolved_len; ++ size_t remaining_len, resolved_len; + unsigned symlinks; + int serrno; +- char left[MAXPATHLEN], next_token[MAXPATHLEN]; ++ char remaining[MAXPATHLEN], next_token[MAXPATHLEN]; + + serrno = errno; + symlinks = 0; + if (path[0] == '/') { +- resolved[0] = '/'; +- resolved[1] = '\0'; +- if (path[1] == '\0') +- return (resolved); +- resolved_len = 1; +- left_len = my_strlcpy(left, path + 1, sizeof(left)); ++ resolved[0] = '/'; ++ resolved[1] = '\0'; ++ if (path[1] == '\0') ++ return (resolved); ++ resolved_len = 1; ++ remaining_len = my_strlcpy(remaining, path + 1, sizeof(remaining)); + } else { +- if (getcwd(resolved, MAXPATHLEN) == NULL) { +- my_strlcpy(resolved, ".", MAXPATHLEN); +- return (NULL); +- } +- resolved_len = strlen(resolved); +- left_len = my_strlcpy(left, path, sizeof(left)); ++ if (getcwd(resolved, MAXPATHLEN) == NULL) { ++ my_strlcpy(resolved, ".", MAXPATHLEN); ++ return (NULL); ++ } ++ resolved_len = strlen(resolved); ++ remaining_len = my_strlcpy(remaining, path, sizeof(remaining)); + } +- if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) { +- errno = ENAMETOOLONG; +- return (NULL); ++ if (remaining_len >= sizeof(remaining) || resolved_len >= MAXPATHLEN) { ++ errno = ENAMETOOLONG; ++ return (NULL); + } + + /* +- * Iterate over path components in 'left'. ++ * Iterate over path components in 'remaining'. + */ +- while (left_len != 0) { +- /* +- * Extract the next path component and adjust 'left' +- * and its length. +- */ +- p = strchr(left, '/'); +- s = p ? p : left + left_len; +- if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) { +- errno = ENAMETOOLONG; +- return (NULL); +- } +- memcpy(next_token, left, s - left); +- next_token[s - left] = '\0'; +- left_len -= s - left; +- if (p != NULL) +- memmove(left, s + 1, left_len + 1); +- if (resolved[resolved_len - 1] != '/') { +- if (resolved_len + 1 >= MAXPATHLEN) { +- errno = ENAMETOOLONG; +- return (NULL); +- } +- resolved[resolved_len++] = '/'; +- resolved[resolved_len] = '\0'; +- } +- if (next_token[0] == '\0') +- continue; +- else if (strcmp(next_token, ".") == 0) +- continue; +- else if (strcmp(next_token, "..") == 0) { +- /* +- * Strip the last path component except when we have +- * single "/" +- */ +- if (resolved_len > 1) { +- resolved[resolved_len - 1] = '\0'; +- q = strrchr(resolved, '/') + 1; +- *q = '\0'; +- resolved_len = q - resolved; +- } +- continue; +- } ++ while (remaining_len != 0) { + +- /* +- * Append the next path component and lstat() it. If +- * lstat() fails we still can return successfully if +- * there are no more path components left. +- */ +- resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN); +- if (resolved_len >= MAXPATHLEN) { +- errno = ENAMETOOLONG; +- return (NULL); +- } ++ /* ++ * Extract the next path component and adjust 'remaining' ++ * and its length. ++ */ ++ ++ p = strchr(remaining, '/'); ++ s = p ? p : remaining + remaining_len; ++ if ((STRLEN)(s - remaining) >= (STRLEN)sizeof(next_token)) { ++ errno = ENAMETOOLONG; ++ return (NULL); ++ } ++ memcpy(next_token, remaining, s - remaining); ++ next_token[s - remaining] = '\0'; ++ remaining_len -= s - remaining; ++ if (p != NULL) ++ memmove(remaining, s + 1, remaining_len + 1); ++ if (resolved[resolved_len - 1] != '/') { ++ if (resolved_len + 1 >= MAXPATHLEN) { ++ errno = ENAMETOOLONG; ++ return (NULL); ++ } ++ resolved[resolved_len++] = '/'; ++ resolved[resolved_len] = '\0'; ++ } ++ if (next_token[0] == '\0') ++ continue; ++ else if (strcmp(next_token, ".") == 0) ++ continue; ++ else if (strcmp(next_token, "..") == 0) { ++ /* ++ * Strip the last path component except when we have ++ * single "/" ++ */ ++ if (resolved_len > 1) { ++ resolved[resolved_len - 1] = '\0'; ++ q = strrchr(resolved, '/') + 1; ++ *q = '\0'; ++ resolved_len = q - resolved; ++ } ++ continue; ++ } ++ ++ /* ++ * Append the next path component and lstat() it. If ++ * lstat() fails we still can return successfully if ++ * there are no more path components left. ++ */ ++ resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN); ++ if (resolved_len >= MAXPATHLEN) { ++ errno = ENAMETOOLONG; ++ return (NULL); ++ } + #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK) +- { +- struct stat sb; +- if (lstat(resolved, &sb) != 0) { +- if (errno == ENOENT && p == NULL) { +- errno = serrno; +- return (resolved); +- } +- return (NULL); +- } +- if (S_ISLNK(sb.st_mode)) { +- int slen; +- char symlink[MAXPATHLEN]; +- +- if (symlinks++ > MAXSYMLINKS) { +- errno = ELOOP; +- return (NULL); +- } +- slen = readlink(resolved, symlink, sizeof(symlink) - 1); +- if (slen < 0) +- return (NULL); +- symlink[slen] = '\0'; +- if (symlink[0] == '/') { +- resolved[1] = 0; +- resolved_len = 1; +- } else if (resolved_len > 1) { +- /* Strip the last path component. */ +- resolved[resolved_len - 1] = '\0'; +- q = strrchr(resolved, '/') + 1; +- *q = '\0'; +- resolved_len = q - resolved; +- } +- +- /* +- * If there are any path components left, then +- * append them to symlink. The result is placed +- * in 'left'. +- */ +- if (p != NULL) { +- if (symlink[slen - 1] != '/') { +- if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) { +- errno = ENAMETOOLONG; +- return (NULL); +- } +- symlink[slen] = '/'; +- symlink[slen + 1] = 0; +- } +- left_len = my_strlcat(symlink, left, sizeof(left)); +- if (left_len >= sizeof(left)) { +- errno = ENAMETOOLONG; +- return (NULL); +- } +- } +- left_len = my_strlcpy(left, symlink, sizeof(left)); +- } +- } ++ { ++ struct stat sb; ++ if (lstat(resolved, &sb) != 0) { ++ if (errno == ENOENT && p == NULL) { ++ errno = serrno; ++ return (resolved); ++ } ++ return (NULL); ++ } ++ if (S_ISLNK(sb.st_mode)) { ++ int slen; ++ char symlink[MAXPATHLEN]; ++ ++ if (symlinks++ > MAXSYMLINKS) { ++ errno = ELOOP; ++ return (NULL); ++ } ++ slen = readlink(resolved, symlink, sizeof(symlink) - 1); ++ if (slen < 0) ++ return (NULL); ++ symlink[slen] = '\0'; ++# ifdef EBCDIC /* XXX Probably this should be only os390 */ ++ /* Replace all instances of $SYSNAME/foo simply by /foo */ ++ if (slen > SYSNAME_LEN + strlen(next_token) ++ && strnEQ(symlink, SYSNAME, SYSNAME_LEN) ++ && *(symlink + SYSNAME_LEN) == '/' ++ && strEQ(symlink + SYSNAME_LEN + 1, next_token)) ++ { ++ goto not_symlink; ++ } ++# endif ++ if (symlink[0] == '/') { ++ resolved[1] = 0; ++ resolved_len = 1; ++ } else if (resolved_len > 1) { ++ /* Strip the last path component. */ ++ resolved[resolved_len - 1] = '\0'; ++ q = strrchr(resolved, '/') + 1; ++ *q = '\0'; ++ resolved_len = q - resolved; ++ } ++ ++ /* ++ * If there are any path components left, then ++ * append them to symlink. The result is placed ++ * in 'remaining'. ++ */ ++ if (p != NULL) { ++ if (symlink[slen - 1] != '/') { ++ if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) { ++ errno = ENAMETOOLONG; ++ return (NULL); ++ } ++ symlink[slen] = '/'; ++ symlink[slen + 1] = 0; ++ } ++ remaining_len = my_strlcat(symlink, remaining, sizeof(symlink)); ++ if (remaining_len >= sizeof(remaining)) { ++ errno = ENAMETOOLONG; ++ return (NULL); ++ } ++ } ++ remaining_len = my_strlcpy(remaining, symlink, sizeof(remaining)); ++ } ++# ifdef EBCDIC ++ not_symlink: ; ++# endif ++ } + #endif + } + +@@ -214,7 +237,7 @@ + * is a single "/". + */ + if (resolved_len > 1 && resolved[resolved_len - 1] == '/') +- resolved[resolved_len - 1] = '\0'; ++ resolved[resolved_len - 1] = '\0'; + return (resolved); + } + #endif +diff -ruN PathTools-3.47/t/abs2rel.t PathTools-core/t/abs2rel.t +--- PathTools-3.47/t/abs2rel.t 1970-01-01 01:00:00.000000000 +0100 ++++ PathTools-core/t/abs2rel.t 2015-01-24 16:02:08.000000000 +0100 +@@ -0,0 +1,76 @@ ++#!/usr/bin/perl -w ++ ++use strict; ++use Test::More; ++ ++use Cwd qw(cwd getcwd abs_path); ++use File::Spec(); ++use File::Temp qw(tempdir); ++use File::Path qw(make_path); ++ ++my $startdir = cwd(); ++my @files = ( 'anyfile', './anyfile', '../first_sub_dir/anyfile', '../second_sub_dir/second_file' ); ++ ++for my $file (@files) { ++ test_rel2abs($file); ++} ++ ++sub test_rel2abs { ++ my $first_file = shift; ++ my $tdir = tempdir( CLEANUP => 1 ); ++ chdir $tdir or die "Unable to change to $tdir: $!"; ++ ++ my @subdirs = ( ++ 'first_sub_dir', ++ File::Spec->catdir('first_sub_dir', 'sub_sub_dir'), ++ 'second_sub_dir' ++ ); ++ make_path(@subdirs, { mode => 0711 }) ++ or die "Unable to make_path: $!"; ++ ++ open my $OUT2, '>', ++ File::Spec->catfile('second_sub_dir', 'second_file') ++ or die "Unable to open 'second_file' for writing: $!"; ++ print $OUT2 "Attempting to resolve RT #121360\n"; ++ close $OUT2 or die "Unable to close 'second_file' after writing: $!"; ++ ++ chdir 'first_sub_dir' ++ or die "Unable to change to 'first_sub_dir': $!"; ++ open my $OUT1, '>', $first_file ++ or die "Unable to open $first_file for writing: $!"; ++ print $OUT1 "Attempting to resolve RT #121360\n"; ++ close $OUT1 or die "Unable to close $first_file after writing: $!"; ++ ++ my $rel_path = $first_file; ++ my $rel_base = File::Spec->catdir(File::Spec->curdir(), 'sub_sub_dir'); ++ my $abs_path = File::Spec->rel2abs($rel_path); ++ my $abs_base = File::Spec->rel2abs($rel_base); ++ ok(-f $rel_path, "'$rel_path' is readable by effective uid/gid"); ++ ok(-f $abs_path, "'$abs_path' is readable by effective uid/gid"); ++ is_deeply( ++ [ (stat $rel_path)[0..5] ], ++ [ (stat $abs_path)[0..5] ], ++ "rel_path and abs_path stat same" ++ ); ++ ok(-d $rel_base, "'$rel_base' is a directory"); ++ ok(-d $abs_base, "'$abs_base' is a directory"); ++ is_deeply( ++ [ (stat $rel_base)[0..5] ], ++ [ (stat $abs_base)[0..5] ], ++ "rel_base and abs_base stat same" ++ ); ++ my $rr_link = File::Spec->abs2rel($rel_path, $rel_base); ++ my $ra_link = File::Spec->abs2rel($rel_path, $abs_base); ++ my $ar_link = File::Spec->abs2rel($abs_path, $rel_base); ++ my $aa_link = File::Spec->abs2rel($abs_path, $abs_base); ++ is($rr_link, $ra_link, ++ "rel_path-rel_base '$rr_link' = rel_path-abs_base '$ra_link'"); ++ is($ar_link, $aa_link, ++ "abs_path-rel_base '$ar_link' = abs_path-abs_base '$aa_link'"); ++ is($rr_link, $aa_link, ++ "rel_path-rel_base '$rr_link' = abs_path-abs_base '$aa_link'"); ++ ++ chdir $startdir or die "Unable to change back to $startdir: $!"; ++} ++ ++done_testing(); +diff -ruN PathTools-3.47/t/lib/Test/Builder.pm PathTools-core/t/lib/Test/Builder.pm +--- PathTools-3.47/t/lib/Test/Builder.pm 2011-12-20 08:15:58.000000000 +0100 ++++ PathTools-core/t/lib/Test/Builder.pm 1970-01-01 01:00:00.000000000 +0100 +@@ -1,1499 +0,0 @@ +-package Test::Builder; +- +-use 5.004; +- +-# $^C was only introduced in 5.005-ish. We do this to prevent +-# use of uninitialized value warnings in older perls. +-$^C ||= 0; +- +-use strict; +-use vars qw($VERSION); +-$VERSION = '0.19'; +- +-my $IsVMS = $^O eq 'VMS'; +- +-# Make Test::Builder thread-safe for ithreads. +-BEGIN { +- use Config; +- # Load threads::shared when threads are turned on +- if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) { +- require threads::shared; +- threads::shared->import; +- } +- # 5.8.0's threads::shared is busted when threads are off. +- # We emulate it here. +- else { +- *share = sub { return $_[0] }; +- *lock = sub { 0 }; +- } +-} +- +- +-=head1 NAME +- +-Test::Builder - Backend for building test libraries +- +-=head1 SYNOPSIS +- +- package My::Test::Module; +- use Test::Builder; +- require Exporter; +- @ISA = qw(Exporter); +- @EXPORT = qw(ok); +- +- my $Test = Test::Builder->new; +- $Test->output('my_logfile'); +- +- sub import { +- my($self) = shift; +- my $pack = caller; +- +- $Test->exported_to($pack); +- $Test->plan(@_); +- +- $self->export_to_level(1, $self, 'ok'); +- } +- +- sub ok { +- my($test, $name) = @_; +- +- $Test->ok($test, $name); +- } +- +- +-=head1 DESCRIPTION +- +-Test::Simple and Test::More have proven to be popular testing modules, +-but they're not always flexible enough. Test::Builder provides the a +-building block upon which to write your own test libraries I. +- +-=head2 Construction +- +-=over 4 +- +-=item B +- +- my $Test = Test::Builder->new; +- +-Returns a Test::Builder object representing the current state of the +-test. +- +-Since you only run one test per program, there is B +-Test::Builder object. No matter how many times you call new(), you're +-getting the same object. (This is called a singleton). +- +-=cut +- +-my $Test = Test::Builder->new; +-sub new { +- my($class) = shift; +- $Test ||= bless ['Move along, nothing to see here'], $class; +- return $Test; +-} +- +-=item B +- +- $Test->reset; +- +-Reinitializes the Test::Builder singleton to its original state. +-Mostly useful for tests run in persistent environments where the same +-test might be run multiple times in the same process. +- +-=cut +- +-my $Test_Died; +-my $Have_Plan; +-my $No_Plan; +-my $Curr_Test; share($Curr_Test); +-use vars qw($Level); +-my $Original_Pid; +-my @Test_Results; share(@Test_Results); +-my @Test_Details; share(@Test_Details); +- +-my $Exported_To; +-my $Expected_Tests; +- +-my $Skip_All; +- +-my $Use_Nums; +- +-my($No_Header, $No_Ending); +- +-$Test->reset; +- +-sub reset { +- my ($self) = @_; +- +- $Test_Died = 0; +- $Have_Plan = 0; +- $No_Plan = 0; +- $Curr_Test = 0; +- $Level = 1; +- $Original_Pid = $$; +- @Test_Results = (); +- @Test_Details = (); +- +- $Exported_To = undef; +- $Expected_Tests = 0; +- +- $Skip_All = 0; +- +- $Use_Nums = 1; +- +- ($No_Header, $No_Ending) = (0,0); +- +- $self->_dup_stdhandles unless $^C; +- +- return undef; +-} +- +-=back +- +-=head2 Setting up tests +- +-These methods are for setting up tests and declaring how many there +-are. You usually only want to call one of these methods. +- +-=over 4 +- +-=item B +- +- my $pack = $Test->exported_to; +- $Test->exported_to($pack); +- +-Tells Test::Builder what package you exported your functions to. +-This is important for getting TODO tests right. +- +-=cut +- +-sub exported_to { +- my($self, $pack) = @_; +- +- if( defined $pack ) { +- $Exported_To = $pack; +- } +- return $Exported_To; +-} +- +-=item B +- +- $Test->plan('no_plan'); +- $Test->plan( skip_all => $reason ); +- $Test->plan( tests => $num_tests ); +- +-A convenient way to set up your tests. Call this and Test::Builder +-will print the appropriate headers and take the appropriate actions. +- +-If you call plan(), don't call any of the other methods below. +- +-=cut +- +-sub plan { +- my($self, $cmd, $arg) = @_; +- +- return unless $cmd; +- +- if( $Have_Plan ) { +- die sprintf "You tried to plan twice! Second plan at %s line %d\n", +- ($self->caller)[1,2]; +- } +- +- if( $cmd eq 'no_plan' ) { +- $self->no_plan; +- } +- elsif( $cmd eq 'skip_all' ) { +- return $self->skip_all($arg); +- } +- elsif( $cmd eq 'tests' ) { +- if( $arg ) { +- return $self->expected_tests($arg); +- } +- elsif( !defined $arg ) { +- die "Got an undefined number of tests. Looks like you tried to ". +- "say how many tests you plan to run but made a mistake.\n"; +- } +- elsif( !$arg ) { +- die "You said to run 0 tests! You've got to run something.\n"; +- } +- } +- else { +- require Carp; +- my @args = grep { defined } ($cmd, $arg); +- Carp::croak("plan() doesn't understand @args"); +- } +- +- return 1; +-} +- +-=item B +- +- my $max = $Test->expected_tests; +- $Test->expected_tests($max); +- +-Gets/sets the # of tests we expect this test to run and prints out +-the appropriate headers. +- +-=cut +- +-sub expected_tests { +- my($self, $max) = @_; +- +- if( defined $max ) { +- $Expected_Tests = $max; +- $Have_Plan = 1; +- +- $self->_print("1..$max\n") unless $self->no_header; +- } +- return $Expected_Tests; +-} +- +- +-=item B +- +- $Test->no_plan; +- +-Declares that this test will run an indeterminate # of tests. +- +-=cut +- +-sub no_plan { +- $No_Plan = 1; +- $Have_Plan = 1; +-} +- +-=item B +- +- $plan = $Test->has_plan +- +-Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). +- +-=cut +- +-sub has_plan { +- return($Expected_Tests) if $Expected_Tests; +- return('no_plan') if $No_Plan; +- return(undef); +-}; +- +- +-=item B +- +- $Test->skip_all; +- $Test->skip_all($reason); +- +-Skips all the tests, using the given $reason. Exits immediately with 0. +- +-=cut +- +-sub skip_all { +- my($self, $reason) = @_; +- +- my $out = "1..0"; +- $out .= " # Skip $reason" if $reason; +- $out .= "\n"; +- +- $Skip_All = 1; +- +- $self->_print($out) unless $self->no_header; +- exit(0); +-} +- +-=back +- +-=head2 Running tests +- +-These actually run the tests, analogous to the functions in +-Test::More. +- +-$name is always optional. +- +-=over 4 +- +-=item B +- +- $Test->ok($test, $name); +- +-Your basic test. Pass if $test is true, fail if $test is false. Just +-like Test::Simple's ok(). +- +-=cut +- +-sub ok { +- my($self, $test, $name) = @_; +- +- # $test might contain an object which we don't want to accidentally +- # store, so we turn it into a boolean. +- $test = $test ? 1 : 0; +- +- unless( $Have_Plan ) { +- require Carp; +- Carp::croak("You tried to run a test without a plan! Gotta have a plan."); +- } +- +- lock $Curr_Test; +- $Curr_Test++; +- +- # In case $name is a string overloaded object, force it to stringify. +- local($@,$!); +- eval { +- if( defined $name ) { +- require overload; +- if( my $string_meth = overload::Method($name, '""') ) { +- $name = $name->$string_meth(); +- } +- } +- }; +- +- $self->diag(<caller; +- +- my $todo = $self->todo($pack); +- +- my $out; +- my $result = &share({}); +- +- unless( $test ) { +- $out .= "not "; +- @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); +- } +- else { +- @$result{ 'ok', 'actual_ok' } = ( 1, $test ); +- } +- +- $out .= "ok"; +- $out .= " $Curr_Test" if $self->use_numbers; +- +- if( defined $name ) { +- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. +- $out .= " - $name"; +- $result->{name} = $name; +- } +- else { +- $result->{name} = ''; +- } +- +- if( $todo ) { +- my $what_todo = $todo; +- $out .= " # TODO $what_todo"; +- $result->{reason} = $what_todo; +- $result->{type} = 'todo'; +- } +- else { +- $result->{reason} = ''; +- $result->{type} = ''; +- } +- +- $Test_Results[$Curr_Test-1] = $result; +- $out .= "\n"; +- +- $self->_print($out); +- +- unless( $test ) { +- my $msg = $todo ? "Failed (TODO)" : "Failed"; +- $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; +- $self->diag(" $msg test ($file at line $line)\n"); +- } +- +- return $test ? 1 : 0; +-} +- +-=item B +- +- $Test->is_eq($got, $expected, $name); +- +-Like Test::More's is(). Checks if $got eq $expected. This is the +-string version. +- +-=item B +- +- $Test->is_num($got, $expected, $name); +- +-Like Test::More's is(). Checks if $got == $expected. This is the +-numeric version. +- +-=cut +- +-sub is_eq { +- my($self, $got, $expect, $name) = @_; +- local $Level = $Level + 1; +- +- if( !defined $got || !defined $expect ) { +- # undef only matches undef and nothing else +- my $test = !defined $got && !defined $expect; +- +- $self->ok($test, $name); +- $self->_is_diag($got, 'eq', $expect) unless $test; +- return $test; +- } +- +- return $self->cmp_ok($got, 'eq', $expect, $name); +-} +- +-sub is_num { +- my($self, $got, $expect, $name) = @_; +- local $Level = $Level + 1; +- +- if( !defined $got || !defined $expect ) { +- # undef only matches undef and nothing else +- my $test = !defined $got && !defined $expect; +- +- $self->ok($test, $name); +- $self->_is_diag($got, '==', $expect) unless $test; +- return $test; +- } +- +- return $self->cmp_ok($got, '==', $expect, $name); +-} +- +-sub _is_diag { +- my($self, $got, $type, $expect) = @_; +- +- foreach my $val (\$got, \$expect) { +- if( defined $$val ) { +- if( $type eq 'eq' ) { +- # quote and force string context +- $$val = "'$$val'" +- } +- else { +- # force numeric context +- $$val = $$val+0; +- } +- } +- else { +- $$val = 'undef'; +- } +- } +- +- return $self->diag(sprintf < +- +- $Test->isnt_eq($got, $dont_expect, $name); +- +-Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +-the string version. +- +-=item B +- +- $Test->is_num($got, $dont_expect, $name); +- +-Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +-the numeric version. +- +-=cut +- +-sub isnt_eq { +- my($self, $got, $dont_expect, $name) = @_; +- local $Level = $Level + 1; +- +- if( !defined $got || !defined $dont_expect ) { +- # undef only matches undef and nothing else +- my $test = defined $got || defined $dont_expect; +- +- $self->ok($test, $name); +- $self->_cmp_diag($got, 'ne', $dont_expect) unless $test; +- return $test; +- } +- +- return $self->cmp_ok($got, 'ne', $dont_expect, $name); +-} +- +-sub isnt_num { +- my($self, $got, $dont_expect, $name) = @_; +- local $Level = $Level + 1; +- +- if( !defined $got || !defined $dont_expect ) { +- # undef only matches undef and nothing else +- my $test = defined $got || defined $dont_expect; +- +- $self->ok($test, $name); +- $self->_cmp_diag($got, '!=', $dont_expect) unless $test; +- return $test; +- } +- +- return $self->cmp_ok($got, '!=', $dont_expect, $name); +-} +- +- +-=item B +- +- $Test->like($this, qr/$regex/, $name); +- $Test->like($this, '/$regex/', $name); +- +-Like Test::More's like(). Checks if $this matches the given $regex. +- +-You'll want to avoid qr// if you want your tests to work before 5.005. +- +-=item B +- +- $Test->unlike($this, qr/$regex/, $name); +- $Test->unlike($this, '/$regex/', $name); +- +-Like Test::More's unlike(). Checks if $this B the +-given $regex. +- +-=cut +- +-sub like { +- my($self, $this, $regex, $name) = @_; +- +- local $Level = $Level + 1; +- $self->_regex_ok($this, $regex, '=~', $name); +-} +- +-sub unlike { +- my($self, $this, $regex, $name) = @_; +- +- local $Level = $Level + 1; +- $self->_regex_ok($this, $regex, '!~', $name); +-} +- +-=item B +- +- $Test->maybe_regex(qr/$regex/); +- $Test->maybe_regex('/$regex/'); +- +-Convenience method for building testing functions that take regular +-expressions as arguments, but need to work before perl 5.005. +- +-Takes a quoted regular expression produced by qr//, or a string +-representing a regular expression. +- +-Returns a Perl value which may be used instead of the corresponding +-regular expression, or undef if it's argument is not recognised. +- +-For example, a version of like(), sans the useful diagnostic messages, +-could be written as: +- +- sub laconic_like { +- my ($self, $this, $regex, $name) = @_; +- my $usable_regex = $self->maybe_regex($regex); +- die "expecting regex, found '$regex'\n" +- unless $usable_regex; +- $self->ok($this =~ m/$usable_regex/, $name); +- } +- +-=cut +- +- +-sub maybe_regex { +- my ($self, $regex) = @_; +- my $usable_regex = undef; +- if( ref $regex eq 'Regexp' ) { +- $usable_regex = $regex; +- } +- # Check if it looks like '/foo/' +- elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { +- $usable_regex = length $opts ? "(?$opts)$re" : $re; +- }; +- return($usable_regex) +-}; +- +-sub _regex_ok { +- my($self, $this, $regex, $cmp, $name) = @_; +- +- local $Level = $Level + 1; +- +- my $ok = 0; +- my $usable_regex = $self->maybe_regex($regex); +- unless (defined $usable_regex) { +- $ok = $self->ok( 0, $name ); +- $self->diag(" '$regex' doesn't look much like a regex to me."); +- return $ok; +- } +- +- { +- local $^W = 0; +- my $test = $this =~ /$usable_regex/ ? 1 : 0; +- $test = !$test if $cmp eq '!~'; +- $ok = $self->ok( $test, $name ); +- } +- +- unless( $ok ) { +- $this = defined $this ? "'$this'" : 'undef'; +- my $match = $cmp eq '=~' ? "doesn't match" : "matches"; +- $self->diag(sprintf < +- +- $Test->cmp_ok($this, $type, $that, $name); +- +-Works just like Test::More's cmp_ok(). +- +- $Test->cmp_ok($big_num, '!=', $other_big_num); +- +-=cut +- +-sub cmp_ok { +- my($self, $got, $type, $expect, $name) = @_; +- +- my $test; +- { +- local $^W = 0; +- local($@,$!); # don't interfere with $@ +- # eval() sometimes resets $! +- $test = eval "\$got $type \$expect"; +- } +- local $Level = $Level + 1; +- my $ok = $self->ok($test, $name); +- +- unless( $ok ) { +- if( $type =~ /^(eq|==)$/ ) { +- $self->_is_diag($got, $type, $expect); +- } +- else { +- $self->_cmp_diag($got, $type, $expect); +- } +- } +- return $ok; +-} +- +-sub _cmp_diag { +- my($self, $got, $type, $expect) = @_; +- +- $got = defined $got ? "'$got'" : 'undef'; +- $expect = defined $expect ? "'$expect'" : 'undef'; +- return $self->diag(sprintf < +- +- $Test->BAILOUT($reason); +- +-Indicates to the Test::Harness that things are going so badly all +-testing should terminate. This includes running any additional test +-scripts. +- +-It will exit with 255. +- +-=cut +- +-sub BAILOUT { +- my($self, $reason) = @_; +- +- $self->_print("Bail out! $reason"); +- exit 255; +-} +- +-=item B +- +- $Test->skip; +- $Test->skip($why); +- +-Skips the current test, reporting $why. +- +-=cut +- +-sub skip { +- my($self, $why) = @_; +- $why ||= ''; +- +- unless( $Have_Plan ) { +- require Carp; +- Carp::croak("You tried to run tests without a plan! Gotta have a plan."); +- } +- +- lock($Curr_Test); +- $Curr_Test++; +- +- $Test_Results[$Curr_Test-1] = &share({ +- 'ok' => 1, +- actual_ok => 1, +- name => '', +- type => 'skip', +- reason => $why, +- }); +- +- my $out = "ok"; +- $out .= " $Curr_Test" if $self->use_numbers; +- $out .= " # skip $why\n"; +- +- $Test->_print($out); +- +- return 1; +-} +- +- +-=item B +- +- $Test->todo_skip; +- $Test->todo_skip($why); +- +-Like skip(), only it will declare the test as failing and TODO. Similar +-to +- +- print "not ok $tnum # TODO $why\n"; +- +-=cut +- +-sub todo_skip { +- my($self, $why) = @_; +- $why ||= ''; +- +- unless( $Have_Plan ) { +- require Carp; +- Carp::croak("You tried to run tests without a plan! Gotta have a plan."); +- } +- +- lock($Curr_Test); +- $Curr_Test++; +- +- $Test_Results[$Curr_Test-1] = &share({ +- 'ok' => 1, +- actual_ok => 0, +- name => '', +- type => 'todo_skip', +- reason => $why, +- }); +- +- my $out = "not ok"; +- $out .= " $Curr_Test" if $self->use_numbers; +- $out .= " # TODO & SKIP $why\n"; +- +- $Test->_print($out); +- +- return 1; +-} +- +- +-=begin _unimplemented +- +-=item B +- +- $Test->skip_rest; +- $Test->skip_rest($reason); +- +-Like skip(), only it skips all the rest of the tests you plan to run +-and terminates the test. +- +-If you're running under no_plan, it skips once and terminates the +-test. +- +-=end _unimplemented +- +-=back +- +- +-=head2 Test style +- +-=over 4 +- +-=item B +- +- $Test->level($how_high); +- +-How far up the call stack should $Test look when reporting where the +-test failed. +- +-Defaults to 1. +- +-Setting $Test::Builder::Level overrides. This is typically useful +-localized: +- +- { +- local $Test::Builder::Level = 2; +- $Test->ok($test); +- } +- +-=cut +- +-sub level { +- my($self, $level) = @_; +- +- if( defined $level ) { +- $Level = $level; +- } +- return $Level; +-} +- +- +-=item B +- +- $Test->use_numbers($on_or_off); +- +-Whether or not the test should output numbers. That is, this if true: +- +- ok 1 +- ok 2 +- ok 3 +- +-or this if false +- +- ok +- ok +- ok +- +-Most useful when you can't depend on the test output order, such as +-when threads or forking is involved. +- +-Test::Harness will accept either, but avoid mixing the two styles. +- +-Defaults to on. +- +-=cut +- +-sub use_numbers { +- my($self, $use_nums) = @_; +- +- if( defined $use_nums ) { +- $Use_Nums = $use_nums; +- } +- return $Use_Nums; +-} +- +-=item B +- +- $Test->no_header($no_header); +- +-If set to true, no "1..N" header will be printed. +- +-=item B +- +- $Test->no_ending($no_ending); +- +-Normally, Test::Builder does some extra diagnostics when the test +-ends. It also changes the exit code as described below. +- +-If this is true, none of that will be done. +- +-=cut +- +-sub no_header { +- my($self, $no_header) = @_; +- +- if( defined $no_header ) { +- $No_Header = $no_header; +- } +- return $No_Header; +-} +- +-sub no_ending { +- my($self, $no_ending) = @_; +- +- if( defined $no_ending ) { +- $No_Ending = $no_ending; +- } +- return $No_Ending; +-} +- +- +-=back +- +-=head2 Output +- +-Controlling where the test output goes. +- +-It's ok for your test to change where STDOUT and STDERR point to, +-Test::Builder's default output settings will not be affected. +- +-=over 4 +- +-=item B +- +- $Test->diag(@msgs); +- +-Prints out the given $message. Normally, it uses the failure_output() +-handle, but if this is for a TODO test, the todo_output() handle is +-used. +- +-Output will be indented and marked with a # so as not to interfere +-with test output. A newline will be put on the end if there isn't one +-already. +- +-We encourage using this rather than calling print directly. +- +-Returns false. Why? Because diag() is often used in conjunction with +-a failing test (C) it "passes through" the failure. +- +- return ok(...) || diag(...); +- +-=for blame transfer +-Mark Fowler +- +-=cut +- +-sub diag { +- my($self, @msgs) = @_; +- return unless @msgs; +- +- # Prevent printing headers when compiling (i.e. -c) +- return if $^C; +- +- # Escape each line with a #. +- foreach (@msgs) { +- $_ = 'undef' unless defined; +- s/^/# /gms; +- } +- +- push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; +- +- local $Level = $Level + 1; +- $self->_print_diag(@msgs); +- +- return 0; +-} +- +-=begin _private +- +-=item B<_print> +- +- $Test->_print(@msgs); +- +-Prints to the output() filehandle. +- +-=end _private +- +-=cut +- +-sub _print { +- my($self, @msgs) = @_; +- +- # Prevent printing headers when only compiling. Mostly for when +- # tests are deparsed with B::Deparse +- return if $^C; +- +- local($\, $", $,) = (undef, ' ', ''); +- my $fh = $self->output; +- +- # Escape each line after the first with a # so we don't +- # confuse Test::Harness. +- foreach (@msgs) { +- s/\n(.)/\n# $1/sg; +- } +- +- push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; +- +- print $fh @msgs; +-} +- +- +-=item B<_print_diag> +- +- $Test->_print_diag(@msg); +- +-Like _print, but prints to the current diagnostic filehandle. +- +-=cut +- +-sub _print_diag { +- my $self = shift; +- +- local($\, $", $,) = (undef, ' ', ''); +- my $fh = $self->todo ? $self->todo_output : $self->failure_output; +- print $fh @_; +-} +- +-=item B +- +- $Test->output($fh); +- $Test->output($file); +- +-Where normal "ok/not ok" test output should go. +- +-Defaults to STDOUT. +- +-=item B +- +- $Test->failure_output($fh); +- $Test->failure_output($file); +- +-Where diagnostic output on test failures and diag() should go. +- +-Defaults to STDERR. +- +-=item B +- +- $Test->todo_output($fh); +- $Test->todo_output($file); +- +-Where diagnostics about todo test failures and diag() should go. +- +-Defaults to STDOUT. +- +-=cut +- +-my($Out_FH, $Fail_FH, $Todo_FH); +-sub output { +- my($self, $fh) = @_; +- +- if( defined $fh ) { +- $Out_FH = _new_fh($fh); +- } +- return $Out_FH; +-} +- +-sub failure_output { +- my($self, $fh) = @_; +- +- if( defined $fh ) { +- $Fail_FH = _new_fh($fh); +- } +- return $Fail_FH; +-} +- +-sub todo_output { +- my($self, $fh) = @_; +- +- if( defined $fh ) { +- $Todo_FH = _new_fh($fh); +- } +- return $Todo_FH; +-} +- +-sub _new_fh { +- my($file_or_fh) = shift; +- +- my $fh; +- unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { +- $fh = do { local *FH }; +- open $fh, ">$file_or_fh" or +- die "Can't open test output log $file_or_fh: $!"; +- } +- else { +- $fh = $file_or_fh; +- } +- +- return $fh; +-} +- +-sub _autoflush { +- my($fh) = shift; +- my $old_fh = select $fh; +- $| = 1; +- select $old_fh; +-} +- +- +-my $Opened_Testhandles = 0; +-sub _dup_stdhandles { +- my $self = shift; +- +- $self->_open_testhandles unless $Opened_Testhandles; +- +- # Set everything to unbuffered else plain prints to STDOUT will +- # come out in the wrong order from our own prints. +- _autoflush(\*TESTOUT); +- _autoflush(\*STDOUT); +- _autoflush(\*TESTERR); +- _autoflush(\*STDERR); +- +- $Test->output(\*TESTOUT); +- $Test->failure_output(\*TESTERR); +- $Test->todo_output(\*TESTOUT); +-} +- +-sub _open_testhandles { +- # We dup STDOUT and STDERR so people can change them in their +- # test suites while still getting normal test output. +- open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; +- open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; +- $Opened_Testhandles = 1; +-} +- +- +-=back +- +- +-=head2 Test Status and Info +- +-=over 4 +- +-=item B +- +- my $curr_test = $Test->current_test; +- $Test->current_test($num); +- +-Gets/sets the current test # we're on. +- +-You usually shouldn't have to set this. +- +-=cut +- +-sub current_test { +- my($self, $num) = @_; +- +- lock($Curr_Test); +- if( defined $num ) { +- unless( $Have_Plan ) { +- require Carp; +- Carp::croak("Can't change the current test number without a plan!"); +- } +- +- $Curr_Test = $num; +- if( $num > @Test_Results ) { +- my $start = @Test_Results ? $#Test_Results + 1 : 0; +- for ($start..$num-1) { +- $Test_Results[$_] = &share({ +- 'ok' => 1, +- actual_ok => undef, +- reason => 'incrementing test number', +- type => 'unknown', +- name => undef +- }); +- } +- } +- } +- return $Curr_Test; +-} +- +- +-=item B +- +- my @tests = $Test->summary; +- +-A simple summary of the tests so far. True for pass, false for fail. +-This is a logical pass/fail, so todos are passes. +- +-Of course, test #1 is $tests[0], etc... +- +-=cut +- +-sub summary { +- my($self) = shift; +- +- return map { $_->{'ok'} } @Test_Results; +-} +- +-=item B
+- +- my @tests = $Test->details; +- +-Like summary(), but with a lot more detail. +- +- $tests[$test_num - 1] = +- { 'ok' => is the test considered a pass? +- actual_ok => did it literally say 'ok'? +- name => name of the test (if any) +- type => type of test (if any, see below). +- reason => reason for the above (if any) +- }; +- +-'ok' is true if Test::Harness will consider the test to be a pass. +- +-'actual_ok' is a reflection of whether or not the test literally +-printed 'ok' or 'not ok'. This is for examining the result of 'todo' +-tests. +- +-'name' is the name of the test. +- +-'type' indicates if it was a special test. Normal tests have a type +-of ''. Type can be one of the following: +- +- skip see skip() +- todo see todo() +- todo_skip see todo_skip() +- unknown see below +- +-Sometimes the Test::Builder test counter is incremented without it +-printing any test output, for example, when current_test() is changed. +-In these cases, Test::Builder doesn't know the result of the test, so +-it's type is 'unkown'. These details for these tests are filled in. +-They are considered ok, but the name and actual_ok is left undef. +- +-For example "not ok 23 - hole count # TODO insufficient donuts" would +-result in this structure: +- +- $tests[22] = # 23 - 1, since arrays start from 0. +- { ok => 1, # logically, the test passed since it's todo +- actual_ok => 0, # in absolute terms, it failed +- name => 'hole count', +- type => 'todo', +- reason => 'insufficient donuts' +- }; +- +-=cut +- +-sub details { +- return @Test_Results; +-} +- +-=item B +- +- my $todo_reason = $Test->todo; +- my $todo_reason = $Test->todo($pack); +- +-todo() looks for a $TODO variable in your tests. If set, all tests +-will be considered 'todo' (see Test::More and Test::Harness for +-details). Returns the reason (ie. the value of $TODO) if running as +-todo tests, false otherwise. +- +-todo() is pretty part about finding the right package to look for +-$TODO in. It uses the exported_to() package to find it. If that's +-not set, it's pretty good at guessing the right package to look at. +- +-Sometimes there is some confusion about where todo() should be looking +-for the $TODO variable. If you want to be sure, tell it explicitly +-what $pack to use. +- +-=cut +- +-sub todo { +- my($self, $pack) = @_; +- +- $pack = $pack || $self->exported_to || $self->caller(1); +- +- no strict 'refs'; +- return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} +- : 0; +-} +- +-=item B +- +- my $package = $Test->caller; +- my($pack, $file, $line) = $Test->caller; +- my($pack, $file, $line) = $Test->caller($height); +- +-Like the normal caller(), except it reports according to your level(). +- +-=cut +- +-sub caller { +- my($self, $height) = @_; +- $height ||= 0; +- +- my @caller = CORE::caller($self->level + $height + 1); +- return wantarray ? @caller : $caller[0]; +-} +- +-=back +- +-=cut +- +-=begin _private +- +-=over 4 +- +-=item B<_sanity_check> +- +- _sanity_check(); +- +-Runs a bunch of end of test sanity checks to make sure reality came +-through ok. If anything is wrong it will die with a fairly friendly +-error message. +- +-=cut +- +-#'# +-sub _sanity_check { +- _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); +- _whoa(!$Have_Plan and $Curr_Test, +- 'Somehow your tests ran without a plan!'); +- _whoa($Curr_Test != @Test_Results, +- 'Somehow you got a different number of results than tests ran!'); +-} +- +-=item B<_whoa> +- +- _whoa($check, $description); +- +-A sanity check, similar to assert(). If the $check is true, something +-has gone horribly wrong. It will die with the given $description and +-a note to contact the author. +- +-=cut +- +-sub _whoa { +- my($check, $desc) = @_; +- if( $check ) { +- die < +- +- _my_exit($exit_num); +- +-Perl seems to have some trouble with exiting inside an END block. 5.005_03 +-and 5.6.1 both seem to do odd things. Instead, this function edits $? +-directly. It should ONLY be called from inside an END block. It +-doesn't actually exit, that's your job. +- +-=cut +- +-sub _my_exit { +- $? = $_[0]; +- +- return 1; +-} +- +- +-=back +- +-=end _private +- +-=cut +- +-$SIG{__DIE__} = sub { +- # We don't want to muck with death in an eval, but $^S isn't +- # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing +- # with it. Instead, we use caller. This also means it runs under +- # 5.004! +- my $in_eval = 0; +- for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { +- $in_eval = 1 if $sub =~ /^\(eval\)/; +- } +- $Test_Died = 1 unless $in_eval; +-}; +- +-sub _ending { +- my $self = shift; +- +- _sanity_check(); +- +- # Don't bother with an ending if this is a forked copy. Only the parent +- # should do the ending. +- do{ _my_exit($?) && return } if $Original_Pid != $$; +- +- # Bailout if plan() was never called. This is so +- # "require Test::Simple" doesn't puke. +- do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; +- +- # Figure out if we passed or failed and print helpful messages. +- if( @Test_Results ) { +- # The plan? We have no plan. +- if( $No_Plan ) { +- $self->_print("1..$Curr_Test\n") unless $self->no_header; +- $Expected_Tests = $Curr_Test; +- } +- +- # Auto-extended arrays and elements which aren't explicitly +- # filled in with a shared reference will puke under 5.8.0 +- # ithreads. So we have to fill them in by hand. :( +- my $empty_result = &share({}); +- for my $idx ( 0..$Expected_Tests-1 ) { +- $Test_Results[$idx] = $empty_result +- unless defined $Test_Results[$idx]; +- } +- +- my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; +- $num_failed += abs($Expected_Tests - @Test_Results); +- +- if( $Curr_Test < $Expected_Tests ) { +- my $s = $Expected_Tests == 1 ? '' : 's'; +- $self->diag(<<"FAIL"); +-Looks like you planned $Expected_Tests test$s but only ran $Curr_Test. +-FAIL +- } +- elsif( $Curr_Test > $Expected_Tests ) { +- my $num_extra = $Curr_Test - $Expected_Tests; +- my $s = $Expected_Tests == 1 ? '' : 's'; +- $self->diag(<<"FAIL"); +-Looks like you planned $Expected_Tests test$s but ran $num_extra extra. +-FAIL +- } +- elsif ( $num_failed ) { +- my $s = $num_failed == 1 ? '' : 's'; +- $self->diag(<<"FAIL"); +-Looks like you failed $num_failed test$s of $Expected_Tests. +-FAIL +- } +- +- if( $Test_Died ) { +- $self->diag(<<"FAIL"); +-Looks like your test died just after $Curr_Test. +-FAIL +- +- _my_exit( 255 ) && return; +- } +- +- _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; +- } +- elsif ( $Skip_All ) { +- _my_exit( 0 ) && return; +- } +- elsif ( $Test_Died ) { +- $self->diag(<<'FAIL'); +-Looks like your test died before it could output anything. +-FAIL +- _my_exit( 255 ) && return; +- } +- else { +- $self->diag("No tests run!\n"); +- _my_exit( 255 ) && return; +- } +-} +- +-END { +- $Test->_ending if defined $Test and !$Test->no_ending; +-} +- +-=head1 EXIT CODES +- +-If all your tests passed, Test::Builder will exit with zero (which is +-normal). If anything failed it will exit with how many failed. If +-you run less (or more) tests than you planned, the missing (or extras) +-will be considered failures. If no tests were ever run Test::Builder +-will throw a warning and exit with 255. If the test died, even after +-having successfully completed all its tests, it will still be +-considered a failure and will exit with 255. +- +-So the exit codes are... +- +- 0 all tests successful +- 255 test died +- any other number how many failed (including missing or extras) +- +-If you fail more than 254 tests, it will be reported as 254. +- +- +-=head1 THREADS +- +-In perl 5.8.0 and later, Test::Builder is thread-safe. The test +-number is shared amongst all threads. This means if one thread sets +-the test number using current_test() they will all be effected. +- +-Test::Builder is only thread-aware if threads.pm is loaded I +-Test::Builder. +- +-=head1 EXAMPLES +- +-CPAN can provide the best examples. Test::Simple, Test::More, +-Test::Exception and Test::Differences all use Test::Builder. +- +-=head1 SEE ALSO +- +-Test::Simple, Test::More, Test::Harness +- +-=head1 AUTHORS +- +-Original code by chromatic, maintained by Michael G Schwern +-Eschwern@pobox.comE +- +-=head1 COPYRIGHT +- +-Copyright 2002 by chromatic Echromatic@wgz.orgE, +- Michael G Schwern Eschwern@pobox.comE. +- +-This program is free software; you can redistribute it and/or +-modify it under the same terms as Perl itself. +- +-See F +- +-=cut +- +-1; +diff -ruN PathTools-3.47/t/lib/Test/More.pm PathTools-core/t/lib/Test/More.pm +--- PathTools-3.47/t/lib/Test/More.pm 2011-12-20 08:15:58.000000000 +0100 ++++ PathTools-core/t/lib/Test/More.pm 1970-01-01 01:00:00.000000000 +0100 +@@ -1,1330 +0,0 @@ +-package Test::More; +- +-use 5.004; +- +-use strict; +-use Test::Builder; +- +- +-# Can't use Carp because it might cause use_ok() to accidentally succeed +-# even though the module being used forgot to use Carp. Yes, this +-# actually happened. +-sub _carp { +- my($file, $line) = (caller(1))[1,2]; +- warn @_, " at $file line $line\n"; +-} +- +- +- +-require Exporter; +-use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +-$VERSION = '0.49'; +-@ISA = qw(Exporter); +-@EXPORT = qw(ok use_ok require_ok +- is isnt like unlike is_deeply +- cmp_ok +- skip todo todo_skip +- pass fail +- eq_array eq_hash eq_set +- $TODO +- plan +- can_ok isa_ok +- diag +- ); +- +-my $Test = Test::Builder->new; +-my $Show_Diag = 1; +- +- +-# 5.004's Exporter doesn't have export_to_level. +-sub _export_to_level +-{ +- my $pkg = shift; +- my $level = shift; +- (undef) = shift; # redundant arg +- my $callpkg = caller($level); +- $pkg->export($callpkg, @_); +-} +- +- +-=head1 NAME +- +-Test::More - yet another framework for writing test scripts +- +-=head1 SYNOPSIS +- +- use Test::More tests => $Num_Tests; +- # or +- use Test::More qw(no_plan); +- # or +- use Test::More skip_all => $reason; +- +- BEGIN { use_ok( 'Some::Module' ); } +- require_ok( 'Some::Module' ); +- +- # Various ways to say "ok" +- ok($this eq $that, $test_name); +- +- is ($this, $that, $test_name); +- isnt($this, $that, $test_name); +- +- # Rather than print STDERR "# here's what went wrong\n" +- diag("here's what went wrong"); +- +- like ($this, qr/that/, $test_name); +- unlike($this, qr/that/, $test_name); +- +- cmp_ok($this, '==', $that, $test_name); +- +- is_deeply($complex_structure1, $complex_structure2, $test_name); +- +- SKIP: { +- skip $why, $how_many unless $have_some_feature; +- +- ok( foo(), $test_name ); +- is( foo(42), 23, $test_name ); +- }; +- +- TODO: { +- local $TODO = $why; +- +- ok( foo(), $test_name ); +- is( foo(42), 23, $test_name ); +- }; +- +- can_ok($module, @methods); +- isa_ok($object, $class); +- +- pass($test_name); +- fail($test_name); +- +- # Utility comparison functions. +- eq_array(\@this, \@that); +- eq_hash(\%this, \%that); +- eq_set(\@this, \@that); +- +- # UNIMPLEMENTED!!! +- my @status = Test::More::status; +- +- # UNIMPLEMENTED!!! +- BAIL_OUT($why); +- +- +-=head1 DESCRIPTION +- +-B If you're just getting started writing tests, have a look at +-Test::Simple first. This is a drop in replacement for Test::Simple +-which you can switch to once you get the hang of basic testing. +- +-The purpose of this module is to provide a wide range of testing +-utilities. Various ways to say "ok" with better diagnostics, +-facilities to skip tests, test future features and compare complicated +-data structures. While you can do almost anything with a simple +-C function, it doesn't provide good diagnostic output. +- +- +-=head2 I love it when a plan comes together +- +-Before anything else, you need a testing plan. This basically declares +-how many tests your script is going to run to protect against premature +-failure. +- +-The preferred way to do this is to declare a plan when you C. +- +- use Test::More tests => $Num_Tests; +- +-There are rare cases when you will not know beforehand how many tests +-your script is going to run. In this case, you can declare that you +-have no plan. (Try to avoid using this as it weakens your test.) +- +- use Test::More qw(no_plan); +- +-B: using no_plan requires a Test::Harness upgrade else it will +-think everything has failed. See L) +- +-In some cases, you'll want to completely skip an entire testing script. +- +- use Test::More skip_all => $skip_reason; +- +-Your script will declare a skip with the reason why you skipped and +-exit immediately with a zero (success). See L for +-details. +- +-If you want to control what functions Test::More will export, you +-have to use the 'import' option. For example, to import everything +-but 'fail', you'd do: +- +- use Test::More tests => 23, import => ['!fail']; +- +-Alternatively, you can use the plan() function. Useful for when you +-have to calculate the number of tests. +- +- use Test::More; +- plan tests => keys %Stuff * 3; +- +-or for deciding between running the tests at all: +- +- use Test::More; +- if( $^O eq 'MacOS' ) { +- plan skip_all => 'Test irrelevant on MacOS'; +- } +- else { +- plan tests => 42; +- } +- +-=cut +- +-sub plan { +- my(@plan) = @_; +- +- my $caller = caller; +- +- $Test->exported_to($caller); +- +- my @cleaned_plan; +- my @imports = (); +- my $idx = 0; +- while( $idx <= $#plan ) { +- if( $plan[$idx] eq 'import' ) { +- @imports = @{$plan[$idx+1]}; +- $idx += 2; +- } +- elsif( $plan[$idx] eq 'no_diag' ) { +- $Show_Diag = 0; +- $idx++; +- } +- else { +- push @cleaned_plan, $plan[$idx]; +- $idx++; +- } +- } +- +- $Test->plan(@cleaned_plan); +- +- __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +-} +- +-sub import { +- my($class) = shift; +- goto &plan; +-} +- +- +-=head2 Test names +- +-By convention, each test is assigned a number in order. This is +-largely done automatically for you. However, it's often very useful to +-assign a name to each test. Which would you rather see: +- +- ok 4 +- not ok 5 +- ok 6 +- +-or +- +- ok 4 - basic multi-variable +- not ok 5 - simple exponential +- ok 6 - force == mass * acceleration +- +-The later gives you some idea of what failed. It also makes it easier +-to find the test in your script, simply search for "simple +-exponential". +- +-All test functions take a name argument. It's optional, but highly +-suggested that you use it. +- +- +-=head2 I'm ok, you're not ok. +- +-The basic purpose of this module is to print out either "ok #" or "not +-ok #" depending on if a given test succeeded or failed. Everything +-else is just gravy. +- +-All of the following print "ok" or "not ok" depending on if the test +-succeeded or failed. They all also return true or false, +-respectively. +- +-=over 4 +- +-=item B +- +- ok($this eq $that, $test_name); +- +-This simply evaluates any expression (C<$this eq $that> is just a +-simple example) and uses that to determine if the test succeeded or +-failed. A true expression passes, a false one fails. Very simple. +- +-For example: +- +- ok( $exp{9} == 81, 'simple exponential' ); +- ok( Film->can('db_Main'), 'set_db()' ); +- ok( $p->tests == 4, 'saw tests' ); +- ok( !grep !defined $_, @items, 'items populated' ); +- +-(Mnemonic: "This is ok.") +- +-$test_name is a very short description of the test that will be printed +-out. It makes it very easy to find a test in your script when it fails +-and gives others an idea of your intentions. $test_name is optional, +-but we B strongly encourage its use. +- +-Should an ok() fail, it will produce some diagnostics: +- +- not ok 18 - sufficient mucus +- # Failed test 18 (foo.t at line 42) +- +-This is actually Test::Simple's ok() routine. +- +-=cut +- +-sub ok ($;$) { +- my($test, $name) = @_; +- $Test->ok($test, $name); +-} +- +-=item B +- +-=item B +- +- is ( $this, $that, $test_name ); +- isnt( $this, $that, $test_name ); +- +-Similar to ok(), is() and isnt() compare their two arguments +-with C and C respectively and use the result of that to +-determine if the test succeeded or failed. So these: +- +- # Is the ultimate answer 42? +- is( ultimate_answer(), 42, "Meaning of Life" ); +- +- # $foo isn't empty +- isnt( $foo, '', "Got some foo" ); +- +-are similar to these: +- +- ok( ultimate_answer() eq 42, "Meaning of Life" ); +- ok( $foo ne '', "Got some foo" ); +- +-(Mnemonic: "This is that." "This isn't that.") +- +-So why use these? They produce better diagnostics on failure. ok() +-cannot know what you are testing for (beyond the name), but is() and +-isnt() know what the test was and why it failed. For example this +-test: +- +- my $foo = 'waffle'; my $bar = 'yarblokos'; +- is( $foo, $bar, 'Is foo the same as bar?' ); +- +-Will produce something like this: +- +- not ok 17 - Is foo the same as bar? +- # Failed test (foo.t at line 139) +- # got: 'waffle' +- # expected: 'yarblokos' +- +-So you can figure out what went wrong without rerunning the test. +- +-You are encouraged to use is() and isnt() over ok() where possible, +-however do not be tempted to use them to find out if something is +-true or false! +- +- # XXX BAD! +- is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); +- +-This does not check if C is true, it checks if +-it returns 1. Very different. Similar caveats exist for false and 0. +-In these cases, use ok(). +- +- ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); +- +-For those grammatical pedants out there, there's an C +-function which is an alias of isnt(). +- +-=cut +- +-sub is ($$;$) { +- $Test->is_eq(@_); +-} +- +-sub isnt ($$;$) { +- $Test->isnt_eq(@_); +-} +- +-*isn't = \&isnt; +- +- +-=item B +- +- like( $this, qr/that/, $test_name ); +- +-Similar to ok(), like() matches $this against the regex C. +- +-So this: +- +- like($this, qr/that/, 'this is like that'); +- +-is similar to: +- +- ok( $this =~ /that/, 'this is like that'); +- +-(Mnemonic "This is like that".) +- +-The second argument is a regular expression. It may be given as a +-regex reference (i.e. C) or (for better compatibility with older +-perls) as a string that looks like a regex (alternative delimiters are +-currently not supported): +- +- like( $this, '/that/', 'this is like that' ); +- +-Regex options may be placed on the end (C<'/that/i'>). +- +-Its advantages over ok() are similar to that of is() and isnt(). Better +-diagnostics on failure. +- +-=cut +- +-sub like ($$;$) { +- $Test->like(@_); +-} +- +- +-=item B +- +- unlike( $this, qr/that/, $test_name ); +- +-Works exactly as like(), only it checks if $this B match the +-given pattern. +- +-=cut +- +-sub unlike ($$;$) { +- $Test->unlike(@_); +-} +- +- +-=item B +- +- cmp_ok( $this, $op, $that, $test_name ); +- +-Halfway between ok() and is() lies cmp_ok(). This allows you to +-compare two arguments using any binary perl operator. +- +- # ok( $this eq $that ); +- cmp_ok( $this, 'eq', $that, 'this eq that' ); +- +- # ok( $this == $that ); +- cmp_ok( $this, '==', $that, 'this == that' ); +- +- # ok( $this && $that ); +- cmp_ok( $this, '&&', $that, 'this && that' ); +- ...etc... +- +-Its advantage over ok() is when the test fails you'll know what $this +-and $that were: +- +- not ok 1 +- # Failed test (foo.t at line 12) +- # '23' +- # && +- # undef +- +-It's also useful in those cases where you are comparing numbers and +-is()'s use of C will interfere: +- +- cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); +- +-=cut +- +-sub cmp_ok($$$;$) { +- $Test->cmp_ok(@_); +-} +- +- +-=item B +- +- can_ok($module, @methods); +- can_ok($object, @methods); +- +-Checks to make sure the $module or $object can do these @methods +-(works with functions, too). +- +- can_ok('Foo', qw(this that whatever)); +- +-is almost exactly like saying: +- +- ok( Foo->can('this') && +- Foo->can('that') && +- Foo->can('whatever') +- ); +- +-only without all the typing and with a better interface. Handy for +-quickly testing an interface. +- +-No matter how many @methods you check, a single can_ok() call counts +-as one test. If you desire otherwise, use: +- +- foreach my $meth (@methods) { +- can_ok('Foo', $meth); +- } +- +-=cut +- +-sub can_ok ($@) { +- my($proto, @methods) = @_; +- my $class = ref $proto || $proto; +- +- unless( @methods ) { +- my $ok = $Test->ok( 0, "$class->can(...)" ); +- $Test->diag(' can_ok() called with no methods'); +- return $ok; +- } +- +- my @nok = (); +- foreach my $method (@methods) { +- local($!, $@); # don't interfere with caller's $@ +- # eval sometimes resets $! +- eval { $proto->can($method) } || push @nok, $method; +- } +- +- my $name; +- $name = @methods == 1 ? "$class->can('$methods[0]')" +- : "$class->can(...)"; +- +- my $ok = $Test->ok( !@nok, $name ); +- +- $Test->diag(map " $class->can('$_') failed\n", @nok); +- +- return $ok; +-} +- +-=item B +- +- isa_ok($object, $class, $object_name); +- isa_ok($ref, $type, $ref_name); +- +-Checks to see if the given C<< $object->isa($class) >>. Also checks to make +-sure the object was defined in the first place. Handy for this sort +-of thing: +- +- my $obj = Some::Module->new; +- isa_ok( $obj, 'Some::Module' ); +- +-where you'd otherwise have to write +- +- my $obj = Some::Module->new; +- ok( defined $obj && $obj->isa('Some::Module') ); +- +-to safeguard against your test script blowing up. +- +-It works on references, too: +- +- isa_ok( $array_ref, 'ARRAY' ); +- +-The diagnostics of this test normally just refer to 'the object'. If +-you'd like them to be more specific, you can supply an $object_name +-(for example 'Test customer'). +- +-=cut +- +-sub isa_ok ($$;$) { +- my($object, $class, $obj_name) = @_; +- +- my $diag; +- $obj_name = 'The object' unless defined $obj_name; +- my $name = "$obj_name isa $class"; +- if( !defined $object ) { +- $diag = "$obj_name isn't defined"; +- } +- elsif( !ref $object ) { +- $diag = "$obj_name isn't a reference"; +- } +- else { +- # We can't use UNIVERSAL::isa because we want to honor isa() overrides +- local($@, $!); # eval sometimes resets $! +- my $rslt = eval { $object->isa($class) }; +- if( $@ ) { +- if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { +- if( !UNIVERSAL::isa($object, $class) ) { +- my $ref = ref $object; +- $diag = "$obj_name isn't a '$class' it's a '$ref'"; +- } +- } else { +- die <isa on your object and got some weird error. +-This should never happen. Please contact the author immediately. +-Here's the error. +-$@ +-WHOA +- } +- } +- elsif( !$rslt ) { +- my $ref = ref $object; +- $diag = "$obj_name isn't a '$class' it's a '$ref'"; +- } +- } +- +- +- +- my $ok; +- if( $diag ) { +- $ok = $Test->ok( 0, $name ); +- $Test->diag(" $diag\n"); +- } +- else { +- $ok = $Test->ok( 1, $name ); +- } +- +- return $ok; +-} +- +- +-=item B +- +-=item B +- +- pass($test_name); +- fail($test_name); +- +-Sometimes you just want to say that the tests have passed. Usually +-the case is you've got some complicated condition that is difficult to +-wedge into an ok(). In this case, you can simply use pass() (to +-declare the test ok) or fail (for not ok). They are synonyms for +-ok(1) and ok(0). +- +-Use these very, very, very sparingly. +- +-=cut +- +-sub pass (;$) { +- $Test->ok(1, @_); +-} +- +-sub fail (;$) { +- $Test->ok(0, @_); +-} +- +-=back +- +-=head2 Diagnostics +- +-If you pick the right test function, you'll usually get a good idea of +-what went wrong when it failed. But sometimes it doesn't work out +-that way. So here we have ways for you to write your own diagnostic +-messages which are safer than just C. +- +-=over 4 +- +-=item B +- +- diag(@diagnostic_message); +- +-Prints a diagnostic message which is guaranteed not to interfere with +-test output. Handy for this sort of thing: +- +- ok( grep(/foo/, @users), "There's a foo user" ) or +- diag("Since there's no foo, check that /etc/bar is set up right"); +- +-which would produce: +- +- not ok 42 - There's a foo user +- # Failed test (foo.t at line 52) +- # Since there's no foo, check that /etc/bar is set up right. +- +-You might remember C with the mnemonic C. +- +-All diag()s can be made silent by passing the "no_diag" option to +-Test::More. C 1, 'no_diag'>. This is useful +-if you have diagnostics for personal testing but then wish to make +-them silent for release without commenting out each individual +-statement. +- +-B The exact formatting of the diagnostic output is still +-changing, but it is guaranteed that whatever you throw at it it won't +-interfere with the test. +- +-=cut +- +-sub diag { +- return unless $Show_Diag; +- $Test->diag(@_); +-} +- +- +-=back +- +-=head2 Module tests +- +-You usually want to test if the module you're testing loads ok, rather +-than just vomiting if its load fails. For such purposes we have +-C and C. +- +-=over 4 +- +-=item B +- +- BEGIN { use_ok($module); } +- BEGIN { use_ok($module, @imports); } +- +-These simply use the given $module and test to make sure the load +-happened ok. It's recommended that you run use_ok() inside a BEGIN +-block so its functions are exported at compile-time and prototypes are +-properly honored. +- +-If @imports are given, they are passed through to the use. So this: +- +- BEGIN { use_ok('Some::Module', qw(foo bar)) } +- +-is like doing this: +- +- use Some::Module qw(foo bar); +- +-Version numbers can be checked like so: +- +- # Just like "use Some::Module 1.02" +- BEGIN { use_ok('Some::Module', 1.02) } +- +-Don't try to do this: +- +- BEGIN { +- use_ok('Some::Module'); +- +- ...some code that depends on the use... +- ...happening at compile time... +- } +- +-because the notion of "compile-time" is relative. Instead, you want: +- +- BEGIN { use_ok('Some::Module') } +- BEGIN { ...some code that depends on the use... } +- +- +-=cut +- +-sub use_ok ($;@) { +- my($module, @imports) = @_; +- @imports = () unless @imports; +- +- my($pack,$filename,$line) = caller; +- +- local($@,$!); # eval sometimes interferes with $! +- +- if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { +- # probably a version check. Perl needs to see the bare number +- # for it to work with non-Exporter based modules. +- eval <ok( !$@, "use $module;" ); +- +- unless( $ok ) { +- chomp $@; +- $@ =~ s{^BEGIN failed--compilation aborted at .*$} +- {BEGIN failed--compilation aborted at $filename line $line.}m; +- $Test->diag(< +- +- require_ok($module); +- +-Like use_ok(), except it requires the $module. +- +-=cut +- +-sub require_ok ($) { +- my($module) = shift; +- +- my $pack = caller; +- +- local($!, $@); # eval sometimes interferes with $! +- eval <ok( !$@, "require $module;" ); +- +- unless( $ok ) { +- chomp $@; +- $Test->diag(<. +- +-The way Test::More handles this is with a named block. Basically, a +-block of tests which can be skipped over or made todo. It's best if I +-just show you... +- +-=over 4 +- +-=item B +- +- SKIP: { +- skip $why, $how_many if $condition; +- +- ...normal testing code goes here... +- } +- +-This declares a block of tests that might be skipped, $how_many tests +-there are, $why and under what $condition to skip them. An example is +-the easiest way to illustrate: +- +- SKIP: { +- eval { require HTML::Lint }; +- +- skip "HTML::Lint not installed", 2 if $@; +- +- my $lint = new HTML::Lint; +- isa_ok( $lint, "HTML::Lint" ); +- +- $lint->parse( $html ); +- is( $lint->errors, 0, "No errors found in HTML" ); +- } +- +-If the user does not have HTML::Lint installed, the whole block of +-code I. Test::More will output special ok's +-which Test::Harness interprets as skipped, but passing, tests. +-It's important that $how_many accurately reflects the number of tests +-in the SKIP block so the # of tests run will match up with your plan. +- +-It's perfectly safe to nest SKIP blocks. Each SKIP block must have +-the label C, or Test::More can't work its magic. +- +-You don't skip tests which are failing because there's a bug in your +-program, or for which you don't yet have code written. For that you +-use TODO. Read on. +- +-=cut +- +-#'# +-sub skip { +- my($why, $how_many) = @_; +- +- unless( defined $how_many ) { +- # $how_many can only be avoided when no_plan is in use. +- _carp "skip() needs to know \$how_many tests are in the block" +- unless $Test::Builder::No_Plan; +- $how_many = 1; +- } +- +- for( 1..$how_many ) { +- $Test->skip($why); +- } +- +- local $^W = 0; +- last SKIP; +-} +- +- +-=item B +- +- TODO: { +- local $TODO = $why if $condition; +- +- ...normal testing code goes here... +- } +- +-Declares a block of tests you expect to fail and $why. Perhaps it's +-because you haven't fixed a bug or haven't finished a new feature: +- +- TODO: { +- local $TODO = "URI::Geller not finished"; +- +- my $card = "Eight of clubs"; +- is( URI::Geller->your_card, $card, 'Is THIS your card?' ); +- +- my $spoon; +- URI::Geller->bend_spoon; +- is( $spoon, 'bent', "Spoon bending, that's original" ); +- } +- +-With a todo block, the tests inside are expected to fail. Test::More +-will run the tests normally, but print out special flags indicating +-they are "todo". Test::Harness will interpret failures as being ok. +-Should anything succeed, it will report it as an unexpected success. +-You then know the thing you had todo is done and can remove the +-TODO flag. +- +-The nice part about todo tests, as opposed to simply commenting out a +-block of tests, is it's like having a programmatic todo list. You know +-how much work is left to be done, you're aware of what bugs there are, +-and you'll know immediately when they're fixed. +- +-Once a todo test starts succeeding, simply move it outside the block. +-When the block is empty, delete it. +- +-B: TODO tests require a Test::Harness upgrade else it will +-treat it as a normal failure. See L) +- +- +-=item B +- +- TODO: { +- todo_skip $why, $how_many if $condition; +- +- ...normal testing code... +- } +- +-With todo tests, it's best to have the tests actually run. That way +-you'll know when they start passing. Sometimes this isn't possible. +-Often a failing test will cause the whole program to die or hang, even +-inside an C with and using C. In these extreme +-cases you have no choice but to skip over the broken tests entirely. +- +-The syntax and behavior is similar to a C except the +-tests will be marked as failing but todo. Test::Harness will +-interpret them as passing. +- +-=cut +- +-sub todo_skip { +- my($why, $how_many) = @_; +- +- unless( defined $how_many ) { +- # $how_many can only be avoided when no_plan is in use. +- _carp "todo_skip() needs to know \$how_many tests are in the block" +- unless $Test::Builder::No_Plan; +- $how_many = 1; +- } +- +- for( 1..$how_many ) { +- $Test->todo_skip($why); +- } +- +- local $^W = 0; +- last TODO; +-} +- +-=item When do I use SKIP vs. TODO? +- +-B, use SKIP. +-This includes optional modules that aren't installed, running under +-an OS that doesn't have some feature (like fork() or symlinks), or maybe +-you need an Internet connection and one isn't available. +- +-B, use TODO. This +-is for any code you haven't written yet, or bugs you have yet to fix, +-but want to put tests in your testing script (always a good idea). +- +- +-=back +- +-=head2 Comparison functions +- +-Not everything is a simple eq check or regex. There are times you +-need to see if two arrays are equivalent, for instance. For these +-instances, Test::More provides a handful of useful functions. +- +-B These are NOT well-tested on circular references. Nor am I +-quite sure what will happen with filehandles. +- +-=over 4 +- +-=item B +- +- is_deeply( $this, $that, $test_name ); +- +-Similar to is(), except that if $this and $that are hash or array +-references, it does a deep comparison walking each data structure to +-see if they are equivalent. If the two structures are different, it +-will display the place where they start differing. +- +-Test::Differences and Test::Deep provide more in-depth functionality +-along these lines. +- +-=cut +- +-use vars qw(@Data_Stack); +-my $DNE = bless [], 'Does::Not::Exist'; +-sub is_deeply { +- unless( @_ == 2 or @_ == 3 ) { +- my $msg = <is_eq($this, $that, $name); +- } +- else { +- local @Data_Stack = (); +- if( _deep_check($this, $that) ) { +- $ok = $Test->ok(1, $name); +- } +- else { +- $ok = $Test->ok(0, $name); +- $ok = $Test->diag(_format_stack(@Data_Stack)); +- } +- } +- +- return $ok; +-} +- +-sub _format_stack { +- my(@Stack) = @_; +- +- my $var = '$FOO'; +- my $did_arrow = 0; +- foreach my $entry (@Stack) { +- my $type = $entry->{type} || ''; +- my $idx = $entry->{'idx'}; +- if( $type eq 'HASH' ) { +- $var .= "->" unless $did_arrow++; +- $var .= "{$idx}"; +- } +- elsif( $type eq 'ARRAY' ) { +- $var .= "->" unless $did_arrow++; +- $var .= "[$idx]"; +- } +- elsif( $type eq 'REF' ) { +- $var = "\${$var}"; +- } +- } +- +- my @vals = @{$Stack[-1]{vals}}[0,1]; +- my @vars = (); +- ($vars[0] = $var) =~ s/\$FOO/ \$got/; +- ($vars[1] = $var) =~ s/\$FOO/\$expected/; +- +- my $out = "Structures begin differing at:\n"; +- foreach my $idx (0..$#vals) { +- my $val = $vals[$idx]; +- $vals[$idx] = !defined $val ? 'undef' : +- $val eq $DNE ? "Does not exist" +- : "'$val'"; +- } +- +- $out .= "$vars[0] = $vals[0]\n"; +- $out .= "$vars[1] = $vals[1]\n"; +- +- $out =~ s/^/ /msg; +- return $out; +-} +- +- +-=item B +- +- eq_array(\@this, \@that); +- +-Checks if two arrays are equivalent. This is a deep check, so +-multi-level structures are handled correctly. +- +-=cut +- +-#'# +-sub eq_array { +- my($a1, $a2) = @_; +- return 1 if $a1 eq $a2; +- +- my $ok = 1; +- my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; +- for (0..$max) { +- my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; +- my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; +- +- push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; +- $ok = _deep_check($e1,$e2); +- pop @Data_Stack if $ok; +- +- last unless $ok; +- } +- return $ok; +-} +- +-sub _deep_check { +- my($e1, $e2) = @_; +- my $ok = 0; +- +- my $eq; +- { +- # Quiet uninitialized value warnings when comparing undefs. +- local $^W = 0; +- +- if( $e1 eq $e2 ) { +- $ok = 1; +- } +- else { +- if( UNIVERSAL::isa($e1, 'ARRAY') and +- UNIVERSAL::isa($e2, 'ARRAY') ) +- { +- $ok = eq_array($e1, $e2); +- } +- elsif( UNIVERSAL::isa($e1, 'HASH') and +- UNIVERSAL::isa($e2, 'HASH') ) +- { +- $ok = eq_hash($e1, $e2); +- } +- elsif( UNIVERSAL::isa($e1, 'REF') and +- UNIVERSAL::isa($e2, 'REF') ) +- { +- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; +- $ok = _deep_check($$e1, $$e2); +- pop @Data_Stack if $ok; +- } +- elsif( UNIVERSAL::isa($e1, 'SCALAR') and +- UNIVERSAL::isa($e2, 'SCALAR') ) +- { +- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; +- $ok = _deep_check($$e1, $$e2); +- } +- else { +- push @Data_Stack, { vals => [$e1, $e2] }; +- $ok = 0; +- } +- } +- } +- +- return $ok; +-} +- +- +-=item B +- +- eq_hash(\%this, \%that); +- +-Determines if the two hashes contain the same keys and values. This +-is a deep check. +- +-=cut +- +-sub eq_hash { +- my($a1, $a2) = @_; +- return 1 if $a1 eq $a2; +- +- my $ok = 1; +- my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; +- foreach my $k (keys %$bigger) { +- my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; +- my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; +- +- push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; +- $ok = _deep_check($e1, $e2); +- pop @Data_Stack if $ok; +- +- last unless $ok; +- } +- +- return $ok; +-} +- +-=item B +- +- eq_set(\@this, \@that); +- +-Similar to eq_array(), except the order of the elements is B +-important. This is a deep check, but the irrelevancy of order only +-applies to the top level. +- +-B By historical accident, this is not a true set comparision. +-While the order of elements does not matter, duplicate elements do. +- +-=cut +- +-# We must make sure that references are treated neutrally. It really +-# doesn't matter how we sort them, as long as both arrays are sorted +-# with the same algorithm. +-sub _bogus_sort { local $^W = 0; ref $a ? -1 : ref $b ? 1 : $a cmp $b } +- +-sub eq_set { +- my($a1, $a2) = @_; +- return 0 unless @$a1 == @$a2; +- +- # There's faster ways to do this, but this is easiest. +- return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); +-} +- +-=back +- +- +-=head2 Extending and Embedding Test::More +- +-Sometimes the Test::More interface isn't quite enough. Fortunately, +-Test::More is built on top of Test::Builder which provides a single, +-unified backend for any test library to use. This means two test +-libraries which both use Test::Builder B. +- +-If you simply want to do a little tweaking of how the tests behave, +-you can access the underlying Test::Builder object like so: +- +-=over 4 +- +-=item B +- +- my $test_builder = Test::More->builder; +- +-Returns the Test::Builder object underlying Test::More for you to play +-with. +- +-=cut +- +-sub builder { +- return Test::Builder->new; +-} +- +-=back +- +- +-=head1 EXIT CODES +- +-If all your tests passed, Test::Builder will exit with zero (which is +-normal). If anything failed it will exit with how many failed. If +-you run less (or more) tests than you planned, the missing (or extras) +-will be considered failures. If no tests were ever run Test::Builder +-will throw a warning and exit with 255. If the test died, even after +-having successfully completed all its tests, it will still be +-considered a failure and will exit with 255. +- +-So the exit codes are... +- +- 0 all tests successful +- 255 test died +- any other number how many failed (including missing or extras) +- +-If you fail more than 254 tests, it will be reported as 254. +- +- +-=head1 NOTES +- +-Test::More is B tested all the way back to perl 5.004. +- +-=head1 BUGS and CAVEATS +- +-=over 4 +- +-=item Threads +- +-Test::More will only be aware of threads if "use threads" has been done +-I Test::More is loaded. This is ok: +- +- use threads; +- use Test::More; +- +-This may cause problems: +- +- use Test::More +- use threads; +- +-=item Making your own ok() +- +-If you are trying to extend Test::More, don't. Use Test::Builder +-instead. +- +-=item The eq_* family has some caveats. +- +-=item Test::Harness upgrade +- +-no_plan and todo depend on new Test::Harness features and fixes. If +-you're going to distribute tests that use no_plan or todo your +-end-users will have to upgrade Test::Harness to the latest one on +-CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness +-will work fine. +- +-Installing Test::More should also upgrade Test::Harness. +- +-=back +- +- +-=head1 HISTORY +- +-This is a case of convergent evolution with Joshua Pritikin's Test +-module. I was largely unaware of its existence when I'd first +-written my own ok() routines. This module exists because I can't +-figure out how to easily wedge test names into Test's interface (along +-with a few other problems). +- +-The goal here is to have a testing utility that's simple to learn, +-quick to use and difficult to trip yourself up with while still +-providing more flexibility than the existing Test.pm. As such, the +-names of the most common routines are kept tiny, special cases and +-magic side-effects are kept to a minimum. WYSIWYG. +- +- +-=head1 SEE ALSO +- +-L if all this confuses you and you just want to write +-some tests. You can upgrade to Test::More later (it's forward +-compatible). +- +-L is the old testing module. Its main benefit is that it has +-been distributed with Perl since 5.004_05. +- +-L for details on how your test results are interpreted +-by Perl. +- +-L for more ways to test complex data structures. +-And it plays well with Test::More. +- +-L is like XUnit but more perlish. +- +-L gives you more powerful complex data structure testing. +- +-L is XUnit style testing. +- +-L shows the idea of embedded testing. +- +-L installs a whole bunch of useful test modules. +- +- +-=head1 AUTHORS +- +-Michael G Schwern Eschwern@pobox.comE with much inspiration +-from Joshua Pritikin's Test module and lots of help from Barrie +-Slaymaker, Tony Bowden, blackstar.co.uk, chromatic and the perl-qa gang. +- +- +-=head1 COPYRIGHT +- +-Copyright 2001, 2002 by Michael G Schwern Eschwern@pobox.comE. +- +-This program is free software; you can redistribute it and/or +-modify it under the same terms as Perl itself. +- +-See F +- +-=cut +- +-1; +diff -ruN PathTools-3.47/t/lib/Test/Simple.pm PathTools-core/t/lib/Test/Simple.pm +--- PathTools-3.47/t/lib/Test/Simple.pm 2011-12-20 08:15:58.000000000 +0100 ++++ PathTools-core/t/lib/Test/Simple.pm 1970-01-01 01:00:00.000000000 +0100 +@@ -1,235 +0,0 @@ +-package Test::Simple; +- +-use 5.004; +- +-use strict 'vars'; +-use vars qw($VERSION); +-$VERSION = '0.49'; +- +- +-use Test::Builder; +-my $Test = Test::Builder->new; +- +-sub import { +- my $self = shift; +- my $caller = caller; +- *{$caller.'::ok'} = \&ok; +- +- $Test->exported_to($caller); +- $Test->plan(@_); +-} +- +- +-=head1 NAME +- +-Test::Simple - Basic utilities for writing tests. +- +-=head1 SYNOPSIS +- +- use Test::Simple tests => 1; +- +- ok( $foo eq $bar, 'foo is bar' ); +- +- +-=head1 DESCRIPTION +- +-** If you are unfamiliar with testing B first! ** +- +-This is an extremely simple, extremely basic module for writing tests +-suitable for CPAN modules and other pursuits. If you wish to do more +-complicated testing, use the Test::More module (a drop-in replacement +-for this one). +- +-The basic unit of Perl testing is the ok. For each thing you want to +-test your program will print out an "ok" or "not ok" to indicate pass +-or fail. You do this with the ok() function (see below). +- +-The only other constraint is you must pre-declare how many tests you +-plan to run. This is in case something goes horribly wrong during the +-test and your test program aborts, or skips a test or whatever. You +-do this like so: +- +- use Test::Simple tests => 23; +- +-You must have a plan. +- +- +-=over 4 +- +-=item B +- +- ok( $foo eq $bar, $name ); +- ok( $foo eq $bar ); +- +-ok() is given an expression (in this case C<$foo eq $bar>). If it's +-true, the test passed. If it's false, it didn't. That's about it. +- +-ok() prints out either "ok" or "not ok" along with a test number (it +-keeps track of that for you). +- +- # This produces "ok 1 - Hell not yet frozen over" (or not ok) +- ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); +- +-If you provide a $name, that will be printed along with the "ok/not +-ok" to make it easier to find your test when if fails (just search for +-the name). It also makes it easier for the next guy to understand +-what your test is for. It's highly recommended you use test names. +- +-All tests are run in scalar context. So this: +- +- ok( @stuff, 'I have some stuff' ); +- +-will do what you mean (fail if stuff is empty) +- +-=cut +- +-sub ok ($;$) { +- $Test->ok(@_); +-} +- +- +-=back +- +-Test::Simple will start by printing number of tests run in the form +-"1..M" (so "1..5" means you're going to run 5 tests). This strange +-format lets Test::Harness know how many tests you plan on running in +-case something goes horribly wrong. +- +-If all your tests passed, Test::Simple will exit with zero (which is +-normal). If anything failed it will exit with how many failed. If +-you run less (or more) tests than you planned, the missing (or extras) +-will be considered failures. If no tests were ever run Test::Simple +-will throw a warning and exit with 255. If the test died, even after +-having successfully completed all its tests, it will still be +-considered a failure and will exit with 255. +- +-So the exit codes are... +- +- 0 all tests successful +- 255 test died +- any other number how many failed (including missing or extras) +- +-If you fail more than 254 tests, it will be reported as 254. +- +-This module is by no means trying to be a complete testing system. +-It's just to get you started. Once you're off the ground its +-recommended you look at L. +- +- +-=head1 EXAMPLE +- +-Here's an example of a simple .t file for the fictional Film module. +- +- use Test::Simple tests => 5; +- +- use Film; # What you're testing. +- +- my $btaste = Film->new({ Title => 'Bad Taste', +- Director => 'Peter Jackson', +- Rating => 'R', +- NumExplodingSheep => 1 +- }); +- ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); +- +- ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); +- ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); +- ok( $btaste->Rating eq 'R', 'Rating() get' ); +- ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); +- +-It will produce output like this: +- +- 1..5 +- ok 1 - new() works +- ok 2 - Title() get +- ok 3 - Director() get +- not ok 4 - Rating() get +- # Failed test (t/film.t at line 14) +- ok 5 - NumExplodingSheep() get +- # Looks like you failed 1 tests of 5 +- +-Indicating the Film::Rating() method is broken. +- +- +-=head1 CAVEATS +- +-Test::Simple will only report a maximum of 254 failures in its exit +-code. If this is a problem, you probably have a huge test script. +-Split it into multiple files. (Otherwise blame the Unix folks for +-using an unsigned short integer as the exit status). +- +-Because VMS's exit codes are much, much different than the rest of the +-universe, and perl does horrible mangling to them that gets in my way, +-it works like this on VMS. +- +- 0 SS$_NORMAL all tests successful +- 4 SS$_ABORT something went wrong +- +-Unfortunately, I can't differentiate any further. +- +- +-=head1 NOTES +- +-Test::Simple is B tested all the way back to perl 5.004. +- +-Test::Simple is thread-safe in perl 5.8.0 and up. +- +-=head1 HISTORY +- +-This module was conceived while talking with Tony Bowden in his +-kitchen one night about the problems I was having writing some really +-complicated feature into the new Testing module. He observed that the +-main problem is not dealing with these edge cases but that people hate +-to write tests B. What was needed was a dead simple module +-that took all the hard work out of testing and was really, really easy +-to learn. Paul Johnson simultaneously had this idea (unfortunately, +-he wasn't in Tony's kitchen). This is it. +- +- +-=head1 SEE ALSO +- +-=over 4 +- +-=item L +- +-More testing functions! Once you outgrow Test::Simple, look at +-Test::More. Test::Simple is 100% forward compatible with Test::More +-(i.e. you can just use Test::More instead of Test::Simple in your +-programs and things will still work). +- +-=item L +- +-The original Perl testing module. +- +-=item L +- +-Elaborate unit testing. +- +-=item L, L +- +-Embed tests in your code! +- +-=item L +- +-Interprets the output of your test program. +- +-=back +- +- +-=head1 AUTHORS +- +-Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +-Eschwern@pobox.comE, wardrobe by Calvin Klein. +- +- +-=head1 COPYRIGHT +- +-Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. +- +-This program is free software; you can redistribute it and/or +-modify it under the same terms as Perl itself. +- +-See F +- +-=cut +- +-1; +diff -ruN PathTools-3.47/t/lib/Test/Tutorial.pod PathTools-core/t/lib/Test/Tutorial.pod +--- PathTools-3.47/t/lib/Test/Tutorial.pod 2011-12-20 08:15:58.000000000 +0100 ++++ PathTools-core/t/lib/Test/Tutorial.pod 1970-01-01 01:00:00.000000000 +0100 +@@ -1,603 +0,0 @@ +-=head1 NAME +- +-Test::Tutorial - A tutorial about writing really basic tests +- +-=head1 DESCRIPTION +- +- +-I +- +-I<*sob*> +- +-I +- +- +-Is this you? Is writing tests right up there with writing +-documentation and having your fingernails pulled out? Did you open up +-a test and read +- +- ######## We start with some black magic +- +-and decide that's quite enough for you? +- +-It's ok. That's all gone now. We've done all the black magic for +-you. And here are the tricks... +- +- +-=head2 Nuts and bolts of testing. +- +-Here's the most basic test program. +- +- #!/usr/bin/perl -w +- +- print "1..1\n"; +- +- print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n"; +- +-since 1 + 1 is 2, it prints: +- +- 1..1 +- ok 1 +- +-What this says is: C<1..1> "I'm going to run one test." [1] C +-"The first test passed". And that's about all magic there is to +-testing. Your basic unit of testing is the I. For each thing you +-test, an C is printed. Simple. B interprets your test +-results to determine if you succeeded or failed (more on that later). +- +-Writing all these print statements rapidly gets tedious. Fortunately, +-there's B. It has one function, C. +- +- #!/usr/bin/perl -w +- +- use Test::Simple tests => 1; +- +- ok( 1 + 1 == 2 ); +- +-and that does the same thing as the code above. C is the backbone +-of Perl testing, and we'll be using it instead of roll-your-own from +-here on. If C gets a true value, the test passes. False, it +-fails. +- +- #!/usr/bin/perl -w +- +- use Test::Simple tests => 2; +- ok( 1 + 1 == 2 ); +- ok( 2 + 2 == 5 ); +- +-from that comes +- +- 1..2 +- ok 1 +- not ok 2 +- # Failed test (test.pl at line 5) +- # Looks like you failed 1 tests of 2. +- +-C<1..2> "I'm going to run two tests." This number is used to ensure +-your test program ran all the way through and didn't die or skip some +-tests. C "The first test passed." C "The second test +-failed". Test::Simple helpfully prints out some extra commentary about +-your tests. +- +-It's not scary. Come, hold my hand. We're going to give an example +-of testing a module. For our example, we'll be testing a date +-library, B. It's on CPAN, so download a copy and follow +-along. [2] +- +- +-=head2 Where to start? +- +-This is the hardest part of testing, where do you start? People often +-get overwhelmed at the apparent enormity of the task of testing a +-whole module. Best place to start is at the beginning. Date::ICal is +-an object-oriented module, and that means you start by making an +-object. So we test C. +- +- #!/usr/bin/perl -w +- +- use Test::Simple tests => 2; +- +- use Date::ICal; +- +- my $ical = Date::ICal->new; # create an object +- ok( defined $ical ); # check that we got something +- ok( $ical->isa('Date::ICal') ); # and it's the right class +- +-run that and you should get: +- +- 1..2 +- ok 1 +- ok 2 +- +-congratulations, you've written your first useful test. +- +- +-=head2 Names +- +-That output isn't terribly descriptive, is it? When you have two +-tests you can figure out which one is #2, but what if you have 102? +- +-Each test can be given a little descriptive name as the second +-argument to C. +- +- use Test::Simple tests => 2; +- +- ok( defined $ical, 'new() returned something' ); +- ok( $ical->isa('Date::ICal'), " and it's the right class" ); +- +-So now you'd see... +- +- 1..2 +- ok 1 - new() returned something +- ok 2 - and it's the right class +- +- +-=head2 Test the manual +- +-Simplest way to build up a decent testing suite is to just test what +-the manual says it does. [3] Let's pull something out of the +-L and test that all its bits work. +- +- #!/usr/bin/perl -w +- +- use Test::Simple tests => 8; +- +- use Date::ICal; +- +- $ical = Date::ICal->new( year => 1964, month => 10, day => 16, +- hour => 16, min => 12, sec => 47, +- tz => '0530' ); +- +- ok( defined $ical, 'new() returned something' ); +- ok( $ical->isa('Date::ICal'), " and it's the right class" ); +- ok( $ical->sec == 47, ' sec()' ); +- ok( $ical->min == 12, ' min()' ); +- ok( $ical->hour == 16, ' hour()' ); +- ok( $ical->day == 17, ' day()' ); +- ok( $ical->month == 10, ' month()' ); +- ok( $ical->year == 1964, ' year()' ); +- +-run that and you get: +- +- 1..8 +- ok 1 - new() returned something +- ok 2 - and it's the right class +- ok 3 - sec() +- ok 4 - min() +- ok 5 - hour() +- not ok 6 - day() +- # Failed test (- at line 16) +- ok 7 - month() +- ok 8 - year() +- # Looks like you failed 1 tests of 8. +- +-Whoops, a failure! [4] Test::Simple helpfully lets us know on what line +-the failure occured, but not much else. We were supposed to get 17, +-but we didn't. What did we get?? Dunno. We'll have to re-run the +-test in the debugger or throw in some print statements to find out. +- +-Instead, we'll switch from B to B. B +-does everything B does, and more! In fact, Test::More does +-things I the way Test::Simple does. You can literally swap +-Test::Simple out and put Test::More in its place. That's just what +-we're going to do. +- +-Test::More does more than Test::Simple. The most important difference +-at this point is it provides more informative ways to say "ok". +-Although you can write almost any test with a generic C, it +-can't tell you what went wrong. Instead, we'll use the C +-function, which lets us declare that something is supposed to be the +-same as something else: +- +- #!/usr/bin/perl -w +- +- use Test::More tests => 8; +- +- use Date::ICal; +- +- $ical = Date::ICal->new( year => 1964, month => 10, day => 16, +- hour => 16, min => 12, sec => 47, +- tz => '0530' ); +- +- ok( defined $ical, 'new() returned something' ); +- ok( $ical->isa('Date::ICal'), " and it's the right class" ); +- is( $ical->sec, 47, ' sec()' ); +- is( $ical->min, 12, ' min()' ); +- is( $ical->hour, 16, ' hour()' ); +- is( $ical->day, 17, ' day()' ); +- is( $ical->month, 10, ' month()' ); +- is( $ical->year, 1964, ' year()' ); +- +-"Is C<$ical-Esec> 47?" "Is C<$ical-Emin> 12?" With C in place, +-you get some more information +- +- 1..8 +- ok 1 - new() returned something +- ok 2 - and it's the right class +- ok 3 - sec() +- ok 4 - min() +- ok 5 - hour() +- not ok 6 - day() +- # Failed test (- at line 16) +- # got: '16' +- # expected: '17' +- ok 7 - month() +- ok 8 - year() +- # Looks like you failed 1 tests of 8. +- +-letting us know that C<$ical-Eday> returned 16, but we expected 17. A +-quick check shows that the code is working fine, we made a mistake +-when writing up the tests. Just change it to: +- +- is( $ical->day, 16, ' day()' ); +- +-and everything works. +- +-So any time you're doing a "this equals that" sort of test, use C. +-It even works on arrays. The test is always in scalar context, so you +-can test how many elements are in a list this way. [5] +- +- is( @foo, 5, 'foo has 5 elements' ); +- +- +-=head2 Sometimes the tests are wrong +- +-Which brings us to a very important lesson. Code has bugs. Tests are +-code. Ergo, tests have bugs. A failing test could mean a bug in the +-code, but don't discount the possibility that the test is wrong. +- +-On the flip side, don't be tempted to prematurely declare a test +-incorrect just because you're having trouble finding the bug. +-Invalidating a test isn't something to be taken lightly, and don't use +-it as a cop out to avoid work. +- +- +-=head2 Testing lots of values +- +-We're going to be wanting to test a lot of dates here, trying to trick +-the code with lots of different edge cases. Does it work before 1970? +-After 2038? Before 1904? Do years after 10,000 give it trouble? +-Does it get leap years right? We could keep repeating the code above, +-or we could set up a little try/expect loop. +- +- use Test::More tests => 32; +- use Date::ICal; +- +- my %ICal_Dates = ( +- # An ICal string And the year, month, date +- # hour, minute and second we expect. +- '19971024T120000' => # from the docs. +- [ 1997, 10, 24, 12, 0, 0 ], +- '20390123T232832' => # after the Unix epoch +- [ 2039, 1, 23, 23, 28, 32 ], +- '19671225T000000' => # before the Unix epoch +- [ 1967, 12, 25, 0, 0, 0 ], +- '18990505T232323' => # before the MacOS epoch +- [ 1899, 5, 5, 23, 23, 23 ], +- ); +- +- +- while( my($ical_str, $expect) = each %ICal_Dates ) { +- my $ical = Date::ICal->new( ical => $ical_str ); +- +- ok( defined $ical, "new(ical => '$ical_str')" ); +- ok( $ical->isa('Date::ICal'), " and it's the right class" ); +- +- is( $ical->year, $expect->[0], ' year()' ); +- is( $ical->month, $expect->[1], ' month()' ); +- is( $ical->day, $expect->[2], ' day()' ); +- is( $ical->hour, $expect->[3], ' hour()' ); +- is( $ical->min, $expect->[4], ' min()' ); +- is( $ical->sec, $expect->[5], ' sec()' ); +- } +- +-So now we can test bunches of dates by just adding them to +-C<%ICal_Dates>. Now that it's less work to test with more dates, you'll +-be inclined to just throw more in as you think of them. +-Only problem is, every time we add to that we have to keep adjusting +-the C ##> line. That can rapidly get +-annoying. There's two ways to make this work better. +- +-First, we can calculate the plan dynamically using the C +-function. +- +- use Test::More; +- use Date::ICal; +- +- my %ICal_Dates = ( +- ...same as before... +- ); +- +- # For each key in the hash we're running 8 tests. +- plan tests => keys %ICal_Dates * 8; +- +-Or to be even more flexible, we use C. This means we're just +-running some tests, don't know how many. [6] +- +- use Test::More 'no_plan'; # instead of tests => 32 +- +-now we can just add tests and not have to do all sorts of math to +-figure out how many we're running. +- +- +-=head2 Informative names +- +-Take a look at this line here +- +- ok( defined $ical, "new(ical => '$ical_str')" ); +- +-we've added more detail about what we're testing and the ICal string +-itself we're trying out to the name. So you get results like: +- +- ok 25 - new(ical => '19971024T120000') +- ok 26 - and it's the right class +- ok 27 - year() +- ok 28 - month() +- ok 29 - day() +- ok 30 - hour() +- ok 31 - min() +- ok 32 - sec() +- +-if something in there fails, you'll know which one it was and that +-will make tracking down the problem easier. So try to put a bit of +-debugging information into the test names. +- +-Describe what the tests test, to make debugging a failed test easier +-for you or for the next person who runs your test. +- +- +-=head2 Skipping tests +- +-Poking around in the existing Date::ICal tests, I found this in +-F [7] +- +- #!/usr/bin/perl -w +- +- use Test::More tests => 7; +- use Date::ICal; +- +- # Make sure epoch time is being handled sanely. +- my $t1 = Date::ICal->new( epoch => 0 ); +- is( $t1->epoch, 0, "Epoch time of 0" ); +- +- # XXX This will only work on unix systems. +- is( $t1->ical, '19700101Z', " epoch to ical" ); +- +- is( $t1->year, 1970, " year()" ); +- is( $t1->month, 1, " month()" ); +- is( $t1->day, 1, " day()" ); +- +- # like the tests above, but starting with ical instead of epoch +- my $t2 = Date::ICal->new( ical => '19700101Z' ); +- is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); +- +- is( $t2->epoch, 0, " and back to ICal" ); +- +-The beginning of the epoch is different on most non-Unix operating +-systems [8]. Even though Perl smooths out the differences for the most +-part, certain ports do it differently. MacPerl is one off the top of +-my head. [9] We I this will never work on MacOS. So rather than +-just putting a comment in the test, we can explicitly say it's never +-going to work and skip the test. +- +- use Test::More tests => 7; +- use Date::ICal; +- +- # Make sure epoch time is being handled sanely. +- my $t1 = Date::ICal->new( epoch => 0 ); +- is( $t1->epoch, 0, "Epoch time of 0" ); +- +- SKIP: { +- skip('epoch to ICal not working on MacOS', 6) +- if $^O eq 'MacOS'; +- +- is( $t1->ical, '19700101Z', " epoch to ical" ); +- +- is( $t1->year, 1970, " year()" ); +- is( $t1->month, 1, " month()" ); +- is( $t1->day, 1, " day()" ); +- +- # like the tests above, but starting with ical instead of epoch +- my $t2 = Date::ICal->new( ical => '19700101Z' ); +- is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); +- +- is( $t2->epoch, 0, " and back to ICal" ); +- } +- +-A little bit of magic happens here. When running on anything but +-MacOS, all the tests run normally. But when on MacOS, C causes +-the entire contents of the SKIP block to be jumped over. It's never +-run. Instead, it prints special output that tells Test::Harness that +-the tests have been skipped. +- +- 1..7 +- ok 1 - Epoch time of 0 +- ok 2 # skip epoch to ICal not working on MacOS +- ok 3 # skip epoch to ICal not working on MacOS +- ok 4 # skip epoch to ICal not working on MacOS +- ok 5 # skip epoch to ICal not working on MacOS +- ok 6 # skip epoch to ICal not working on MacOS +- ok 7 # skip epoch to ICal not working on MacOS +- +-This means your tests won't fail on MacOS. This means less emails +-from MacPerl users telling you about failing tests that you know will +-never work. You've got to be careful with skip tests. These are for +-tests which don't work and I. It is not for skipping +-genuine bugs (we'll get to that in a moment). +- +-The tests are wholly and completely skipped. [10] This will work. +- +- SKIP: { +- skip("I don't wanna die!"); +- +- die, die, die, die, die; +- } +- +- +-=head2 Todo tests +- +-Thumbing through the Date::ICal man page, I came across this: +- +- ical +- +- $ical_string = $ical->ical; +- +- Retrieves, or sets, the date on the object, using any +- valid ICal date/time string. +- +-"Retrieves or sets". Hmmm, didn't see a test for using C to set +-the date in the Date::ICal test suite. So I'll write one. +- +- use Test::More tests => 1; +- use Date::ICal; +- +- my $ical = Date::ICal->new; +- $ical->ical('20201231Z'); +- is( $ical->ical, '20201231Z', 'Setting via ical()' ); +- +-run that and I get +- +- 1..1 +- not ok 1 - Setting via ical() +- # Failed test (- at line 6) +- # got: '20010814T233649Z' +- # expected: '20201231Z' +- # Looks like you failed 1 tests of 1. +- +-Whoops! Looks like it's unimplemented. Let's assume we don't have +-the time to fix this. [11] Normally, you'd just comment out the test +-and put a note in a todo list somewhere. Instead, we're going to +-explicitly state "this test will fail" by wrapping it in a C block. +- +- use Test::More tests => 1; +- +- TODO: { +- local $TODO = 'ical($ical) not yet implemented'; +- +- my $ical = Date::ICal->new; +- $ical->ical('20201231Z'); +- +- is( $ical->ical, '20201231Z', 'Setting via ical()' ); +- } +- +-Now when you run, it's a little different: +- +- 1..1 +- not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented +- # got: '20010822T201551Z' +- # expected: '20201231Z' +- +-Test::More doesn't say "Looks like you failed 1 tests of 1". That '# +-TODO' tells Test::Harness "this is supposed to fail" and it treats a +-failure as a successful test. So you can write tests even before +-you've fixed the underlying code. +- +-If a TODO test passes, Test::Harness will report it "UNEXPECTEDLY +-SUCCEEDED". When that happens, you simply remove the TODO block with +-C and turn it into a real test. +- +- +-=head2 Testing with taint mode. +- +-Taint mode is a funny thing. It's the globalest of all global +-features. Once you turn it on, it affects I code in your program +-and I modules used (and all the modules they use). If a single +-piece of code isn't taint clean, the whole thing explodes. With that +-in mind, it's very important to ensure your module works under taint +-mode. +- +-It's very simple to have your tests run under taint mode. Just throw +-a C<-T> into the C<#!> line. Test::Harness will read the switches +-in C<#!> and use them to run your tests. +- +- #!/usr/bin/perl -Tw +- +- ...test normally here... +- +-So when you say C it will be run with taint mode and +-warnings on. +- +- +-=head1 FOOTNOTES +- +-=over 4 +- +-=item 1 +- +-The first number doesn't really mean anything, but it has to be 1. +-It's the second number that's important. +- +-=item 2 +- +-For those following along at home, I'm using version 1.31. It has +-some bugs, which is good -- we'll uncover them with our tests. +- +-=item 3 +- +-You can actually take this one step further and test the manual +-itself. Have a look at B (formerly B). +- +-=item 4 +- +-Yes, there's a mistake in the test suite. What! Me, contrived? +- +-=item 5 +- +-We'll get to testing the contents of lists later. +- +-=item 6 +- +-But what happens if your test program dies halfway through?! Since we +-didn't say how many tests we're going to run, how can we know it +-failed? No problem, Test::More employs some magic to catch that death +-and turn the test into a failure, even if every test passed up to that +-point. +- +-=item 7 +- +-I cleaned it up a little. +- +-=item 8 +- +-Most Operating Systems record time as the number of seconds since a +-certain date. This date is the beginning of the epoch. Unix's starts +-at midnight January 1st, 1970 GMT. +- +-=item 9 +- +-MacOS's epoch is midnight January 1st, 1904. VMS's is midnight, +-November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a +-problem. +- +-=item 10 +- +-As long as the code inside the SKIP block at least compiles. Please +-don't ask how. No, it's not a filter. +- +-=item 11 +- +-Do NOT be tempted to use TODO tests as a way to avoid fixing simple +-bugs! +- +-=back +- +-=head1 AUTHORS +- +-Michael G Schwern Eschwern@pobox.comE and the perl-qa dancers! +- +-=head1 COPYRIGHT +- +-Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. +- +-This documentation is free; you can redistribute it and/or modify it +-under the same terms as Perl itself. +- +-Irrespective of its distribution, all code examples in these files +-are hereby placed into the public domain. You are permitted and +-encouraged to use this code in your own programs for fun +-or for profit as you see fit. A simple comment in the code giving +-credit would be courteous but is not required. +- +-=cut +diff -ruN PathTools-3.47/t/rel2abs_vs_symlink.t PathTools-core/t/rel2abs_vs_symlink.t +--- PathTools-3.47/t/rel2abs_vs_symlink.t 2011-12-20 08:15:58.000000000 +0100 ++++ PathTools-core/t/rel2abs_vs_symlink.t 1970-01-01 01:00:00.000000000 +0100 +@@ -1,37 +0,0 @@ +-#!/usr/bin/perl -w +- +-# Test that rel2abs() works correctly when the process is under a symlink +-# See [rt.cpan.org 47637] +- +-use strict; +- +-use File::Path; +-use File::Spec; +- +-# Do this to simulate already being inside a symlinked directory +-# and having $ENV{PWD} set. +-use Cwd qw(chdir); +- +-use Test::More; +- +-plan skip_all => "needs symlink()" if !eval { symlink("", ""); 1 }; +- +-plan tests => 1; +- +-my $real_dir = "for_rel2abs_test"; +-my $symlink = "link_for_rel2abs_test"; +-mkdir $real_dir or die "Can't make $real_dir: $!"; +-END { rmtree $real_dir } +- +-symlink $real_dir, $symlink or die "Can't symlink $real_dir => $symlink: $!"; +-END { unlink $symlink } +- +-chdir $symlink or die "Can't chdir into $symlink: $!"; +- +-TODO: { +- local $TODO = 'Need to find a way to make cwd work reliably under symlinks"'; +- like( File::Spec->rel2abs("."), qr/$symlink/ ); +-} +- +-# So the unlinking works +-chdir ".."; diff --git a/perl-PathTools.spec b/perl-PathTools.spec index 295f2c2..f05b7a7 100644 --- a/perl-PathTools.spec +++ b/perl-PathTools.spec @@ -1,14 +1,16 @@ -%global cpan_version 3.47 +%global base_version 3.47 Name: perl-PathTools -Version: %(echo '%{cpan_version}' | tr _ .) -Release: 311%{?dist} +Version: 3.56 +Release: 1%{?dist} Summary: PathTools Perl module (Cwd, File::Spec) License: (GPL+ or Artistic) and BSD Group: Development/Libraries URL: http://search.cpan.org/dist/PathTools/ -Source0: http://www.cpan.org/authors/id/S/SM/SMUELLER/PathTools-%{cpan_version}.tar.gz +Source0: http://www.cpan.org/authors/id/S/SM/SMUELLER/PathTools-%{base_version}.tar.gz +# Unbundled from perl 5.21.11 +Patch0: PathTools-3.47-Update-to-3.56.patch # Disable VMS test (bug #973713) -Patch0: PathTools-3.47-Disable-VMS-tests.patch +Patch1: PathTools-3.47-Disable-VMS-tests.patch BuildRequires: perl BuildRequires: perl(ExtUtils::MakeMaker) # Run-time: @@ -23,6 +25,7 @@ BuildRequires: perl(vars) BuildRequires: perl(Carp::Heavy) BuildRequires: perl(Config) BuildRequires: perl(File::Path) +BuildRequires: perl(File::Temp) BuildRequires: perl(lib) BuildRequires: perl(Test::More) Requires: perl(:MODULE_COMPAT_%(eval "`perl -V:version`"; echo $version)) @@ -35,11 +38,10 @@ Requires: perl(Scalar::Util) This is the combined distribution for the File::Spec and Cwd modules. %prep -%setup -q -n PathTools-%{cpan_version} +%setup -q -n PathTools-%{base_version} %patch0 -p1 -# Remove bundled modules -rm -r t/lib -sed -i -e '/^t\/lib\//d' MANIFEST +%patch1 -p1 + # Do not distribute File::Spec::VMS as it works on VMS only (bug #973713) rm lib/File/Spec/VMS.pm sed -i -e '/^lib\/File\/Spec\/VMS.pm/d' MANIFEST @@ -65,6 +67,9 @@ make test %{_mandir}/man3/* %changelog +* Mon Apr 27 2015 Jitka Plesnikova - 3.56-1 +- 3.56 bump in order to dual-live with Perl 5.22 + * Tue Jan 13 2015 Petr Pisar - 3.47-311 - Require constant module