jplesnik pushed to perl-PathTools (master). "3.56 bump in order to dual-live with Perl 5.22"
notifications at fedoraproject.org
notifications at fedoraproject.org
Wed May 6 11:56:12 UTC 2015
>From ed79c05d5ffafc27800a54eac3f86c0a5f3d99dc Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik at redhat.com>
Date: Wed, 6 May 2015 13:55:50 +0200
Subject: 3.56 bump in order to dual-live with Perl 5.22
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{(?<!\^)[\[<:]}, @_));
+
+ my($path,$base) = @_;
+ $base = $self->_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{(?<!\^)[\[<:]};
++
++ for ($path, $base) { $_ = $self->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<all> 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<die> 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<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+-functions are all aliases for the C<cwd()> function, which, on Mac OS,
+-calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+-C<fast_abs_path()>.
+-
+-=back
+-
+-=head1 AUTHOR
+-
+-Originally by the perl5-porters.
+-
+-Maintained by Ken Williams <KWILLIAMS at cpan.org>
+-
+-=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<Cwd.xs> for the
+-details.
+-
+-=head1 SEE ALSO
+-
+-L<File::chdir>
+-
+-=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<all> 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<die> 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<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
++functions are all aliases for the C<cwd()> function, which, on Mac OS,
++calls `pwd`. Likewise, the C<abs_path()> function is an alias for
++C<fast_abs_path()>.
++
++=back
++
++=head1 AUTHOR
++
++Originally by the perl5-porters.
++
++Maintained by Ken Williams <KWILLIAMS at cpan.org>
++
++=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<Cwd.xs> for the
++details.
++
++=head1 SEE ALSO
++
++L<File::chdir>
++
++=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 <unistd.h>
+ #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<which can
+-work together>.
+-
+-=head2 Construction
+-
+-=over 4
+-
+-=item B<new>
+-
+- 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<one and only one>
+-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<reset>
+-
+- $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<exported_to>
+-
+- 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<plan>
+-
+- $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<expected_tests>
+-
+- 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<no_plan>
+-
+- $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<has_plan>
+-
+- $plan = $Test->has_plan
+-
+-Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (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<skip_all>
+-
+- $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<ok>
+-
+- $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(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
+- You named your test '$name'. You shouldn't use numbers for your test names.
+- Very confusing.
+-ERR
+-
+- my($pack, $file, $line) = $self->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<is_eq>
+-
+- $Test->is_eq($got, $expected, $name);
+-
+-Like Test::More's is(). Checks if $got eq $expected. This is the
+-string version.
+-
+-=item B<is_num>
+-
+- $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 <<DIAGNOSTIC, $got, $expect);
+- got: %s
+- expected: %s
+-DIAGNOSTIC
+-
+-}
+-
+-=item B<isnt_eq>
+-
+- $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<isnt_num>
+-
+- $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<like>
+-
+- $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<unlike>
+-
+- $Test->unlike($this, qr/$regex/, $name);
+- $Test->unlike($this, '/$regex/', $name);
+-
+-Like Test::More's unlike(). Checks if $this B<does not match> 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<maybe_regex>
+-
+- $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 <<DIAGNOSTIC, $this, $match, $regex);
+- %s
+- %13s '%s'
+-DIAGNOSTIC
+-
+- }
+-
+- return $ok;
+-}
+-
+-=item B<cmp_ok>
+-
+- $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 <<DIAGNOSTIC, $got, $type, $expect);
+- %s
+- %s
+- %s
+-DIAGNOSTIC
+-}
+-
+-=item B<BAILOUT>
+-
+- $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<skip>
+-
+- $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<todo_skip>
+-
+- $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<skip_rest>
+-
+- $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<level>
+-
+- $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<use_numbers>
+-
+- $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<no_header>
+-
+- $Test->no_header($no_header);
+-
+-If set to true, no "1..N" header will be printed.
+-
+-=item B<no_ending>
+-
+- $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<diag>
+-
+- $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<ok() || diag()>) it "passes through" the failure.
+-
+- return ok(...) || diag(...);
+-
+-=for blame transfer
+-Mark Fowler <mark at twoshortplanks.com>
+-
+-=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<output>
+-
+- $Test->output($fh);
+- $Test->output($file);
+-
+-Where normal "ok/not ok" test output should go.
+-
+-Defaults to STDOUT.
+-
+-=item B<failure_output>
+-
+- $Test->failure_output($fh);
+- $Test->failure_output($file);
+-
+-Where diagnostic output on test failures and diag() should go.
+-
+-Defaults to STDERR.
+-
+-=item B<todo_output>
+-
+- $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<current_test>
+-
+- 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<summary>
+-
+- 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<details>
+-
+- 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<todo>
+-
+- 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<caller>
+-
+- 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 <<WHOA;
+-WHOA! $desc
+-This should never happen! Please contact the author immediately!
+-WHOA
+- }
+-}
+-
+-=item B<_my_exit>
+-
+- _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<before>
+-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
+-E<lt>schwern at pobox.comE<gt>
+-
+-=head1 COPYRIGHT
+-
+-Copyright 2002 by chromatic E<lt>chromatic at wgz.orgE<gt>,
+- Michael G Schwern E<lt>schwern at pobox.comE<gt>.
+-
+-This program is free software; you can redistribute it and/or
+-modify it under the same terms as Perl itself.
+-
+-See F<http://www.perl.com/perl/misc/Artistic.html>
+-
+-=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';
+- at ISA = qw(Exporter);
+- at 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<STOP!> 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<ok()> 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>.
+-
+- 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<NOTE>: using no_plan requires a Test::Harness upgrade else it will
+-think everything has failed. See L<BUGS and CAVEATS>)
+-
+-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<Test::Harness> 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>
+-
+- 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<very> 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<is>
+-
+-=item B<isnt>
+-
+- is ( $this, $that, $test_name );
+- isnt( $this, $that, $test_name );
+-
+-Similar to ok(), is() and isnt() compare their two arguments
+-with C<eq> and C<ne> 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<exists $brooklyn{tree}> 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<isn't()>
+-function which is an alias of isnt().
+-
+-=cut
+-
+-sub is ($$;$) {
+- $Test->is_eq(@_);
+-}
+-
+-sub isnt ($$;$) {
+- $Test->isnt_eq(@_);
+-}
+-
+-*isn't = \&isnt;
+-
+-
+-=item B<like>
+-
+- like( $this, qr/that/, $test_name );
+-
+-Similar to ok(), like() matches $this against the regex C<qr/that/>.
+-
+-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<qr//>) 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>
+-
+- unlike( $this, qr/that/, $test_name );
+-
+-Works exactly as like(), only it checks if $this B<does not> match the
+-given pattern.
+-
+-=cut
+-
+-sub unlike ($$;$) {
+- $Test->unlike(@_);
+-}
+-
+-
+-=item B<cmp_ok>
+-
+- 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<eq> will interfere:
+-
+- cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+-
+-=cut
+-
+-sub cmp_ok($$$;$) {
+- $Test->cmp_ok(@_);
+-}
+-
+-
+-=item B<can_ok>
+-
+- 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>
+-
+- 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 <<WHOA;
+-WHOA! I tried to call ->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<pass>
+-
+-=item B<fail>
+-
+- 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<print STDERR>.
+-
+-=over 4
+-
+-=item B<diag>
+-
+- 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<ok() or diag()> with the mnemonic C<open() or
+-die()>.
+-
+-All diag()s can be made silent by passing the "no_diag" option to
+-Test::More. C<use Test::More tests => 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<NOTE> 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<use_ok> and C<require_ok>.
+-
+-=over 4
+-
+-=item B<use_ok>
+-
+- 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 <<USE;
+-package $pack;
+-use $module $imports[0];
+-USE
+- }
+- else {
+- eval <<USE;
+-package $pack;
+-use $module \@imports;
+-USE
+- }
+-
+- my $ok = $Test->ok( !$@, "use $module;" );
+-
+- unless( $ok ) {
+- chomp $@;
+- $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+- {BEGIN failed--compilation aborted at $filename line $line.}m;
+- $Test->diag(<<DIAGNOSTIC);
+- Tried to use '$module'.
+- Error: $@
+-DIAGNOSTIC
+-
+- }
+-
+- return $ok;
+-}
+-
+-=item B<require_ok>
+-
+- 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 <<REQUIRE;
+-package $pack;
+-require $module;
+-REQUIRE
+-
+- my $ok = $Test->ok( !$@, "require $module;" );
+-
+- unless( $ok ) {
+- chomp $@;
+- $Test->diag(<<DIAGNOSTIC);
+- Tried to require '$module'.
+- Error: $@
+-DIAGNOSTIC
+-
+- }
+-
+- return $ok;
+-}
+-
+-=back
+-
+-=head2 Conditional tests
+-
+-Sometimes running a test under certain conditions will cause the
+-test script to die. A certain function or method isn't implemented
+-(such as fork() on MacOS), some resource isn't available (like a
+-net connection) or a module isn't available. In these cases it's
+-necessary to skip tests, or declare that they are supposed to fail
+-but will work in the future (a todo test).
+-
+-For more details on the mechanics of skip and todo tests see
+-L<Test::Harness>.
+-
+-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: BLOCK>
+-
+- 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<won't be run at all>. 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<SKIP>, 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: BLOCK>
+-
+- 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<NOTE>: TODO tests require a Test::Harness upgrade else it will
+-treat it as a normal failure. See L<BUGS and CAVEATS>)
+-
+-
+-=item B<todo_skip>
+-
+- 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<eval BLOCK> with and using C<alarm>. 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<SKIP: BLOCK> 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<If it's something the user might not be able to do>, 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<If it's something the programmer hasn't done yet>, 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<NOTE> These are NOT well-tested on circular references. Nor am I
+-quite sure what will happen with filehandles.
+-
+-=over 4
+-
+-=item B<is_deeply>
+-
+- 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 = <<WARNING;
+-is_deeply() takes two or three args, you gave %d.
+-This usually means you passed an array or hash instead
+-of a reference to it
+-WARNING
+- chop $msg; # clip off newline so carp() will put in line/file
+-
+- _carp sprintf $msg, scalar @_;
+- }
+-
+- my($this, $that, $name) = @_;
+-
+- my $ok;
+- if( !ref $this || !ref $that ) {
+- $ok = $Test->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>
+-
+- 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>
+-
+- 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>
+-
+- eq_set(\@this, \@that);
+-
+-Similar to eq_array(), except the order of the elements is B<not>
+-important. This is a deep check, but the irrelevancy of order only
+-applies to the top level.
+-
+-B<NOTE> 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<can be used together in the
+-same program>.
+-
+-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<builder>
+-
+- 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<explicitly> 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<before> 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<Test::Simple> 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<Test> is the old testing module. Its main benefit is that it has
+-been distributed with Perl since 5.004_05.
+-
+-L<Test::Harness> for details on how your test results are interpreted
+-by Perl.
+-
+-L<Test::Differences> for more ways to test complex data structures.
+-And it plays well with Test::More.
+-
+-L<Test::Class> is like XUnit but more perlish.
+-
+-L<Test::Deep> gives you more powerful complex data structure testing.
+-
+-L<Test::Unit> is XUnit style testing.
+-
+-L<Test::Inline> shows the idea of embedded testing.
+-
+-L<Bundle::Test> installs a whole bunch of useful test modules.
+-
+-
+-=head1 AUTHORS
+-
+-Michael G Schwern E<lt>schwern at pobox.comE<gt> 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 E<lt>schwern at pobox.comE<gt>.
+-
+-This program is free software; you can redistribute it and/or
+-modify it under the same terms as Perl itself.
+-
+-See F<http://www.perl.com/perl/misc/Artistic.html>
+-
+-=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<read Test::Tutorial> 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>
+-
+- 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<Test::More>.
+-
+-
+-=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<explicitly> 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<at all>. 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<Test::More>
+-
+-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<Test>
+-
+-The original Perl testing module.
+-
+-=item L<Test::Unit>
+-
+-Elaborate unit testing.
+-
+-=item L<Test::Inline>, L<SelfTest>
+-
+-Embed tests in your code!
+-
+-=item L<Test::Harness>
+-
+-Interprets the output of your test program.
+-
+-=back
+-
+-
+-=head1 AUTHORS
+-
+-Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+-E<lt>schwern at pobox.comE<gt>, wardrobe by Calvin Klein.
+-
+-
+-=head1 COPYRIGHT
+-
+-Copyright 2001 by Michael G Schwern E<lt>schwern at pobox.comE<gt>.
+-
+-This program is free software; you can redistribute it and/or
+-modify it under the same terms as Perl itself.
+-
+-See F<http://www.perl.com/perl/misc/Artistic.html>
+-
+-=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<AHHHHHHH!!!! NOT TESTING! Anything but testing!
+-Beat me, whip me, send me to Detroit, but don't make
+-me write tests!>
+-
+-I<*sob*>
+-
+-I<Besides, I don't know how to write the damned things.>
+-
+-
+-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<ok 1>
+-"The first test passed". And that's about all magic there is to
+-testing. Your basic unit of testing is the I<ok>. For each thing you
+-test, an C<ok> is printed. Simple. B<Test::Harness> 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<Test::Simple>. It has one function, C<ok()>.
+-
+- #!/usr/bin/perl -w
+-
+- use Test::Simple tests => 1;
+-
+- ok( 1 + 1 == 2 );
+-
+-and that does the same thing as the code above. C<ok()> is the backbone
+-of Perl testing, and we'll be using it instead of roll-your-own from
+-here on. If C<ok()> 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<ok 1> "The first test passed." C<not ok 2> "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<Date::ICal>. 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<new()>.
+-
+- #!/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<ok()>.
+-
+- 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<Date::ICal/SYNOPSIS> 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<Test::Simple> to B<Test::More>. B<Test::More>
+-does everything B<Test::Simple> does, and more! In fact, Test::More does
+-things I<exactly> 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<ok()>, it
+-can't tell you what went wrong. Instead, we'll use the C<is()>
+-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-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> 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-E<gt>day> 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<is()>.
+-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<use Test::More tests =E<gt> ##> 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<plan()>
+-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<no_plan>. 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<t/01sanity.t> [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<know> 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<skip()> 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<never will>. 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<ical()> 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<TODO> 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<local $TODO> 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<all> code in your program
+-and I<all> 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<make test> 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<Test::Inline> (formerly B<Pod::Tests>).
+-
+-=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 E<lt>schwern at pobox.comE<gt> and the perl-qa dancers!
+-
+-=head1 COPYRIGHT
+-
+-Copyright 2001 by Michael G Schwern E<lt>schwern at pobox.comE<gt>.
+-
+-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 <jplesnik at redhat.com> - 3.56-1
+- 3.56 bump in order to dual-live with Perl 5.22
+
* Tue Jan 13 2015 Petr Pisar <ppisar at redhat.com> - 3.47-311
- Require constant module
--
cgit v0.10.2
http://pkgs.fedoraproject.org/cgit/perl-PathTools.git/commit/?h=master&id=ed79c05d5ffafc27800a54eac3f86c0a5f3d99dc
More information about the perl-devel
mailing list