diff options
| author | fukachan <fukachan> | 2018-01-13 08:48:42 +0000 |
|---|---|---|
| committer | fukachan <fukachan> | 2018-01-13 08:48:42 +0000 |
| commit | 28a388f6aeced7f8dd585a84bde0f0ddf0bb7a69 (patch) | |
| tree | 7fbe3b9fc9209113e15e00fbdf9663ff1f16190d | |
| parent | dbab3c94592a2f0ef40175cf39cf89fbe5503c41 (diff) | |
| download | fml8-PathTools-3-62.tar.gz fml8-PathTools-3-62.tar.bz2 fml8-PathTools-3-62.zip | |
import PathTools-3.62PathTools-3-62
45 files changed, 20242 insertions, 478 deletions
diff --git a/cpan/dist/PathTools/Changes b/cpan/dist/PathTools/Changes new file mode 100644 index 00000000..09e977aa --- /dev/null +++ b/cpan/dist/PathTools/Changes @@ -0,0 +1,927 @@ +Revision history for Perl distribution PathTools. + +3.62 - Mon Jan 11 08:39:19 EST 2016 +- ensure File::Spec::canonpath() preserves taint (CVE-2015-8607) + +3.61 - Sun Dec 20 12:00:00 EST 2015 (bleadperl only release) +- improve performance of cwd on Win32 miniperl + +3.60 - Wed Nov 18 21:28:01 EST 2015 +- add File::Spec::AmigaOS -- and actually ship it, this time + +3.59 - Fri Nov 13 18:38:01 EST 2015 +- no changes since 5.58_01 + +3.58_01 - Mon Nov 9 17:35:28 EST 2015 - TRIAL RELEASE +- add File::Spec::AmigaOS +- fix INSTALLDIRS on post-5.10 perls + +3.56_02 - Thu Jul 16 11:28:57 EDT 2015 - TRIAL RELEASE +- fix $VERSION in loaded modules + +3.56_01 - Sat Jul 11 18:07:28 EDT 2015 - TRIAL RELEASE +- CPAN release of the PathTools included in perl v5.22.0 +- support for z/OS sysplexed systems +- long-deprecated "fixpath" and "eliminate_macros" VMS functions removed +- avoid turning leading // into / on cygwin +- Force barename base to be a directory in File::Spec::VMS:abs2rel +- Revise Unix syntax detection File::Spec::VMS::abs2rel +- compiles on Android now +- fewer compiler warnings +- eliminate some runtime perl warnings, too + +3.47 - Fri May 23 18:52:00 2014 +- Improved Android support. +- File::Spec::Unix->tmpdir: Always return an absolute path +- File::Spec now has an XS version for performance. +- QNX and VMS portability +- tmpdir is updated when the environment changes. + +3.40 - Wed Jan 16 07:30:00 2013 +- Stop inadvertently skipping Spec.t on VMS. (Craig Berry) +- Rethink EFS in File::Spec::VMS. (Craig Berry) +- File::Spec::UNIX->abs2rel() gets it wrong with ".." components + [perl #111510] (Volker Schatz) +- Add C define to remove taint support from perl (Steffen Mueller) +- Remove "register" declarations as they are no longer + useful (Karl Williamson) +- Add test for fast_abs_path in LF dir + [perl #115962] (Father Chrysostomos) +- Cwd::fast_abs_path's untaint should allow for multiline + directories (Joel Berger) + +3.39_01 - Tue Dec 20 08:30:00 2011 +- [perl #51562] Problem & "solution" for building 5.10.0 with + win32+mingw+dmake (kmx) +- Fix various compiler warnings from XS code (Zefram) +- Fix typos (spelling errors) (Peter J. Acklam) +- Remove Mac OS classic only tests from Cwd's Spec.t + and special case code from Cwd's cwd.t (Nicholas Clark) +- Convert File::Spec's remaining tests to Test::More from Test + (Nicholas Clark) +- dist/Cwd/lib/File/Spec/Win32.pm: Fix broken link (Karl Williamson) +- In Cwd::_win32_cwd() avoid a string eval when checking if we're + miniperl (Nicholas Clark) +- Add PERL_NO_GET_CONTEXT to Cwd (Nicholas Clark) +- In Cwd.xs on VMS, don't compile bsd_realpath() at all (Nicholas Clark) +- Merge the implementation of Cwd::{fastcwd,getcwd} using + ALIAS (Nicholas Clark) +- In Cwd.xs, swap to defaulting to disabled prototypes (Nicholas Clark) +- Remove duplicate $VERSION handling code, made redundant + in 3.28_01 (Nicholas Clark) +- In Cwd.xs, tidy the conditional code related to symlinks + (Nicholas Clark) +- Keep verbatim pod within 80 cols (Father Chrysostomos) +- [RT #36079] Convert ` to ' in docs (Jim Keenan) +- [rt.cpan.org #45885] File::Spec: Don’t use tainted tmpdir + in 5.6 (Father Chrysostomos) + +3.33 - Mon Sep 20 18:00:00 2010 +- No functional changes since the previous release. +- Fixes POD links + (part of core change2a6dc37471bea77f0c24fd1fe90c598a270c9968, + Florian Ragwitz) + +3.32 - Sun Sep 19 18:00:00 2010 + +- Promote to stable release. + +3.31_03 - Fri Sep 17 20:00:00 2010 + +- Colon delimiter and escaped delimiters for File::Spec::VMS + This is core change 61196b433b2b (Craig A. Berry) + +3.31_02 - Fri Jul 23 20:00:00 2010 + +- Add TODO test for File::Spec->rel2abs() when under a symlink. +- Make catpath return an empty directory rather than the current + directory if the directory name is empty. This allows catpath + to play nice with non-rooted logical names, as in + catpath('sys$login:', '', 'login.com'); + (Craig A. Berry) +- Fix abs2rel bug in handling a Unix-style input. + (Craig A. Berry) +- Assorted clarification and simplification of the documentation. + (Craig A. Berry) + +3.31 - Sun Nov 1 15:15:00 2009 + +- Do not pack a Build.PL to avoid a circular dependency involving + ExtUtils::CBuilder (PathTools RT #50749) + +3.30_02 - Tue Sep 29 08:17:00 2009 + +- Remove more special logic required for core perl. + +3.30_01 - Mon Sep 21 14:39:00 2009 + +- Merge changes from core perl. + (Mostly changes regarding the lib->ext migration) + +3.30 - Sun May 10 10:55:00 2009 + +- Promote to stable release. + +3.29_01 - Thu May 7 20:22:00 2009 + +- Minor fixes for QNX6. [Sean Boudreau] + +- Update to support VMS in Unix compatible mode and/or file names using + extended character sets. (RT #42154) [John Malmberg] + +- VMS support for Unix and extended file specifications in File::Spec + (RT #42153) [John Malmberg] + +3.29 - Wed Oct 29 20:48:11 2008 + +- Promote to stable release. + +3.28_03 - Mon Oct 27 22:12:11 2008 + +- In Cwd.pm, pass the un-munged $VERSION to XSLoader/DynaLoader, + otherwise development releases fail tests on Win32. + +3.28_02 - Mon Oct 27 20:13:11 2008 + + - Fixed some issues on QNX/NTO related to paths with double + slashes. [Matt Kraai & Nicholas Clark] + +3.28_01 - Fri Jul 25 21:18:11 2008 + + - Fixed and clarified the behavior of splitpath() with a $no_file + argument on VMS. [Craig A. Berry, Peter Edwards] + + - Removed some function prototypes and other Perl::Critic violations. + + - canonpath() and catdir() and catfile() on Win32 now make an + explicit (and unnecessary) copy of their arguments right away, + because apparently if we don't, we sabotage all of Win32dom. [RT + #33675] + + - The Makefile.PL now has 'use 5.005;' to explicitly show what + minimum version of perl we support. [Spotted by Alexandr Ciornii] + +3.2701 - Mon Feb 11 21:43:51 2008 + + - Fixed an edge case for Win32 catdir('C:', 'foo') and catfile('C:', + 'foo.txt') (which the caller's not really supposed to do, that's + what catpath() is for) that changed between versions. Now we're + back to the old behavior, which was to return C:\foo and C:\foo.txt . + [Audrey Tang] + +3.27 - Wed Jan 16 20:20:49 2008 + + - If strlcpy() and strlcat() aren't available on the user's system, + we now use ppport.h to provide them, so our C code works. [Steve + Peters] + + - Upgraded to a newer version of ppport.h [Steve Peters] + +3.26 - Sun Jan 13 21:59:20 2008 + + - case_tolerant() on Cygwin will now avoid a painful death when + Cygwin::mount_flags() isn't defined, as is the case for perl < + 5.10. It will now just return 1, which is what it always did + before it got so smart. [Spotted by Emanuele Zeppieri] + + - abs_path() on Unix(ish) platforms has been upgraded to a much later + version of the underlying C code from BSD. [Michael Schwern] + +3.2501 - Mon Dec 24 20:33:02 2007 + + - Reimplemented abs_path() on VMS to use + VMS::Filespec::vms_realpath() when it's available. [John E. Malmberg] + + - tmpdir() on Cygwin now also looks in $ENV{TMP} and $ENV{TEMP}. + + - case_tolerant() on Cygwin and Win32 now take an optional path + argument, defaulting to the C drive, to check for case tolerance, + because this fact can vary on different volumes. + + - File::Spec on Unix now uses Cwd::getcwd() rather than Cwd::cwd() to + get the current directory because I guess someone on p5p thought it + was more appropriate. + + - Added a large set of File::Spec tests for the Cygwin platform. + + - abs_path() now behaves correctly with symbolic links on VMS. + + - Someone fixed a couple of mysterious edge cases in VMS' canonpath() + and splitdir(). + +3.25_01 - Sat Oct 13 21:13:57 2007 + + - Major fixes on Win32, including a rewrite of catdir(), catfile(), + and canonpath() in terms of a single body of code. [Heinrich Tegethoff] + + - For Win32 and Cygwin, case-tolerance can vary depending on the + volume under scrutiny. When Win32API::File is available, it will + be employed to determine case-sensitivity of the given filesystem + (C: by default), otherwise we still return the default of 1. [Reini + Urban] + + - On Cygwin, we added $ENV{'TMP'} and $ENV{'TEMP'} to the list of + possible places to look for tmpdir() return values. [Reini Urban] + + - Added lots more tests for Cygwin. [Reini Urban] + + - canonpath() with no arguments and canonpath(undef) now consistently + return undef on all platforms. [Spotted by Peter John Edwards] + + - Fixed splitdir('') and splitdir(undef) and splitdir() to return an + empty list on VMS and MacOS, like it does on other platforms. + [Craig A. Berry] + + - All .pm files now have the same $VERSION number, rather than a + hodgepodge of various numbers. + +3.25 - Mon May 21 21:07:26 2007 + + - Added a workaround for auto-vivication-of-function-args Perl bug + (triggered by OS/2-specific code). [Ilya Zakharevich] + + - Sync with a bleadperl change: miniperl can no longer use Win32::* + functions because it cannot load Win32.dll. [Jan Dubois] + + - We only need to load ppport.h when building outside the core, so we + avoid using it when in the core. + +3.24 - Sun Nov 19 22:52:49 2006 + + - Fixed a bug in the $ENV{PWD}-updating of Cwd::chdir() when a + dirhandle is passed in. [Steve Peters] + + - Add perl 5.005 to the list of requirements in the + Build.PL/Makefile.PL/META.yml. + + - Add ExtUtils::CBuilder to the list of build_requires in Build.PL. + + - Improved performance of canonpath() on Unix-ish platforms - on my + OS X laptop it looks like it's about twice as fast. [Ruslan Zakirov] + +3.23 - Wed Oct 11 12:11:25 2006 + + - Yet more Win32 fixes (sigh... seems like I'm fighting a neverending + waterbed...). This time, fixed file_name_is_absolute() to know + what it's doing when the path includes a volume but a relative + path, like C:foo.txt . This bug had impact in rel2abs() on Win32 + too. + +3.22 - Mon Oct 9 21:50:52 2006 + + - Fixed the t/crossplatform.t test on Win32 (and possibly other + volume-aware platforms) now that rel2abs() always adds a drive + letter. [Reported by several parties] + +3.21 - Wed Oct 4 21:16:43 2006 + + - Added a bunch of X<> tags to the File::Spec docs to help + podindex. [Gabor Szabo] + + - On Win32, abs2rel('C:\one\two\t\foo', 't\bar') should return + '..\foo' when the cwd is 'C:\one\two', but it wasn't noticing that + the two relevant volumes were the same so it would return the full + path 'C:\one\two\t\foo'. This is fixed. [Spotted by Alexandr + Ciornii] + + - On Win32, rel2abs() now always adds a volume (drive letter) if the + given path doesn't have a volume (drive letter or UNC volume). + Previously it could return a value that didn't have a volume if the + input was a semi-absolute path like /foo/bar instead of a + fully-absolute path like C:/foo/bar . + +3.19 Tue Jul 11 22:40:26 CDT 2006 + + - When abs2rel() is called with two relative paths + (e.g. abs2rel('foo/bar/baz', 'foo/bar')) the resolution algorithm + needlessly called cwd() (twice!) to turn both arguments into + absolute paths. Now it avoids the cwd() calls with a workaround, + making a big efficiency win when abs2rel() is called + repeatedly. [Brendan O'Dea] + + - Added a build-time dependency on ExtUtils::Install version 1.39 + when on Windows. This is necessary because version 1.39 knows how + to replace an in-use Cwd shared library, but previous versions + don't. [Suggested by Adam Kennedy] + + - Fixed File::Spec::Win32->canonpath('foo/../bar'), which was + returning \bar, and now properly returns just bar. [Spotted by + Heinrich Tegethoff] + +3.18 Thu Apr 27 22:01:38 CDT 2006 + + - Fixed some problems on VMS in which a directory called "0" would be + treated as a second-class citizen. [Peter (Stig) Edwards] + + - Added a couple of regression tests to make sure abs2rel('/foo/bar', + '/') works as expected. [Chia-liang Kao] + + - Added a couple of regression tests to make sure catdir('/', + 'foo/bar') works as expected. [Mark Grimes] + +3.17 Fri Mar 3 16:52:30 CST 2006 + + - The Cygwin version of Cwd::cwd() will croak if given any arguments + (which can happen if, for example, it's called as Cwd->cwd). Since + that croaking is bad, we now wrap the original cwd() in a + subroutine that ignores its arguments. We could skip this wrapping + if a future version of perl changes cygwin.c's cwd() to not barf + when fed an argument. [Jerry D. Hedden] + +3.16 Mon Jan 30 20:48:41 CST 2006 + + - Updated to version 3.06 of ppport.h, which provides backward + compatibility XS layers for older perl versions. + + - Clarify in the docs for File::Spec's abs2rel() and rel2abs() + methods that the cwd() function it discusses is + Cwd::cwd(). [Spotted by Steven Lembark] + + - Apparently the version of File::Path that ships with perl 5.8.5 + (and perhaps others) calls Cwd::getcwd() with an argument (perhaps + as a method?), which causes it to die with a prototyping error. + We've eliminated the prototype by using the "(...)" arglist, since + "PROTOTYPE: DISABLE" for the function didn't seem to work. [Spotted + by Eamon Daly and others] + +3.15 Tue Dec 27 14:17:39 CST 2005 + + - The Cwd::getcwd() function on *nix is now a direct pass-through to + the underlying getcwd() C library function when possible. This is + safer and faster than the previous implementation, which just did + abs_path('.'). The pure-perl version has been kept for cases in + which the XS version can't load, such as when running under + miniperl. [Suggested by Nick Ing-Simmons] + + - When Cwd searches for a 'pwd' executable in the $PATH, we now stop + after we find the first one rather than continuing the search. We + also avoid the $PATH search altogether when a 'pwd' was already + found in a well-known and well-trusted location like /bin or + /usr/bin. [Suggested by Nick Ing-Simmons] + + - On Win32 abs2rel($path, $base) was failing whenever $base is the + root of a volume (such as C:\ or \\share\dir). This has been + fixed. [Reported by Bryan Daimler] + + - In abs2rel() on VMS, we've fixed handling of directory trees so + that the test $file = File::Spec::VMS->abs2rel('[t1.t2.t3]file', + '[t1.t2.t3]') returns 'file' instead of an empty string. [John + E. Malmberg] + + - In canonpath() on VMS, '[]' was totally optimized away instead of + just returning '[]'. Now it's fixed. [John E. Malmberg] + +3.14 Thu Nov 17 18:08:44 CST 2005 + + - canonpath() has some logic in it that avoids collapsing a + //double/slash at the beginning of a pathname on platforms where + that means something special. It used to check the value of $^O + rather than the classname it was called as, which meant that + calling File::Spec::Cygwin->canonpath() didn't act like cygwin + unless you were actually *on* cygwin. Now it does. + + - Fixed a major bug on Cygwin in which catdir() could sometimes + create things that look like //network/paths in cases when it + shouldn't (e.g. catdir("/", "foo", "bar")). + +3.13 Tue Nov 15 23:50:37 CST 2005 + + - Calling tmpdir() on Win32 had the unintended side-effect of storing + some undef values in %INC for the TMPDIR, TEMP, and TMP entries if + they didn't exist already. This is probably a bug in perl itself + (submitted as #37441 on rt.perl.org), which we're now working + around. [Thomas L. Shinnick] + + - Integrated a change from bleadperl - a certain #ifdef in Cwd.xs + needs to apply to WIN32 but not WinCE. [Vadim Konovalov] + + - abs2rel() used to return the empty string when its two arguments + were identical, which made no sense. Now it returns + curdir(). [Spotted by David Golden] + + - The Unix and Win32 implementations of abs2rel() have been unified. + +3.12 Mon Oct 3 22:09:12 CDT 2005 + + - Fixed a testing error on OS/2 in which a drive letter for the root + directory was confusing things. [Ilya Zakharevich] + + - Integrated a patch from bleadperl for fixing path() on + Win32. [Gisle Aas] + +3.11 Sat Aug 27 20:12:55 CDT 2005 + + - Fixed a couple of typos in the documentation for + File::Spec::Mac. [Piotr Fusik] + +3.10 Thu Aug 25 22:24:57 CDT 2005 + + - eliminate_macros() and fixpath() in File::Spec::VMS are now + deprecated, since they are MakeMaker-specific and now live inside + MakeMaker. [Michael Schwern] + + - canonpath() on Win32 now collapses foo/.. (or foo\..) sections + correctly, rather than doing the "misguided" work it was previously + doing. Note that canonpath() on Unix still does NOT collapse these + sections, as doing so would be incorrect. [Michael Schwern] + +3.09 Tue Jun 14 20:36:50 CDT 2005 + + - Added some block delimiters (brackets) in the Perl_getcwd_sv() XS + function, which were necessary to separate the variable + declarations from the statements when HAS_GETCWD is not + defined. [Yves] + + - Apparently the _NT_cwd() routine is never defined externally like I + thought it was, so I simplified the code around it. + + - When cwd() is implemented using the _backtick_pwd() function, it + sometimes could create accidental undef entries in %ENV under perl + 5.6, because local($hash{key}) is somewhat broken. This is now + fixed with an appropriate workaround. [Neil Watkiss] + +3.08 Sat May 28 10:10:29 CDT 2005 + + - Fixed a test failure with fast_abs_path() on Windows - it was + sensitive to the rootdir() change from version 3.07. [Steve Hay] + +3.07 Fri May 6 07:46:45 CDT 2005 + + - Fixed a bug in which the special perl variable $^O would become + tainted under certain versions of perl. [Michael Schwern] + + - File::Spec->rootdir() was returning / on Win32. Now it returns \ . + [Michael Schwern] + + - We now avoid modifying @_ in tmpdir() when it's not strictly + necessary, which reportedly provides a modest performance + boost. [Richard Soderberg] + + - Made a couple of slight changes to the Win32 code so that it works + (or works better) on Symbian OS phones. [Jarkko Hietaniemi] + +3.06 Wed Apr 13 20:47:26 CDT 2005 + + (No changes in functionality) + + - Added a note to the canonpath() docs about why it doesn't collapse + foo/../bar sections. + + - The internal-only function bsd_realpath() in the XS file now uses + normal arg syntax instead of K&R syntax. [Nicholas Clark] + +3.05 Mon Feb 28 07:22:58 CST 2005 + + - Fixed a bug in fast_abs_path() on Win32 in which forward- and + backward-slashes were confusing things. [demerphq] + + - Failure to load the XS code in Cwd is no longer a fatal error + (though failure to compile it is still a fatal error in the build + process). This lets Cwd work under miniperl in the core. [Rafael + Garcia-Suarez] + + - In the t/cwd.t test, don't enforce loading from blib/ if we're + testing in the perl core. [Rafael Garcia-Suarez] + +3.04 Sun Feb 6 17:27:38 CST 2005 + + - For perls older than 5.006, the HAS_GETCWD symbol is not available, + because it wasn't checked for in older Configure scripts when perl + was built. We therefore just ask the user whether the getcwd() C + function is defined on their platform when their perl is old. + Maybe in the future we'll try to automate this. [Reported by + several parties] + + - Remove lib/ppport.h from the distribution, so that MakeMaker + doesn't accidentally pick it up and install it as a lib + file. [Jerry Hedden] + + - Fixed a testing error on VMS that occurred when a user had + read-access to the root of the current volume. [Craig A. Berry] + +3.03 Fri Jan 21 21:44:05 CST 2005 + + - Fixed a testing error if the first file we find in the root + directory is a symlink. [Blair Zajac] + + - Added a test to make sure Cwd.pm is loaded from blib/ during + testing, which seems to be an issue in some people's environments + and makes it awfully hard to debug things on my end. + + - Skip the _perl_abs_path() tests on Cygwin - they don't usually + pass, and this function isn't used there anyway, so I decided not + to push it. Let 'em use `cwd`. + +3.02 Sun Jan 9 19:29:52 CST 2005 + + - Fixed a bug in which Cwd::abs_path() called on a file in the root + directory returned strange results. [Bob Luckin] + + - Straightened out the licensing details for the portion of the Cwd + module that comes from BSD sources. [Hugo van der Sanden] + + - Removed the prototype from _perl_abs_path() and the XS version of + abs_path(), since all they seemed to be doing was causing people + grief, and since some platforms didn't have them anyway. + + - Fixed a testing bug in which sometimes the wrong version of Cwd + (the version already installed on the user's machine) would get + loaded instead of the one we're building & installing. + + - Sometimes getdcwd() returns a lower-case drive letter, so don't + require an upper-case letter in t/win32.t. [Jan Dubois] + + - Fixed a memory leak in getdcwd() on win32. [Steve Hay] + + - Added a copy of ppport.h to the distribution to aid compilation on + older versions of perl. [Suggested by Charlie Root] + + - Don't bother looking for a 'pwd' executable on MSWin32 - there + won't be one, and looking for it can be extremely slow when lots of + disks are mounted. [Several people, including Andrew Burke] + + - Eliminated a multi-argument form of open() that was causing a + syntax error on older versions of perl. [Fixed by Michael Schwern] + + - The bug-fix changes for revision 0.90 of File::Spec somehow were + lost when I merged it into the PathTools distribution. They're + restored now. [Craig A. Berry] + + - File::Spec->canonpath() will now reduce paths like '[d1.-]foo.dat' + down to '[000000]foo.dat' instead of '[]foo.dat' or 'foo.dat'. + This is in better accordance with the native filename syntax + parser. [Craig A. Berry] + + - In order to remove a recursive dependency (PathTools -> Test-Simple + -> Test-Harness -> PathTools), we now include a copy of Test::More in + the distribution. It is only used for testing, it won't be installed + with the rest of the stuff. + + - Removed some 5.6-isms from Cwd in order to get it to build with + older perls like 5.005. + + - abs_path() on Windows was trampling on $ENV{PWD} - fixed. [Spotted + by Neil MacMullen] + + - Added licensing/copyright statements to the POD in each .pm + file. [Spotted by Radoslaw Zielinski] + +3.01 Mon Sep 6 22:28:06 CDT 2004 + + - Removed an unnecessary and confusing dependency on File::Spec from + the Makefile.PL and the Build.PL. + + - Added a 'NAME' entry to the Makefile.PL, because otherwise it won't + even begin to work. [Reported by many] + +3.00 Thu Sep 2 22:15:07 CDT 2004 + + - Merged Cwd and File::Spec into a single PathTools distribution. + This was done because the two modules use each other fairly + extensively, and extracting the common stuff into another + distribution was deemed nigh-impossible. The code in revision 3.00 + of PathTools should be equivalent to the code in Cwd 2.21 and + File::Spec 0.90. + +================================================================== +Prior to revision 3.00, Cwd and File::Spec were maintained as two +separate distributions. The revision history for Cwd is shown here. +The revision history for File::Spec is further below. +================================================================== + +Cwd 2.21 Tue Aug 31 22:50:14 CDT 2004 + + - Removed "NO_META" from the Makefile.PL, since I'm not building the + distribution with MakeMaker anyway. [Rohan Carly] + + - Only test _perl_abs_path() on platforms where it's expected to work + (platforms with '/' as the directory separator). [Craig A. Berry] + +Cwd 2.20 Thu Jul 22 08:23:53 CDT 2004 + + - On some implementations of perl on Win32, a memory leak (or worse?) + occurred when calling getdcwd(). This has been fixed. [PodMaster] + + - Added tests for getdcwd() on Win32. + + - Fixed a problem in the pure-perl implementation _perl_abs_path() + that caused a fatal error when run on plain files. [Nicholas Clark] + To exercise the appropriate test code on platforms that wouldn't + otherwise use _perl_abs_path(), run the tests with $ENV{PERL_CORE} + or $ENV{TEST_PERL_CWD_CODE} set. + +Cwd 2.19 Thu Jul 15 08:32:18 CDT 2004 + + - The abs_path($arg) fix from 2.18 didn't work for VMS, now it's + fixed there. [Craig Berry] + +Cwd 2.18 Thu Jun 24 08:22:57 CDT 2004 + + - Fixed a problem in which abs_path($arg) on some platforms could + only be called on directories, and died when called on files. This + was a problem in the pure-perl implementation _perl_abs_path(). + + - Fixed fast_abs_path($arg) in the same way as abs_path($arg) above. + + - On Win32, a function getdcwd($vol) has been added, which gets the + current working directory of the specified drive/volume. + [Steve Hay] + + - Fixed a problem on perl 5.6.2 when built with the MULTIPLICITY + compile-time flags. [Yitzchak Scott-Thoennes] + + - When looking for a `pwd` system command, we no longer assume the + path separator is ':'. + + - On platforms where cwd() is implemented internally (like Win32), + don't look for a `pwd` command externally. This can greatly speed + up load time. [Stefan Scherer] + + - The pure-perl version of abs_path() now has the same prototype as + the XS version (;$). + +Cwd 2.17 Wed Mar 10 07:55:36 CST 2004 + + - The change in 2.16 created a testing failure when tested from + within a path that contains symlinks (for instance, /tmp -> + /private/tmp). + +Cwd 2.16 Sat Mar 6 17:56:31 CST 2004 + + - For VMS compatibility (and to conform to Cwd's documented + interface), in the regression tests we now compare output results + to an absolute path. [Craig A. Berry] + +Cwd 2.15 Fri Jan 16 08:09:44 CST 2004 + + - Fixed a problem on static perl builds - while creating + Makefile.aperl, it was loading a mismatched version of Cwd from + blib/ . [Reported by Blair Zajac] + +Cwd 2.14 Thu Jan 8 18:51:08 CST 2004 + + - We now use File::Spec->canonpath() and properly-escaped regular + expressions when comparing paths in the regression tests. This + fixes some testing failures in 2.13 on non-Unix platforms. No + changes were made in the actual Cwd module code. [Steve Hay] + +Cwd 2.13 Fri Jan 2 22:29:42 CST 2004 + + - Changed a '//' comment to a '/* */' comment in the XS code, so that + it'll compile properly under ANSI C rules. [Jarkko Hietaniemi] + + - Fixed a 1-character buffer overrun problem in the C code. [The BSD + people] + +Cwd 2.12 Fri Dec 19 17:04:52 CST 2003 + + - Fixed a bug on Cygwin - the output of realpath() should have been + tainted, but wasn't. [Reported by Tom Wyant] + +Cwd 2.10 Mon Dec 15 07:50:12 CST 2003 + + (Note that this release was mistakenly packaged as version 2.11, even + though it had an internal $VERSION variable of 2.10. Not sure how + THAT happened...) + + - There was a dependency in the Makefile.PL on Module::Build, which + isn't necessary. I've removed it. + +Cwd 2.09 Thu Dec 11 20:30:58 CST 2003 + + - The module should now build & install using version 5.6 of perl. + + - We now note a build-time dependency on version 0.19 of + Module::Build, which is necessary because we don't use the standard + lib/-based file layout. No version of Module::Build is required if + you use the Makefile.PL, just if you use the Build.PL . + + - Removed some gratuitous uses of 5.6-isms like our(), with the aim + of backporting this module to perl 5.005. + + - Simplified all code that autoloads Carp.pm and calls + carp()/croak(). + + - Removed some redundant OS/2 code at the suggestion of Michael + Schwern and Ilya Zakharevich. + + - Make sure the correct version of Cwd.pm is loaded in the regression + tests. [Sam Vilain] + +Cwd 2.08 Wed Oct 15 20:56 CDT 2003 + + - Code extracted from perl 5.8.1 and packaged as a separate CPAN + release by Ken Williams. + +================================================================== +Prior to revision 3.00, Cwd and File::Spec were maintained as two +separate distributions. The revision history for File::Spec is shown +here. The revision history for Cwd is above. +================================================================== + +File::Spec 0.90 Tue Aug 31 22:34:50 CDT 2004 + + - On VMS, directories use vmspath() and files use vmsify(), so + rel2abs() has to use some 'educated guessing' when dealing with + paths containing slashes. [Craig A. Berry] + +File::Spec 0.89 Sun Aug 29 19:02:32 CDT 2004 + + - Fixed some pathological cases on VMS which broke canonpath() and + splitdir(). [Richard Levitte and Craig A. Berry] + + - Fixed rel2abs() on VMS when passed a unix-style relative + path. [Craig A. Berry] + +File::Spec 0.88 Thu Jul 22 23:14:32 CDT 2004 + + - rel2abs() on Win32 will now use the new Cwd::getdcwd() function, so + that things like rel2abs('D:foo.txt') work properly when the + current drive isn't 'D'. This requires Cwd version 2.18. + [Steve Hay] + + - Got rid of a redundant double-backslash in a character + class. [Alexander Farber] + + - Added much markup to pod for enhanced readability. [Andy Lester] + +File::Spec 0.87 Fri Dec 19 08:03:28 CST 2003 + + - With a one-line change in the tests, backported to perl 5.004. + [Issue reported by Barry Kemble] + +File::Spec 0.86 Fri Sep 26 10:07:39 CDT 2003 + + - This is the version released with perl 5.8.1. It is identical to + the code in the File::Spec beta 0.85_03. + +File::Spec 0.85_03 Mon Sep 15 09:35:53 CDT 2003 + + - On VMS, if catpath() receives volume specifiers in both its first + two arguments, it will now use the volume in the first argument + only. Previously it returned a non-syntactical result which + included both volumes. This change is the same in spirit to the + catpath() MacOS change from version 0.85_02. + + - Fixed an abs2rel() bug on VMS - previously + abs2rel('[t1.t2.t3]file','[t1.t2]') returned '[t3]file', now it + properly returns '[.t3]file'. + +File::Spec 0.85_02 Fri Sep 12 17:11:13 CDT 2003 + + - abs2rel() now behaves more consistently across platforms with the + notion of a volume. If the volumes of the first and second + argument (the second argument may be implicit) do not agree, we do + not attempt to reconcile the paths, and simply return the first + argument. Previously the volume of the second argument was + (usually) ignored, resulting in sometimes-garbage output. + + - catpath() on MacOS now looks for a volume element (i.e. "Macintosh HD:") + in its first argument, and then its second argument. The first + volume found will be used, and if none is found, none will be used. + + - Fixed a problem in abs2rel() on Win32 in which the volume of the + current working directory would get added to the second argument if + none was specified. This might have been somewhat helpful, but it + was contrary to the documented behavior. For example, + abs2rel('C:/foo/bar', '/foo') used to return 'bar', now it returns + 'C:/foo/bar' because there's no guarantee /foo is actually C:/foo . + + - catdir('/', '../') on OS2 previously erroneously returned '//..', + and now it returns '/'. + +File::Spec 0.85_01 Thu Sep 11 16:18:54 CDT 2003 + + Working toward 0.86, the version that will be released with perl 5.8.1. + + - The t/rel2abs2rel.t test now is a little friendlier about emitting + its diagnostic debugging output. [Jarkko Hietaniemi] + + - We now only require() Cwd when it's needed, on demand. [Michael + Schwern, Tels] + + - Fixed some POD errors and redundancies in OS2.pm and Cygwin.pm. + [Michael Schwern] + + - The internal method cwd() has been renamed to _cwd(), since it was + never meant for public use. [Michael Schwern] + + - Several methods in File::Spec::Unix that just return constant + strings have been sped up. catdir() has also been sped up there. + [Tels] + + - Several canonpath() and catdir() bugs on Win32 have been fixed, and + tests added for them: + catdir('/', '../') -> '\\' (was '\..') + catdir('/', '..\\') -> '\\ (was '') + canonpath('\\../') -> '\\' (was '') + canonpath('\\..\\') -> '\\' (was '') + canonpath('/../') -> '\\' (was '\..') + canonpath('/..\\') -> '\\' (was '') + catdir('\\', 'foo') -> '\foo' (was '\\foo') + + - catpath($volume, $dirs, $file) on Mac OS now ignores any volume + that might be part of $dirs, enabling catpath($volume, + catdir(rootdir(), 'foo'), '') to work portably across platforms. + +File::Spec 0.85 Tue Jul 22 11:31 CDT 2003 + + A bug-fix release relative to 0.84. I've forked development into a + "stable" branch (this one) and a more aggressive branch (as yet + unreleased), with an eye toward getting the stable features in perl + 5.8.1. + + - File::Spec::Mac->case_tolerant() returned 0 when it should have + returned 1. + + - Many cases in File::Spec::Win32->abs2rel() were broken, because of + the way in which volumes were/weren't ignored. Unfortunately, part + of the regression tests were broken too. Now, if the $path + argument to abs2rel() is on a different volume than the $base + argument, the result will be an absolute path rather than the + broken relative path previous versions returned. + + - Fixed a problem in File::Spec::Win32->canonpath, which was turning + \../foo into "foo" rather than \foo + + - Greatly simplified the code in File::Spec::Unix->splitdir(). + +File::Spec 0.84_01 Fri Jul 11 16:14:29 CDT 2003 + + No actual code changes, just changes in other distribution files + + - Dependencies are now listed explicitly in the Makefile.PL and + Build.PL scripts, as well as in the META.yml file. + + - The t/abs2rel2abs.t test should now be more friendly about skipping + on platforms where it can't run properly. + +File::Spec 0.84 Wed Jul 9 22:21:23 CDT 2003 + + I (Ken)'ve taken the changes from bleadperl and created a new CPAN release + from them, since they're pretty important changes. The highlights, + from what I can tell, are listed here. + + - A huge number of changes to File::Spec::Mac in order to bring it in + line with the other platforms. This work was mostly/completely + done by Thomas Wegner. + + - The Epoc and Cygwin platforms are now supported. + + - Lots of generically-applicable documentation has been taken from + File::Spec::Unix and put in File::Spec. + + - A Build.PL has been provided for people who wish to install via + Module::Build. + + - Some spurious warnings and errors in the tests have been + eliminated. [Michael Schwern] + + - canonpath() on File::Spec::Unix now honors a //node-name at the + beginning of a path. + + - Cwd.pm wasn't being loaded properly on MacOS. [Chris Nandor] + + - Various POD fixups + + - Several testing patches for the Epoc and Cygwin platforms [Tels] + + - When running under taint mode and perl >= 5.8, all the tmpdir() + implementations now avoid returning a tainted path. + + - File::Spec::OS2 now implements canonpath(), splitpath(), + splitdir(), catpath(), abs2rel(), and rel2abs() directly rather + than inheriting them from File::Spec::Unix. + + - Added 'SYS:/temp' and 'C:/temp' to the list of possible tmpdir()s + on Win32. + + - catfile() on Win32 and VMS will now automatically call canonpath() + on its final argument. + + - canonpath() on Win32 now does a much more extensive cleanup of the + path. + + - abs2rel() on Win32 now defaults to using cwd() as the base of + relativity when no base is given. + + - abs2rel() on Win32 now explicitly ignores any volume component in + the $path argument. + + - canonpath() on VMS now does []foo ==> foo, and foo.000000] ==> foo]. + It also fixes a bug in multiple [000000.foo ==> [foo translations. + + - tmpdir() on VMS now uses 'sys$scratch:' instead of 'sys$scratch'. + + - abs2rel() on VMS now uses '000000' in both the path and the base. + +File::Spec 0.82 Wed Jun 28 11:24:05 EDT 2000 + - Mac.pm: file_name_is_absolute( '' ) now returns TRUE on all platforms + - Spec.pm: unbreak C<$VERSION = '0.xx'> to be C<$VERSION = 0.xx>, so + underscores can be used when I want to update CPAN without anyone + needing to update the perl repository. + - abs2rel, rel2abs doc tweaks + - VMS.pm: get $path =~ /\s/ checks from perl repository. + - Makefile.PL: added INSTALLDIRS => 'perl', since these are std. modules. + - Remove vestigial context prototypes from &rel2abs until some future + arrives where method prototypes are honored. diff --git a/cpan/dist/PathTools/Cwd.pm b/cpan/dist/PathTools/Cwd.pm new file mode 100644 index 00000000..9b5183e3 --- /dev/null +++ b/cpan/dist/PathTools/Cwd.pm @@ -0,0 +1,869 @@ +package Cwd; +use strict; +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + +$VERSION = '3.62'; +my $xs_version = $VERSION; +$VERSION =~ tr/_//d; + +@ISA = qw/ Exporter /; +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); + +# sys_cwd may keep the builtin command + +# All the functionality of this module may provided by builtins, +# there is no sense to process the rest of the file. +# The best choice may be to have this in BEGIN, but how to return from BEGIN? + +if ($^O eq 'os2') { + local $^W = 0; + + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + + *fast_abs_path = \&sys_abspath if defined &sys_abspath; + *abs_path = \&fast_abs_path; + *realpath = \&fast_abs_path; + *fast_realpath = \&fast_abs_path; + + return 1; +} + +# Need to look up the feature settings on VMS. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. + +my $use_vms_feature; +BEGIN { + if ($^O eq 'VMS') { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_vms_feature = 1; + } + } +} + +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _vms_unix_rpt { + my $unix_rpt; + if ($use_vms_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + } + return $unix_rpt; +} + +# Need to look up the EFS character set mode. This may become a dynamic +# mode in the future. +sub _vms_efs { + my $efs; + if ($use_vms_feature) { + $efs = VMS::Feature::current("efs_charset"); + } else { + my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; + $efs = $env_efs =~ /^[ET1]/i; + } + return $efs; +} + + +# If loading the XS stuff doesn't work, we can fall back to pure perl +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); + } else { + require DynaLoader; + push @ISA, 'DynaLoader'; + __PACKAGE__->bootstrap( $xs_version ); + } + }; +} + +# Big nasty table of function aliases +my %METHOD_MAP = + ( + VMS => + { + cwd => '_vms_cwd', + getcwd => '_vms_cwd', + fastcwd => '_vms_cwd', + fastgetcwd => '_vms_cwd', + abs_path => '_vms_abs_path', + fast_abs_path => '_vms_abs_path', + }, + + MSWin32 => + { + # We assume that &_NT_cwd is defined as an XSUB or in the core. + cwd => '_NT_cwd', + getcwd => '_NT_cwd', + fastcwd => '_NT_cwd', + fastgetcwd => '_NT_cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + dos => + { + cwd => '_dos_cwd', + getcwd => '_dos_cwd', + fastgetcwd => '_dos_cwd', + fastcwd => '_dos_cwd', + abs_path => 'fast_abs_path', + }, + + # QNX4. QNX6 has a $os of 'nto'. + qnx => + { + cwd => '_qnx_cwd', + getcwd => '_qnx_cwd', + fastgetcwd => '_qnx_cwd', + fastcwd => '_qnx_cwd', + abs_path => '_qnx_abs_path', + fast_abs_path => '_qnx_abs_path', + }, + + cygwin => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + epoc => + { + cwd => '_epoc_cwd', + getcwd => '_epoc_cwd', + fastgetcwd => '_epoc_cwd', + fastcwd => '_epoc_cwd', + abs_path => 'fast_abs_path', + }, + + MacOS => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + }, + + amigaos => + { + getcwd => '_backtick_pwd', + fastgetcwd => '_backtick_pwd', + fastcwd => '_backtick_pwd', + abs_path => 'fast_abs_path', + } + ); + +$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; + + +# Find the pwd command in the expected locations. We assume these +# are safe. This prevents _backtick_pwd() consulting $ENV{PATH} +# so everything works under taint mode. +my $pwd_cmd; +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; + } + } +} + +# Android has a built-in pwd. Using $pwd_cmd will DTRT if +# this perl was compiled with -Dd_useshellcmds, which is the +# default for Android, but the block below is needed for the +# miniperl running on the host when cross-compiling, and +# potentially for native builds with -Ud_useshellcmds. +if ($^O =~ /android/) { + # If targetsh is executable, then we're either a full + # perl, or a miniperl for a native build. + if (-x $Config::Config{targetsh}) { + $pwd_cmd = "$Config::Config{targetsh} -c pwd" + } + else { + my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh'); + $pwd_cmd = "$sh -c pwd" + } +} + +my $found_pwd_cmd = defined($pwd_cmd); +unless ($pwd_cmd) { + # Isn't this wrong? _backtick_pwd() will fail if someone has + # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? + # See [perl #16774]. --jhi + $pwd_cmd = 'pwd'; +} + +# Lazy-load Carp +sub _carp { require Carp; Carp::carp(@_) } +sub _croak { require Carp; Carp::croak(@_) } + +# The 'natural and safe form' for UNIX (pwd may be setuid root) +sub _backtick_pwd { + + # Localize %ENV entries in a way that won't create new hash keys. + # Under AmigaOS we don't want to localize as it stops perl from + # finding 'sh' in the PATH. + my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos"; + local @ENV{@localize} if @localize; + + my $cwd = `$pwd_cmd`; + # Belt-and-suspenders in case someone said "undef $/". + local $/ = "\n"; + # `pwd` may fail e.g. if the disk is full + chomp($cwd) if defined $cwd; + $cwd; +} + +# Since some ports may predefine cwd internally (e.g., NT) +# we take care not to override an existing definition for cwd(). + +unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { + # The pwd command is not available in some chroot(2)'ed environments + my $sep = $Config::Config{path_sep} || ':'; + my $os = $^O; # Protect $^O from tainting + + + # Try again to find a pwd, this time searching the whole PATH. + if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows + my @candidates = split($sep, $ENV{PATH}); + while (!$found_pwd_cmd and @candidates) { + my $candidate = shift @candidates; + $found_pwd_cmd = 1 if -x "$candidate/pwd"; + } + } + + # MacOS has some special magic to make `pwd` work. + if( $os eq 'MacOS' || $found_pwd_cmd ) + { + *cwd = \&_backtick_pwd; + } + else { + *cwd = \&getcwd; + } +} + +if ($^O eq 'cygwin') { + # We need to make sure cwd() is called with no args, because it's + # got an arg-less prototype and will die if args are present. + local $^W = 0; + my $orig_cwd = \&cwd; + *cwd = sub { &$orig_cwd() } +} + + +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; + +# A non-XS version of getcwd() - also used to bootstrap the perl build +# process, when miniperl is running and no XS loading happens. +sub _perl_getcwd +{ + abs_path('.'); +} + +# By John Bazik +# +# Usage: $cwd = &fastcwd; +# +# This is a faster version of getcwd. It's also more dangerous because +# you might chdir out of a directory that you can't chdir back into. + +sub fastcwd_ { + my($odev, $oino, $cdev, $cino, $tdev, $tino); + my(@path, $path); + local(*DIR); + + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); + for (;;) { + my $direntry; + ($odev, $oino) = ($cdev, $cino); + CORE::chdir('..') || return undef; + ($cdev, $cino) = stat('.'); + last if $odev == $cdev && $oino == $cino; + opendir(DIR, '.') || return undef; + for (;;) { + $direntry = readdir(DIR); + last unless defined $direntry; + next if $direntry eq '.'; + next if $direntry eq '..'; + + ($tdev, $tino) = lstat($direntry); + last unless $tdev != $odev || $tino != $oino; + } + closedir(DIR); + return undef unless defined $direntry; # should never happen + unshift(@path, $direntry); + } + $path = '/' . join('/', @path); + if ($^O eq 'apollo') { $path = "/".$path; } + # At this point $path may be tainted (if tainting) and chdir would fail. + # Untaint it then check that we landed where we started. + $path =~ /^(.*)\z/s # untaint + && CORE::chdir($1) or return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; + $path; +} +if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } + + +# Keeps track of current working directory in PWD environment var +# Usage: +# use Cwd 'chdir'; +# chdir $newdir; + +my $chdir_init = 0; + +sub chdir_init { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { + my($dd,$di) = stat('.'); + my($pd,$pi) = stat($ENV{'PWD'}); + if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { + $ENV{'PWD'} = cwd(); + } + } + else { + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; + } + # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { + my($pd,$pi) = stat($2); + my($dd,$di) = stat($1); + if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } + } + $chdir_init = 1; +} + +sub chdir { + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) + 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') { + # get the full path name *before* the chdir() + $newpwd = Win32::GetFullPathName($newdir); + } + + return 0 unless CORE::chdir $newdir; + + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MacOS') { + return $ENV{'PWD'} = cwd(); + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = $newpwd; + return 1; + } + + if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in + $ENV{'PWD'} = cwd(); + } elsif ($newdir =~ m#^/#s) { + $ENV{'PWD'} = $newdir; + } else { + my @curdir = split(m#/#,$ENV{'PWD'}); + @curdir = ('') unless @curdir; + my $component; + foreach $component (split(m#/#, $newdir)) { + next if $component eq '.'; + pop(@curdir),next if $component eq '..'; + push(@curdir,$component); + } + $ENV{'PWD'} = join('/',@curdir) || '/'; + } + 1; +} + + +sub _perl_abs_path +{ + my $start = @_ ? shift : '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat( $start )) + { + _carp("stat($start): $!"); + return ''; + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + # NOTE that this routine assumes that '/' is the only directory separator. + + my ($dir, $file) = $start =~ m{^(.*)/(.+)$} + or return cwd() . '/' . $start; + + # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). + if (-l $start) { + my $link_target = readlink($start); + die "Can't resolve link $start: $!" unless defined $link_target; + + require File::Spec; + $link_target = $dir . '/' . $link_target + unless File::Spec->file_name_is_absolute($link_target); + + return abs_path($link_target); + } + + return $dir ? abs_path($dir) . "/$file" : "/$file"; + } + + $cwd = ''; + $dotdots = $start; + do + { + $dotdots .= '/..'; + @pst = @cst; + local *PARENT; + unless (opendir(PARENT, $dotdots)) + { + # probably a permissions issue. Try the native command. + require File::Spec; + return File::Spec->rel2abs( $start, _backtick_pwd() ); + } + unless (@cst = stat($dotdots)) + { + _carp("stat($dotdots): $!"); + closedir(PARENT); + return ''; + } + if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) + { + $dir = undef; + } + else + { + do + { + unless (defined ($dir = readdir(PARENT))) + { + _carp("readdir($dotdots): $!"); + closedir(PARENT); + return ''; + } + $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; + closedir(PARENT); + } while (defined $dir); + chop($cwd) unless $cwd eq '/'; # drop the trailing / + $cwd; +} + + +my $Curdir; +sub fast_abs_path { + local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage + my $cwd = getcwd(); + require File::Spec; + my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); + + # Detaint else we'll explode in taint mode. This is safe because + # we're not doing anything dangerous with it. + ($path) = $path =~ /(.*)/s; + ($cwd) = $cwd =~ /(.*)/s; + + unless (-e $path) { + _croak("$path: No such file or directory"); + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + + my ($vol, $dir, $file) = File::Spec->splitpath($path); + return File::Spec->catfile($cwd, $path) unless length $dir; + + if (-l $path) { + my $link_target = readlink($path); + die "Can't resolve link $path: $!" unless defined $link_target; + + $link_target = File::Spec->catpath($vol, $dir, $link_target) + unless File::Spec->file_name_is_absolute($link_target); + + return fast_abs_path($link_target); + } + + return $dir eq File::Spec->rootdir + ? File::Spec->catpath($vol, $dir, $file) + : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; + } + + if (!CORE::chdir($path)) { + _croak("Cannot chdir to $path: $!"); + } + my $realpath = getcwd(); + if (! ((-d $cwd) && (CORE::chdir($cwd)))) { + _croak("Cannot chdir back to $cwd: $!"); + } + $realpath; +} + +# added function alias to follow principle of least surprise +# based on previous aliasing. --tchrist 27-Jan-00 +*fast_realpath = \&fast_abs_path; + + +# --- PORTING SECTION --- + +# VMS: $ENV{'DEFAULT'} points to default directory at all times +# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu +# Note: Use of Cwd::chdir() causes the logical name PWD to be defined +# in the process logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device +# and directory seen by DCL after Perl exits, since the effects +# the CRTL chdir() function persist only until Perl exits. + +sub _vms_cwd { + return $ENV{'DEFAULT'}; +} + +sub _vms_abs_path { + return $ENV{'DEFAULT'} unless @_; + my $path = shift; + + my $efs = _vms_efs; + my $unix_rpt = _vms_unix_rpt; + + if (defined &VMS::Filespec::vmsrealpath) { + my $path_unix = 0; + my $path_vms = 0; + + $path_unix = 1 if ($path =~ m#(?<=\^)/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + + my $unix_mode = $path_unix; + if ($efs) { + # In case of a tie, the Unix report mode decides. + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = 0 if $path_vms; + } + } + + if ($unix_mode) { + # Unix format + return VMS::Filespec::unixrealpath($path); + } + + # VMS format + + my $new_path = VMS::Filespec::vmsrealpath($path); + + # Perl expects directories to be in directory format + $new_path = VMS::Filespec::pathify($new_path) if -d $path; + return $new_path; + } + + # Fallback to older algorithm if correct ones are not + # available. + + if (-l $path) { + my $link_target = readlink($path); + die "Can't resolve link $path: $!" unless defined $link_target; + + return _vms_abs_path($link_target); + } + + # may need to turn foo.dir into [.foo] + my $pathified = VMS::Filespec::pathify($path); + $path = $pathified if defined $pathified; + + return VMS::Filespec::rmsexpand($path); +} + +sub _os2_cwd { + my $pwd = `cmd /c cd`; + chomp $pwd; + $pwd =~ s:\\:/:g ; + $ENV{'PWD'} = $pwd; + return $pwd; +} + +sub _win32_cwd_simple { + my $pwd = `cd`; + chomp $pwd; + $pwd =~ s:\\:/:g ; + $ENV{'PWD'} = $pwd; + return $pwd; +} + +sub _win32_cwd { + my $pwd; + $pwd = Win32::GetCwd(); + $pwd =~ s:\\:/:g ; + $ENV{'PWD'} = $pwd; + return $pwd; +} + +*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple; + +sub _dos_cwd { + my $pwd; + if (!defined &Dos::GetCwd) { + chomp($pwd = `command /c cd`); + $pwd =~ s:\\:/:g ; + } else { + $pwd = Dos::GetCwd(); + } + $ENV{'PWD'} = $pwd; + return $pwd; +} + +sub _qnx_cwd { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + my $pwd = `/usr/bin/fullpath -t`; + chomp $pwd; + $ENV{'PWD'} = $pwd; + return $pwd; +} + +sub _qnx_abs_path { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + my $path = @_ ? shift : '.'; + local *REALPATH; + + defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or + die "Can't open /usr/bin/fullpath: $!"; + my $realpath = <REALPATH>; + close REALPATH; + chomp $realpath; + return $realpath; +} + +sub _epoc_cwd { + return $ENV{'PWD'} = EPOC::getcwd(); +} + + +# Now that all the base-level functions are set up, alias the +# user-level functions to the right places + +if (exists $METHOD_MAP{$^O}) { + my $map = $METHOD_MAP{$^O}; + foreach my $name (keys %$map) { + local $^W = 0; # assignments trigger 'subroutine redefined' warning + no strict 'refs'; + *{$name} = \&{$map->{$name}}; + } +} + +# In case the XS version doesn't load. +*abs_path = \&_perl_abs_path unless defined &abs_path; +*getcwd = \&_perl_getcwd unless defined &getcwd; + +# added function alias for those of us more +# used to the libc function. --tchrist 27-Jan-00 +*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@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 diff --git a/cpan/dist/PathTools/Cwd.xs b/cpan/dist/PathTools/Cwd.xs new file mode 100644 index 00000000..3d018dc4 --- /dev/null +++ b/cpan/dist/PathTools/Cwd.xs @@ -0,0 +1,784 @@ +/* + * ex: set ts=8 sts=4 sw=4 et: + */ + +#define PERL_NO_GET_CONTEXT + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#define NEED_my_strlcpy +#define NEED_my_strlcat +#include "ppport.h" + +#ifdef I_UNISTD +# 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. + */ + +/* See + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html + * for the details of why the BSD license is compatible with the + * AL/GPL standard perl license. + */ + +/* + * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The names of the authors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +/* OpenBSD system #includes removed since the Perl ones should do. --jhi */ + +#ifndef MAXSYMLINKS +#define MAXSYMLINKS 8 +#endif + +#ifndef VMS +/* + * char *realpath(const char *path, char resolved[MAXPATHLEN]); + * + * Find the real name of path, by removing all ".", ".." and symlink + * components. Returns (resolved) on success, or (NULL) on failure, + * in which case the path which caused trouble is left in (resolved). + */ +static +char * +bsd_realpath(const char *path, char resolved[MAXPATHLEN]) +{ + char *p, *q, *s; + size_t remaining_len, resolved_len; + unsigned symlinks; + int serrno; + 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; + 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); + remaining_len = my_strlcpy(remaining, path, sizeof(remaining)); + } + if (remaining_len >= sizeof(remaining) || resolved_len >= MAXPATHLEN) { + errno = ENAMETOOLONG; + return (NULL); + } + + /* + * Iterate over path components in 'remaining'. + */ + while (remaining_len != 0) { + + /* + * 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'; +# 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 + } + + /* + * Remove trailing slash except when the resolved pathname + * is a single "/". + */ + if (resolved_len > 1 && resolved[resolved_len - 1] == '/') + resolved[resolved_len - 1] = '\0'; + return (resolved); +} +#endif + +#ifndef SV_CWD_RETURN_UNDEF +#define SV_CWD_RETURN_UNDEF \ +sv_setsv(sv, &PL_sv_undef); \ +return FALSE +#endif + +#ifndef OPpENTERSUB_HASTARG +#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */ +#endif + +#ifndef dXSTARG +#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \ + ? PAD_SV(PL_op->op_targ) : sv_newmortal()) +#endif + +#ifndef XSprePUSH +#define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#ifndef SV_CWD_ISDOT +#define SV_CWD_ISDOT(dp) \ + (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) +#endif + +#ifndef getcwd_sv +/* Taken from perl 5.8's util.c */ +#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a) +int Perl_getcwd_sv(pTHX_ SV *sv) +{ +#ifndef PERL_MICRO + + SvTAINTED_on(sv); + +#ifdef HAS_GETCWD + { + char buf[MAXPATHLEN]; + + /* Some getcwd()s automatically allocate a buffer of the given + * size from the heap if they are given a NULL buffer pointer. + * The problem is that this behaviour is not portable. */ + if (getcwd(buf, sizeof(buf) - 1)) { + STRLEN len = strlen(buf); + sv_setpvn(sv, buf, len); + return TRUE; + } + else { + sv_setsv(sv, &PL_sv_undef); + return FALSE; + } + } + +#else + { + Stat_t statbuf; + int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; + int namelen, pathlen=0; + DIR *dir; + Direntry_t *dp; + + (void)SvUPGRADE(sv, SVt_PV); + + if (PerlLIO_lstat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + orig_cdev = statbuf.st_dev; + orig_cino = statbuf.st_ino; + cdev = orig_cdev; + cino = orig_cino; + + for (;;) { + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } + + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } + + if (!dp) { + SV_CWD_RETURN_UNDEF; + } + + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } + + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); + +#ifdef VOID_CLOSEDIR + PerlDir_close(dir); +#else + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } +#endif + } + + if (pathlen) { + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); + + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (cdev != orig_cdev || cino != orig_cino) { + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); + } + + return TRUE; + } +#endif + +#else + return FALSE; +#endif +} + +#endif + +#if defined(START_MY_CXT) && defined(MY_CXT_CLONE) +# define USE_MY_CXT 1 +#else +# define USE_MY_CXT 0 +#endif + +#if USE_MY_CXT +# define MY_CXT_KEY "Cwd::_guts"XS_VERSION +typedef struct { + SV *empty_string_sv, *slash_string_sv; +} my_cxt_t; +START_MY_CXT +# define dUSE_MY_CXT dMY_CXT +# define EMPTY_STRING_SV MY_CXT.empty_string_sv +# define SLASH_STRING_SV MY_CXT.slash_string_sv +# define POPULATE_MY_CXT do { \ + MY_CXT.empty_string_sv = newSVpvs(""); \ + MY_CXT.slash_string_sv = newSVpvs("/"); \ + } while(0) +#else +# define dUSE_MY_CXT dNOOP +# define EMPTY_STRING_SV sv_2mortal(newSVpvs("")) +# define SLASH_STRING_SV sv_2mortal(newSVpvs("/")) +#endif + +#define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i) +static +bool +THX_invocant_is_unix(pTHX_ SV *invocant) +{ + /* + * This is used to enable optimisations that avoid method calls + * by knowing how they would resolve. False negatives, disabling + * the optimisation where it would actually behave correctly, are + * acceptable. + */ + return SvPOK(invocant) && SvCUR(invocant) == 16 && + !memcmp(SvPVX(invocant), "File::Spec::Unix", 16); +} + +#define unix_canonpath(p) THX_unix_canonpath(aTHX_ p) +static +SV * +THX_unix_canonpath(pTHX_ SV *path) +{ + SV *retval; + char const *p, *pe, *q; + STRLEN l; + char *o; + STRLEN plen; + SvGETMAGIC(path); + if(!SvOK(path)) return &PL_sv_undef; + p = SvPV_nomg(path, plen); + if(plen == 0) return newSVpvs(""); + pe = p + plen; + retval = newSV(plen); +#ifdef SvUTF8 + if(SvUTF8(path)) SvUTF8_on(retval); +#endif + o = SvPVX(retval); + if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') { + q = (const char *) memchr(p+2, '/', pe-(p+2)); + if(!q) q = pe; + l = q - p; + memcpy(o, p, l); + p = q; + o += l; + } + /* + * The transformations performed here are: + * . squeeze multiple slashes + * . eliminate "." segments, except one if that's all there is + * . eliminate leading ".." segments + * . eliminate trailing slash, unless it's all there is + */ + if(p[0] == '/') { + *o++ = '/'; + while(1) { + do { p++; } while(p[0] == '/'); + if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) { + p++; + /* advance past second "." next time round loop */ + } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) { + /* advance past "." next time round loop */ + } else { + break; + } + } + } else if(p[0] == '.' && p[1] == '/') { + do { + p++; + do { p++; } while(p[0] == '/'); + } while(p[0] == '.' && p[1] == '/'); + if(p == pe) *o++ = '.'; + } + if(p == pe) goto end; + while(1) { + q = (const char *) memchr(p, '/', pe-p); + if(!q) q = pe; + l = q - p; + memcpy(o, p, l); + p = q; + o += l; + if(p == pe) goto end; + while(1) { + do { p++; } while(p[0] == '/'); + if(p == pe) goto end; + if(p[0] != '.') break; + if(p+1 == pe) goto end; + if(p[1] != '/') break; + p++; + } + *o++ = '/'; + } + end: ; + *o = 0; + SvPOK_on(retval); + SvCUR_set(retval, o - SvPVX(retval)); + SvTAINT(retval); + return retval; +} + +MODULE = Cwd PACKAGE = Cwd + +PROTOTYPES: DISABLE + +BOOT: +#if USE_MY_CXT +{ + MY_CXT_INIT; + POPULATE_MY_CXT; +} +#endif + +#if USE_MY_CXT + +void +CLONE(...) +CODE: + PERL_UNUSED_VAR(items); + { MY_CXT_CLONE; POPULATE_MY_CXT; } + +#endif + +void +getcwd(...) +ALIAS: + fastcwd=1 +PPCODE: +{ + dXSTARG; + /* fastcwd takes zero parameters: */ + if (ix == 1 && items != 0) + croak_xs_usage(cv, ""); + getcwd_sv(TARG); + XSprePUSH; PUSHTARG; + SvTAINTED_on(TARG); +} + +void +abs_path(pathsv=Nullsv) + SV *pathsv +PPCODE: +{ + dXSTARG; + char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)"."; + char buf[MAXPATHLEN]; + + if ( +#ifdef VMS + Perl_rmsexpand(aTHX_ path, buf, NULL, 0) +#else + bsd_realpath(path, buf) +#endif + ) { + sv_setpv_mg(TARG, buf); + SvPOK_only(TARG); + SvTAINTED_on(TARG); + } + else + sv_setsv(TARG, &PL_sv_undef); + + XSprePUSH; PUSHs(TARG); + SvTAINTED_on(TARG); +} + +#if defined(WIN32) && !defined(UNDER_CE) + +void +getdcwd(...) +PROTOTYPE: ENABLE +PPCODE: +{ + dXSTARG; + int drive; + char *dir; + + /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */ + if ( items == 0 || + (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0)))))) + drive = 0; + else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) && + isALPHA(SvPVX(ST(0))[0])) + drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1; + else + croak("Usage: getdcwd(DRIVE)"); + + New(0,dir,MAXPATHLEN,char); + if (_getdcwd(drive, dir, MAXPATHLEN)) { + sv_setpv_mg(TARG, dir); + SvPOK_only(TARG); + } + else + sv_setsv(TARG, &PL_sv_undef); + + Safefree(dir); + + XSprePUSH; PUSHs(TARG); + SvTAINTED_on(TARG); +} + +#endif + +MODULE = Cwd PACKAGE = File::Spec::Unix + +SV * +canonpath(SV *self, SV *path = &PL_sv_undef, ...) +CODE: + PERL_UNUSED_VAR(self); + RETVAL = unix_canonpath(path); +OUTPUT: + RETVAL + +SV * +_fn_canonpath(SV *path = &PL_sv_undef, ...) +CODE: + RETVAL = unix_canonpath(path); +OUTPUT: + RETVAL + +SV * +catdir(SV *self, ...) +PREINIT: + dUSE_MY_CXT; + SV *joined; +CODE: + EXTEND(SP, items+1); + ST(items) = EMPTY_STRING_SV; + joined = sv_newmortal(); + do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items)); + if(invocant_is_unix(self)) { + RETVAL = unix_canonpath(joined); + } else { + ENTER; + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(self); + PUSHs(joined); + PUTBACK; + call_method("canonpath", G_SCALAR); + SPAGAIN; + RETVAL = POPs; + LEAVE; + SvREFCNT_inc(RETVAL); + } +OUTPUT: + RETVAL + +SV * +_fn_catdir(...) +PREINIT: + dUSE_MY_CXT; + SV *joined; +CODE: + EXTEND(SP, items+1); + ST(items) = EMPTY_STRING_SV; + joined = sv_newmortal(); + do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items)); + RETVAL = unix_canonpath(joined); +OUTPUT: + RETVAL + +SV * +catfile(SV *self, ...) +PREINIT: + dUSE_MY_CXT; +CODE: + if(invocant_is_unix(self)) { + if(items == 1) { + RETVAL = &PL_sv_undef; + } else { + SV *file = unix_canonpath(ST(items-1)); + if(items == 2) { + RETVAL = file; + } else { + SV *dir = sv_newmortal(); + sv_2mortal(file); + ST(items-1) = EMPTY_STRING_SV; + do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1)); + RETVAL = unix_canonpath(dir); + if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/') + sv_catsv(RETVAL, SLASH_STRING_SV); + sv_catsv(RETVAL, file); + } + } + } else { + SV *file, *dir; + ENTER; + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(self); + PUSHs(items == 1 ? &PL_sv_undef : ST(items-1)); + PUTBACK; + call_method("canonpath", G_SCALAR); + SPAGAIN; + file = POPs; + LEAVE; + if(items <= 2) { + RETVAL = SvREFCNT_inc(file); + } else { + char const *pv; + STRLEN len; + bool need_slash; + SP--; + ENTER; + PUSHMARK(&ST(-1)); + PUTBACK; + call_method("catdir", G_SCALAR); + SPAGAIN; + dir = POPs; + LEAVE; + pv = SvPV(dir, len); + need_slash = len == 0 || pv[len-1] != '/'; + RETVAL = newSVsv(dir); + if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV); + sv_catsv(RETVAL, file); + } + } +OUTPUT: + RETVAL + +SV * +_fn_catfile(...) +PREINIT: + dUSE_MY_CXT; +CODE: + if(items == 0) { + RETVAL = &PL_sv_undef; + } else { + SV *file = unix_canonpath(ST(items-1)); + if(items == 1) { + RETVAL = file; + } else { + SV *dir = sv_newmortal(); + sv_2mortal(file); + ST(items-1) = EMPTY_STRING_SV; + do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1)); + RETVAL = unix_canonpath(dir); + if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/') + sv_catsv(RETVAL, SLASH_STRING_SV); + sv_catsv(RETVAL, file); + } + } +OUTPUT: + RETVAL diff --git a/cpan/dist/PathTools/INSTALL b/cpan/dist/PathTools/INSTALL new file mode 100644 index 00000000..743a0ca7 --- /dev/null +++ b/cpan/dist/PathTools/INSTALL @@ -0,0 +1,21 @@ + Installation instructions for PathTools + +To install this module, do this: + + perl Build.PL + ./Build + ./Build test + ./Build install + +Alternatively, if you don't want to use the newer Module::Build module, +you can follow the standard steps for installing most Perl modules: + + perl Makefile.PL + make + make test + make install + +Or you may use the CPAN.pm module, which will automatically execute +these steps for you. See 'perldoc CPAN' for the details. + + -Ken diff --git a/cpan/dist/PathTools/MANIFEST b/cpan/dist/PathTools/MANIFEST new file mode 100644 index 00000000..36e47b18 --- /dev/null +++ b/cpan/dist/PathTools/MANIFEST @@ -0,0 +1,35 @@ +Changes +Cwd.pm +Cwd.xs +INSTALL +lib/File/Spec.pm +lib/File/Spec/AmigaOS.pm +lib/File/Spec/Cygwin.pm +lib/File/Spec/Epoc.pm +lib/File/Spec/Functions.pm +lib/File/Spec/Mac.pm +lib/File/Spec/OS2.pm +lib/File/Spec/Unix.pm +lib/File/Spec/VMS.pm +lib/File/Spec/Win32.pm +Makefile.PL +MANIFEST This list of files +ppport.h +README +t/abs2rel.t +t/crossplatform.t +t/cwd.t +t/Functions.t +t/lib/Test/Builder.pm +t/lib/Test/More.pm +t/lib/Test/Simple.pm +t/lib/Test/Tutorial.pod +t/rel2abs2rel.t +t/rel2abs_vs_symlink.t +t/Spec-taint.t +t/Spec.t +t/taint.t +t/tmpdir.t +t/win32.t +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/cpan/dist/PathTools/META.json b/cpan/dist/PathTools/META.json new file mode 100644 index 00000000..4932c331 --- /dev/null +++ b/cpan/dist/PathTools/META.json @@ -0,0 +1,46 @@ +{ + "abstract" : "unknown", + "author" : [ + "unknown" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005", + "license" : [ + "unknown" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "PathTools", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "File::Basename" : "0", + "Scalar::Util" : "0", + "Test" : "0", + "Test::More" : "0.88" + } + } + }, + "release_status" : "stable", + "version" : "3.62", + "x_serialization_backend" : "JSON::PP version 2.27300" +} diff --git a/cpan/dist/PathTools/META.yml b/cpan/dist/PathTools/META.yml new file mode 100644 index 00000000..7026a49a --- /dev/null +++ b/cpan/dist/PathTools/META.yml @@ -0,0 +1,27 @@ +--- +abstract: unknown +author: + - unknown +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005' +license: unknown +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: PathTools +no_index: + directory: + - t + - inc +requires: + Carp: '0' + File::Basename: '0' + Scalar::Util: '0' + Test: '0' + Test::More: '0.88' +version: '3.62' +x_serialization_backend: 'CPAN::Meta::YAML version 0.017' diff --git a/cpan/dist/PathTools/Makefile.PL b/cpan/dist/PathTools/Makefile.PL new file mode 100644 index 00000000..bc40baff --- /dev/null +++ b/cpan/dist/PathTools/Makefile.PL @@ -0,0 +1,27 @@ + +BEGIN { @INC = grep {!/blib/} @INC } + +require 5.005; +use ExtUtils::MakeMaker; +WriteMakefile +( + 'DISTNAME' => 'PathTools', + 'NAME' => 'Cwd', + 'VERSION_FROM' => 'Cwd.pm', + 'DEFINE' => join(" ", + "-DDOUBLE_SLASHES_SPECIAL=@{[$^O eq q(qnx) || $^O eq q(nto) ? 1 : 0]}", + ((grep { $_ eq 'PERL_CORE=1' } @ARGV) ? '-DNO_PPPORT_H' : ()), + ), + 'PREREQ_PM' => { + 'Carp' => '0', + 'File::Basename' => '0', + 'Scalar::Util' => '0', + 'Test' => '0', + # done_testing() is used in dist/Cwd/t/Spec.t + 'Test::More' => 0.88, + }, + ($] > 5.011) ? () : ( INSTALLDIRS => 'perl' ), # CPAN sourced versions should now install to site + 'EXE_FILES' => [], + 'PL_FILES' => {} + ) +; diff --git a/cpan/dist/PathTools/README b/cpan/dist/PathTools/README new file mode 100644 index 00000000..a04e895d --- /dev/null +++ b/cpan/dist/PathTools/README @@ -0,0 +1,2 @@ +This is the combined distribution for the File::Spec and Cwd modules. +Please see their respective documentation for details. diff --git a/cpan/dist/PathTools/lib/File/Spec.pm b/cpan/dist/PathTools/lib/File/Spec.pm new file mode 100644 index 00000000..2709c39f --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec.pm @@ -0,0 +1,340 @@ +package File::Spec; + +use strict; +use vars qw(@ISA $VERSION); + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +my %module = (MacOS => 'Mac', + MSWin32 => 'Win32', + os2 => 'OS2', + VMS => 'VMS', + epoc => 'Epoc', + NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. + dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. + cygwin => 'Cygwin', + amigaos => 'AmigaOS'); + + +my $module = $module{$^O} || 'Unix'; + +require "File/Spec/$module.pm"; +@ISA = ("File::Spec::$module"); + +1; + +__END__ + +=head1 NAME + +File::Spec - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec; + + $x=File::Spec->catfile('a', 'b', 'c'); + +which returns 'a/b/c' under Unix. Or: + + use File::Spec::Functions; + + $x = catfile('a', 'b', 'c'); + +=head1 DESCRIPTION + +This module is designed to support operations commonly performed on file +specifications (usually called "file names", but not to be confused with the +contents of a file, or Perl's file handles), such as concatenating several +directory and file names into a single path, or determining whether a path +is rooted. It is based on code directly taken from MakeMaker 5.17, code +written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya +Zakharevich, Paul Schinder, and others. + +Since these functions are different for most operating systems, each set of +OS specific routines is available in a separate module, including: + + File::Spec::Unix + File::Spec::Mac + File::Spec::OS2 + File::Spec::Win32 + File::Spec::VMS + +The module appropriate for the current OS is automatically loaded by +File::Spec. Since some modules (like VMS) make use of facilities available +only under that OS, it may not be possible to load all modules under all +operating systems. + +Since File::Spec is object oriented, subroutines should not be called directly, +as in: + + File::Spec::catfile('a','b'); + +but rather as class methods: + + File::Spec->catfile('a','b'); + +For simple uses, L<File::Spec::Functions> provides convenient functional +forms of these methods. + +=head1 METHODS + +=over 2 + +=item canonpath +X<canonpath> + +No physical check on the filesystem, but a logical cleanup of a +path. + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=item catdir +X<catdir> + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS/2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + + $path = File::Spec->catdir( @directories ); + +=item catfile +X<catfile> + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + + $path = File::Spec->catfile( @directories, $filename ); + +=item curdir +X<curdir> + +Returns a string representation of the current directory. + + $curdir = File::Spec->curdir(); + +=item devnull +X<devnull> + +Returns a string representation of the null device. + + $devnull = File::Spec->devnull(); + +=item rootdir +X<rootdir> + +Returns a string representation of the root directory. + + $rootdir = File::Spec->rootdir(); + +=item tmpdir +X<tmpdir> + +Returns a string representation of the first writable directory from a +list of possible temporary directories. Returns the current directory +if no writable temporary directories are found. The list of directories +checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> +(unless taint is on) and F</tmp>. + + $tmpdir = File::Spec->tmpdir(); + +=item updir +X<updir> + +Returns a string representation of the parent directory. + + $updir = File::Spec->updir(); + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + + @paths = File::Spec->no_upwards( @paths ); + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +case is not or is significant when comparing file specifications. +Cygwin and Win32 accept an optional drive argument. + + $is_case_tolerant = File::Spec->case_tolerant(); + +=item file_name_is_absolute + +Takes as its argument a path, and returns true if it is an absolute path. + + $is_absolute = File::Spec->file_name_is_absolute( $path ); + +This does not consult the local filesystem on Unix, Win32, OS/2, or +Mac OS (Classic). It does consult the working environment for VMS +(see L<File::Spec::VMS/file_name_is_absolute>). + +=item path +X<path> + +Takes no argument. Returns the environment variable C<PATH> (or the local +platform's equivalent) as a list. + + @PATH = File::Spec->path(); + +=item join +X<join, path> + +join is the same as catfile. + +=item splitpath +X<splitpath> X<split, path> + +Splits a path in to volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + + ($volume,$directories,$file) = + File::Spec->splitpath( $path ); + ($volume,$directories,$file) = + File::Spec->splitpath( $path, $no_file ); + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless C<$no_file> is true or a +trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=item splitdir +X<splitdir> X<split, dir> + +The opposite of L</catdir>. + + @dirs = File::Spec->splitdir( $directories ); + +C<$directories> must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSes. + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is +inserted if need be. On other OSes, C<$volume> is significant. + + $full_path = File::Spec->catpath( $volume, $directory, $file ); + +=item abs2rel +X<abs2rel> X<absolute, path> X<relative, path> + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<Cwd::cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<Cwd::cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=item rel2abs() +X<rel2abs> X<absolute, path> X<relative, path> + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<Cwd::cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is absolute, it is cleaned up and returned using L</canonpath>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=back + +For further information, please see L<File::Spec::Unix>, +L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or +L<File::Spec::VMS>. + +=head1 SEE ALSO + +L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, +L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, +L<ExtUtils::MakeMaker> + +=head1 AUTHOR + +Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< <kjahds@kjahds.com> >>, +Andy Dougherty C<< <doughera@lafayette.edu> >>, +Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>, +Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>. +VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>. +OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>. +Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and +Thomas Wegner C<< <wegner_thomas@yahoo.com> >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>, +modified by Barrie Slaymaker C<< <barries@slaysys.com> >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004-2013 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. + +=cut diff --git a/cpan/dist/PathTools/lib/File/Spec/AmigaOS.pm b/cpan/dist/PathTools/lib/File/Spec/AmigaOS.pm new file mode 100644 index 00000000..e6d6f5f2 --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/AmigaOS.pm @@ -0,0 +1,61 @@ +package File::Spec::AmigaOS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::AmigaOS - File::Spec for AmigaOS + +=head1 SYNOPSIS + + require File::Spec::AmigaOS; # Done automatically by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item tmpdir + +Returns $ENV{TMPDIR} or if that is unset, "/t". + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/t" ); +} + +=item file_name_is_absolute + +Returns true if there's a colon in the file name, +or if it begins with a slash. + +=cut + +sub file_name_is_absolute { + my ($self, $file) = @_; + + # Not 100% robust as a "/" must not preceded a ":" + # but this cannot happen in a well formed path. + return $file =~ m{^/|:}s; +} + +=back + +All the other methods are from L<File::Spec::Unix>. + +=cut + +1; diff --git a/cpan/dist/PathTools/lib/File/Spec/Cygwin.pm b/cpan/dist/PathTools/lib/File/Spec/Cygwin.pm new file mode 100644 index 00000000..67f056f5 --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/Cygwin.pm @@ -0,0 +1,160 @@ +package File::Spec::Cygwin; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Cygwin - methods for Cygwin file specs + +=head1 SYNOPSIS + + require File::Spec::Cygwin; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +This module is still in beta. Cygwin-knowledgeable folks are invited +to offer patches and suggestions. + +=cut + +=pod + +=over 4 + +=item canonpath + +Any C<\> (backslashes) are converted to C</> (forward slashes), +and then File::Spec::Unix canonpath() is called on the result. + +=cut + +sub canonpath { + my($self,$path) = @_; + return unless defined $path; + + $path =~ s|\\|/|g; + + # Handle network path names beginning with double slash + my $node = ''; + if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) { + $node = $1; + } + return $node . $self->SUPER::canonpath($path); +} + +sub catdir { + my $self = shift; + return unless @_; + + # Don't create something that looks like a //network/path + if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { + shift; + return $self->SUPER::catdir('', @_); + } + + $self->SUPER::catdir(@_); +} + +=pod + +=item file_name_is_absolute + +True is returned if the file name begins with C<drive_letter:>, +and if not, File::Spec::Unix file_name_is_absolute() is called. + +=cut + + +sub file_name_is_absolute { + my ($self,$file) = @_; + return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test + return $self->SUPER::file_name_is_absolute($file); +} + +=item tmpdir (override) + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + /tmp + $ENV{'TMP'} + $ENV{'TEMP'} + C:/temp + +If running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +sub tmpdir { + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( + $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' + ), + qw 'TMPDIR TMP TEMP' + ); +} + +=item case_tolerant + +Override Unix. Cygwin case-tolerance depends on managed mount settings and +as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Default: 1 + +=cut + +sub case_tolerant { + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + + my $drive = shift; + if (! $drive) { + my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); + my $prefix = pop(@flags); + if (! $prefix || $prefix eq 'cygdrive') { + $drive = '/cygdrive/c'; + } elsif ($prefix eq '/') { + $drive = '/c'; + } else { + $drive = "$prefix/c"; + } + } + my $mntopts = Cygwin::mount_flags($drive); + if ($mntopts and ($mntopts =~ /,managed/)) { + return 0; + } + eval { require Win32API::File; } or return 1; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004,2007 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. + +=cut + +1; diff --git a/cpan/dist/PathTools/lib/File/Spec/Epoc.pm b/cpan/dist/PathTools/lib/File/Spec/Epoc.pm new file mode 100644 index 00000000..17e3f54d --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/Epoc.pm @@ -0,0 +1,79 @@ +package File::Spec::Epoc; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Epoc - methods for Epoc file specs + +=head1 SYNOPSIS + + require File::Spec::Epoc; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This package is still a work in progress. ;-) + +=cut + +sub case_tolerant { + return 1; +} + +=pod + +=over 4 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=back + +=cut + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + $path =~ s|/+|/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + return $path; +} + +=pod + +=head1 AUTHOR + +o.flebbe@gmx.de + +=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. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/cpan/dist/PathTools/lib/File/Spec/Functions.pm b/cpan/dist/PathTools/lib/File/Spec/Functions.pm new file mode 100644 index 00000000..470c7718 --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/Functions.pm @@ -0,0 +1,130 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw( + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path +); + +@EXPORT_OK = qw( + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant +); + +%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); + +require File::Spec::Unix; +my %udeps = ( + canonpath => [], + catdir => [qw(canonpath)], + catfile => [qw(canonpath catdir)], + case_tolerant => [], + curdir => [], + devnull => [], + rootdir => [], + updir => [], +); + +foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = File::Spec->can($meth); + no strict 'refs'; + if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) && + !(grep { + File::Spec->can($_) != File::Spec::Unix->can($_) + } @{$udeps{$meth}}) && + defined(&{"File::Spec::Unix::_fn_$meth"})) { + *{$meth} = \&{"File::Spec::Unix::_fn_$meth"}; + } else { + *{$meth} = sub {&$sub('File::Spec', @_)}; + } +} + + +1; +__END__ + +=head1 NAME + +File::Spec::Functions - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec::Functions; + $x = catfile('a','b'); + +=head1 DESCRIPTION + +This module exports convenience functions for all of the class methods +provided by File::Spec. + +For a reference of available functions, please consult L<File::Spec::Unix>, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L<File::Spec::Mac>, +L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. + +=head2 Exports + +The following functions are exported by default. + + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path + + +The following functions are exported only by request. + + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant + +All the functions may be imported using the C<:ALL> tag. + +=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. + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker + +=cut + diff --git a/cpan/dist/PathTools/lib/File/Spec/Mac.pm b/cpan/dist/PathTools/lib/File/Spec/Mac.pm new file mode 100644 index 00000000..329451fb --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/Mac.pm @@ -0,0 +1,786 @@ +package File::Spec::Mac; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::Files }; +} + +sub case_tolerant { 1 } + + +=head1 NAME + +File::Spec::Mac - File::Spec for Mac OS (Classic) + +=head1 SYNOPSIS + + require File::Spec::Mac; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item canonpath + +On Mac OS, there's nothing to be done. Returns what it's given. + +=cut + +sub canonpath { + my ($self,$path) = @_; + return $path; +} + +=item catdir() + +Concatenate two or more directory names to form a path separated by colons +(":") ending with a directory. Resulting paths are B<relative> by default, +but can be forced to be absolute (but avoid this, see below). Automatically +puts a trailing ":" on the end of the complete path, because that's what's +done in MacPerl's environment and helps to distinguish a file path from a +directory path. + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting +path is relative by default and I<not> absolute. This decision was made due +to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths +on all other operating systems, it will now also follow this convention on Mac +OS. Note that this may break some existing scripts. + +The intended purpose of this routine is to concatenate I<directory names>. +But because of the nature of Macintosh paths, some additional possibilities +are allowed to make using this routine give reasonable results for some +common situations. In other words, you are also allowed to concatenate +I<paths> instead of directory names (strictly speaking, a string like ":a" +is a path, but not a name, since it contains a punctuation character ":"). + +So, beside calls like + + catdir("a") = ":a:" + catdir("a","b") = ":a:b:" + catdir() = "" (special case) + +calls like the following + + catdir(":a:") = ":a:" + catdir(":a","b") = ":a:b:" + catdir(":a:","b") = ":a:b:" + catdir(":a:",":b:") = ":a:b:" + catdir(":") = ":" + +are allowed. + +Here are the rules that are used in C<catdir()>; note that we try to be as +compatible as possible to Unix: + +=over 2 + +=item 1. + +The resulting path is relative by default, i.e. the resulting path will have a +leading colon. + +=item 2. + +A trailing colon is added automatically to the resulting path, to denote a +directory. + +=item 3. + +Generally, each argument has one leading ":" and one trailing ":" +removed (if any). They are then joined together by a ":". Special +treatment applies for arguments denoting updir paths like "::lib:", +see (4), or arguments consisting solely of colons ("colon paths"), +see (5). + +=item 4. + +When an updir path like ":::lib::" is passed as argument, the number +of directories to climb up is handled correctly, not removing leading +or trailing colons when necessary. E.g. + + catdir(":::a","::b","c") = ":::a::b:c:" + catdir(":::a::","::b","c") = ":::a:::b:c:" + +=item 5. + +Adding a colon ":" or empty string "" to a path at I<any> position +doesn't alter the path, i.e. these arguments are ignored. (When a "" +is passed as the first argument, it has a special meaning, see +(6)). This way, a colon ":" is handled like a "." (curdir) on Unix, +while an empty string "" is generally ignored (see +C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".." +(updir), and a ":::" is handled like a "../.." etc. E.g. + + catdir("a",":",":","b") = ":a:b:" + catdir("a",":","::",":b") = ":a::b:" + +=item 6. + +If the first argument is an empty string "" or is a volume name, i.e. matches +the pattern /^[^:]+:/, the resulting path is B<absolute>. + +=item 7. + +Passing an empty string "" as the first argument to C<catdir()> is +like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e. + + catdir("","a","b") is the same as + + catdir(rootdir(),"a","b"). + +This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and +C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup +volume, which is the closest in concept to Unix' "/". This should help +to run existing scripts originally written for Unix. + +=item 8. + +For absolute paths, some cleanup is done, to ensure that the volume +name isn't immediately followed by updirs. This is invalid, because +this would go beyond "root". Generally, these cases are handled like +their Unix counterparts: + + Unix: + Unix->catdir("","") = "/" + Unix->catdir("",".") = "/" + Unix->catdir("","..") = "/" # can't go + # beyond root + Unix->catdir("",".","..","..","a") = "/a" + Mac: + Mac->catdir("","") = rootdir() # (e.g. "HD:") + Mac->catdir("",":") = rootdir() + Mac->catdir("","::") = rootdir() # can't go + # beyond root + Mac->catdir("",":","::","::","a") = rootdir() . "a:" + # (e.g. "HD:a:") + +However, this approach is limited to the first arguments following +"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more +arguments that move up the directory tree, an invalid path going +beyond root can be created. + +=back + +As you've seen, you can force C<catdir()> to create an absolute path +by passing either an empty string or a path that begins with a volume +name as the first argument. However, you are strongly encouraged not +to do so, since this is done only for backward compatibility. Newer +versions of File::Spec come with a method called C<catpath()> (see +below), that is designed to offer a portable solution for the creation +of absolute paths. It takes volume, directory and file portions and +returns an entire path. While C<catdir()> is still suitable for the +concatenation of I<directory names>, you are encouraged to use +C<catpath()> to concatenate I<volume names> and I<directory +paths>. E.g. + + $dir = File::Spec->catdir("tmp","sources"); + $abs_path = File::Spec->catpath("MacintoshHD:", $dir,""); + +yields + + "MacintoshHD:tmp:sources:" . + +=cut + +sub catdir { + my $self = shift; + return '' unless @_; + my @args = @_; + my $first_arg; + my $relative; + + # take care of the first argument + + if ($args[0] eq '') { # absolute path, rootdir + shift @args; + $relative = 0; + $first_arg = $self->rootdir; + + } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name + $relative = 0; + $first_arg = shift @args; + # add a trailing ':' if need be (may be it's a path like HD:dir) + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + + } else { # relative path + $relative = 1; + if ( $args[0] =~ /^::+\Z(?!\n)/ ) { + # updir colon path ('::', ':::' etc.), don't shift + $first_arg = ':'; + } elsif ($args[0] eq ':') { + $first_arg = shift @args; + } else { + # add a trailing ':' if need be + $first_arg = shift @args; + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + } + } + + # For all other arguments, + # (a) ignore arguments that equal ':' or '', + # (b) handle updir paths specially: + # '::' -> concatenate '::' + # '::' . '::' -> concatenate ':::' etc. + # (c) add a trailing ':' if need be + + my $result = $first_arg; + while (@args) { + my $arg = shift @args; + unless (($arg eq '') || ($arg eq ':')) { + if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::' + my $updir_count = length($arg) - 1; + while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path + $arg = shift @args; + $updir_count += (length($arg) - 1); + } + $arg = (':' x $updir_count); + } else { + $arg =~ s/^://s; # remove a leading ':' if any + $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':' + } + $result .= $arg; + }#unless + } + + if ( ($relative) && ($result !~ /^:/) ) { + # add a leading colon if need be + $result = ":$result"; + } + + unless ($relative) { + # remove updirs immediately following the volume name + $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/; + } + + return $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename. Resulting paths are B<relative> +by default, but can be forced to be absolute (but avoid this). + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the +resulting path is relative by default and I<not> absolute. This +decision was made due to portability reasons. Since +C<File::Spec-E<gt>catfile()> returns relative paths on all other +operating systems, it will now also follow this convention on Mac OS. +Note that this may break some existing scripts. + +The last argument is always considered to be the file portion. Since +C<catfile()> uses C<catdir()> (see above) for the concatenation of the +directory portions (if any), the following with regard to relative and +absolute paths is true: + + catfile("") = "" + catfile("file") = "file" + +but + + catfile("","") = rootdir() # (e.g. "HD:") + catfile("","file") = rootdir() . file # (e.g. "HD:file") + catfile("HD:","file") = "HD:file" + +This means that C<catdir()> is called only when there are two or more +arguments, as one might expect. + +Note that the leading ":" is removed from the filename, so that + + catfile("a","b","file") = ":a:b:file" and + + catfile("a","b",":file") = ":a:b:file" + +give the same answer. + +To concatenate I<volume names>, I<directory paths> and I<filenames>, +you are encouraged to use C<catpath()> (see below). + +=cut + +sub catfile { + my $self = shift; + return '' unless @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $file =~ s/^://s; + return $dir.$file; +} + +=item curdir + +Returns a string representing the current directory. On Mac OS, this is ":". + +=cut + +sub curdir { + return ":"; +} + +=item devnull + +Returns a string representing the null device. On Mac OS, this is "Dev:Null". + +=cut + +sub devnull { + return "Dev:Null"; +} + +=item rootdir + +Returns a string representing the root directory. Under MacPerl, +returns the name of the startup volume, since that's the closest in +concept, although other volumes aren't rooted there. The name has a +trailing ":", because that's the correct specification for a volume +name on Mac OS. + +If Mac::Files could not be loaded, the empty string is returned. + +=cut + +sub rootdir { +# +# There's no real root directory on Mac OS. The name of the startup +# volume is returned, since that's the closest in concept. +# + return '' unless $macfiles; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*\Z(?!\n)/:/s; + return $system; +} + +=item tmpdir + +Returns the contents of $ENV{TMPDIR}, if that directory exits or the +current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will +contain a path like "MacintoshHD:Temporary Items:", which is a hidden +directory on your startup volume. + +=cut + +sub tmpdir { + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), 'TMPDIR'); +} + +=item updir + +Returns a string representing the parent directory. On Mac OS, this is "::". + +=cut + +sub updir { + return "::"; +} + +=item file_name_is_absolute + +Takes as argument a path and returns true, if it is an absolute path. +If the path has a leading ":", it's a relative path. Otherwise, it's an +absolute path, unless the path doesn't contain any colons, i.e. it's a name +like "a". In this particular case, the path is considered to be relative +(i.e. it is considered to be a filename). Use ":" in the appropriate place +in the path if you want to distinguish unambiguously. As a special case, +the filename '' is always considered to be absolute. Note that with version +1.2 of File::Spec::Mac, this does no longer consult the local filesystem. + +E.g. + + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); + # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) + + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + if ($file =~ /:/) { + return (! ($file =~ m/^:/s) ); + } elsif ( $file eq '' ) { + return 1 ; + } else { + return 0; # i.e. a file like "a" + } +} + +=item path + +Returns the null list for the MacPerl application, since the concept is +usually meaningless under Mac OS. But if you're using the MacPerl tool under +MPW, it gives back $ENV{Commands} suitably split, as is done in +:lib:ExtUtils:MM_Mac.pm. + +=cut + +sub path { +# +# The concept is meaningless under the MacPerl application. +# Under MPW, it has a meaning. +# + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); + +Splits a path into volume, directory, and filename portions. + +On Mac OS, assumes that the last part of the path is a filename unless +$no_file is true or a trailing separator ":" is present. + +The volume portion is always returned with a trailing ":". The directory portion +is always returned with a leading (to denote a relative path) and a trailing ":" +(to denote a directory). The file portion is always returned I<without> a leading ":". +Empty portions are returned as empty string ''. + +The results can be passed to C<catpath()> to get back a path equivalent to +(usually identical to) the original path. + + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file); + + if ( $nofile ) { + ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s; + } + else { + $path =~ + m|^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + |xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + $volume = '' unless defined($volume); + $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir" + if ($directory) { + # Make sure non-empty directories begin and end in ':' + $directory .= ':' unless (substr($directory,-1) eq ':'); + $directory = ":$directory" unless (substr($directory,0,1) eq ':'); + } else { + $directory = ''; + } + $file = '' unless defined($file); + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of C<catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories should be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. Consider using C<splitpath()> otherwise. + +Unlike just splitting the directories on the separator, empty directory names +(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing +colon to distinguish a directory path from a file path, a single trailing colon +will be ignored, i.e. there's no empty directory name after it. + +Hence, on Mac OS, both + + File::Spec->splitdir( ":a:b::c:" ); and + File::Spec->splitdir( ":a:b::c" ); + +yield: + + ( "a", "b", "::", "c") + +while + + File::Spec->splitdir( ":a:b::c::" ); + +yields: + + ( "a", "b", "::", "c", "::") + + +=cut + +sub splitdir { + my ($self, $path) = @_; + my @result = (); + my ($head, $sep, $tail, $volume, $directories); + + return @result if ( (!defined($path)) || ($path eq '') ); + return (':') if ($path eq ':'); + + ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; + + # deprecated, but handle it correctly + if ($volume) { + push (@result, $volume); + $sep .= ':'; + } + + while ($sep || $directories) { + if (length($sep) > 1) { + my $updir_count = length($sep) - 1; + for (my $i=0; $i<$updir_count; $i++) { + # push '::' updir_count times; + # simulate Unix '..' updirs + push (@result, '::'); + } + } + $sep = ''; + if ($directories) { + ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s; + push (@result, $head); + $directories = $tail; + } + } + return @result; +} + + +=item catpath + + $path = File::Spec->catpath($volume,$directory,$file); + +Takes volume, directory and file portions and returns an entire path. On Mac OS, +$volume, $directory and $file are concatenated. A ':' is inserted if need be. You +may pass an empty string for each portion. If all portions are empty, the empty +string is returned. If $volume is empty, the result will be a relative path, +beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any) +is removed form $file and the remainder is returned. If $file is empty, the +resulting path will have a trailing ':'. + + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( (! $volume) && (! $directory) ) { + $file =~ s/^:// if $file; + return $file ; + } + + # We look for a volume in $volume, then in $directory, but not both + + my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1); + + $volume = $dir_volume unless length $volume; + my $path = $volume; # may be '' + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + + if ($directory) { + $directory = $dir_dirs if $volume; + $directory =~ s/^://; # remove leading ':' if any + $path .= $directory; + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + } + + if ($file) { + $file =~ s/^://; # remove leading ':' if any + $path .= $file; + } + + return $path; +} + +=item abs2rel + +Takes a destination path and an optional base path and returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then the current working directory is used. +If $base is relative, then it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +If $path and $base appear to be on two different volumes, we will not +attempt to resolve the two paths, and we will instead simply return +$path. Note that previous versions of this module ignored the volume +of $base, which resulted in garbage results part of the time. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is relative, it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +Based on code written by Shigio Yamaguchi. + + +=cut + +# maybe this should be done in canonpath() ? +sub _resolve_updirs { + my $path = shift @_; + my $proceed; + + # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file" + do { + $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + + return $path; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + $base = _resolve_updirs( $base ); # resolve updirs in $base + } + else { + $base = _resolve_updirs( $base ); + } + + # Split up paths - ignore $base's file + my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path ); + my ( $base_vol, $base_dirs ) = $self->splitpath( $base ); + + return $path unless lc( $path_vol ) eq lc( $base_vol ); + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_dirs ); + my @basechunks = $self->splitdir( $base_dirs ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @pathchunks now has the directories to descend in to. + # ensure relative path, even if @pathchunks is empty + $path_dirs = $self->catdir( ':', @pathchunks ); + + # @basechunks now contains the number of directories to climb out of. + $base_dirs = (':' x @basechunks) . ':' ; + + return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path: + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then $base is set to the current working +directory. If $base is relative, then it is converted to absolute form +using C<rel2abs()>. This means that it is taken to be relative to the +current working directory. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is already absolute, it is returned and $base is ignored. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base) = @_; + + if ( ! $self->file_name_is_absolute($path) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute($base) ) { + $base = $self->rel2abs($base) ; + } + + # Split up paths + + # ignore $path's volume + my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; + + # ignore $base's file part + my ( $base_vol, $base_dirs ) = $self->splitpath($base) ; + + # Glom them together + $path_dirs = ':' if ($path_dirs eq ''); + $base_dirs =~ s/:$//; # remove trailing ':', if any + $base_dirs = $base_dirs . $path_dirs; + + $path = $self->catpath( $base_vol, $base_dirs, $path_file ); + } + return $path; +} + + +=back + +=head1 AUTHORS + +See the authors list in I<File::Spec>. Mac OS support by Paul Schinder +<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. + +=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. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/cpan/dist/PathTools/lib/File/Spec/OS2.pm b/cpan/dist/PathTools/lib/File/Spec/OS2.pm new file mode 100644 index 00000000..55e6d335 --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/OS2.pm @@ -0,0 +1,276 @@ +package File::Spec::OS2; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +sub devnull { + return "/dev/nul"; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); +} + +sub path { + my $path = $ENV{PATH}; + $path =~ s:\\:/:g; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +sub _cwd { + # In OS/2 the "require Cwd" is unnecessary bloat. + return Cwd::sys_cwd(); +} + +sub tmpdir { + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); + return $cached if defined $cached; + my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP' + ); +} + +sub catdir { + my $self = shift; + my @args = @_; + foreach (@args) { + tr[\\][/]; + # append a backslash to each argument unless it has one there + $_ .= "/" unless m{/$}; + } + return $self->canonpath(join('', @args)); +} + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + $path =~ s/^([a-z]:)/\l$1/s; + $path =~ s|\\|/|g; + $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx + $path =~ s|/\Z(?!\n)|| + unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx + $path =~ s{^/\.\.$}{/}; # /.. -> / + 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx + return $path; +} + + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +sub splitdir { + my ($self,$directories) = @_ ; + split m|[\\/]|, $directories, -1; +} + + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '/' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; + my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; + return $path unless $path_volume eq $base_volume; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '/', @pathchunks ); + $base_directories = CORE::join( '/', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories/$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + return $self->canonpath( + $self->catpath( "", $path_directories, $path_file ) + ) ; +} + + +sub rel2abs { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +1; +__END__ + +=head1 NAME + +File::Spec::OS2 - methods for OS/2 file specs + +=head1 SYNOPSIS + + require File::Spec::OS2; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +Amongst the changes made for OS/2 are... + +=over 4 + +=item tmpdir + +Modifies the list of places temp directory information is looked for. + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / + +=item splitpath + +Volumes can be drive letters or UNC sharenames (\\server\share). + +=back + +=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. + +=cut diff --git a/cpan/dist/PathTools/lib/File/Spec/Unix.pm b/cpan/dist/PathTools/lib/File/Spec/Unix.pm new file mode 100644 index 00000000..586e9b0a --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/Unix.pm @@ -0,0 +1,598 @@ +package File::Spec::Unix; + +use strict; +use vars qw($VERSION); + +$VERSION = '3.62'; +my $xs_version = $VERSION; +$VERSION =~ tr/_//d; + +#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); + } else { + require Cwd; + } + }; +} + +=head1 NAME + +File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules + +=head1 SYNOPSIS + + require File::Spec::Unix; # Done automatically by File::Spec + +=head1 DESCRIPTION + +Methods for manipulating file specifications. Other File::Spec +modules, such as File::Spec::Mac, inherit from File::Spec::Unix and +override specific methods. + +=head1 METHODS + +=over 2 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminates successive slashes and successive "/.". + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=cut + +sub _pp_canonpath { + my ($self,$path) = @_; + return unless defined $path; + + # Handle POSIX-style node names beginning with double slash (qnx, nto) + # (POSIX says: "a pathname that begins with two successive slashes + # may be interpreted in an implementation-defined manner, although + # more than two leading slashes shall be treated as a single slash.") + my $node = ''; + my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; + + + if ( $double_slashes_special + && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { + $node = $1; + } + # This used to be + # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); + # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail + # (Mainly because trailing "" directories didn't get stripped). + # Why would cygwin avoid collapsing multiple slashes into one? --jhi + $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx + $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx + $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return "$node$path"; +} +*canonpath = \&_pp_canonpath unless defined &canonpath; + +=item catdir() + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + +=cut + +sub _pp_catdir { + my $self = shift; + + $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' +} +*catdir = \&_pp_catdir unless defined &catdir; + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub _pp_catfile { + my $self = shift; + my $file = $self->canonpath(pop @_); + return $file unless @_; + my $dir = $self->catdir(@_); + $dir .= "/" unless substr($dir,-1) eq "/"; + return $dir.$file; +} +*catfile = \&_pp_catfile unless defined &catfile; + +=item curdir + +Returns a string representation of the current directory. "." on UNIX. + +=cut + +sub curdir { '.' } +use constant _fn_curdir => "."; + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull { '/dev/null' } +use constant _fn_devnull => "/dev/null"; + +=item rootdir + +Returns a string representation of the root directory. "/" on UNIX. + +=cut + +sub rootdir { '/' } +use constant _fn_rootdir => "/"; + +=item tmpdir + +Returns a string representation of the first writable directory from +the following list or the current directory if none from the list are +writable: + + $ENV{TMPDIR} + /tmp + +If running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +my ($tmpdir, %tmpenv); +# Cache and return the calculated tmpdir, recording which env vars +# determined it. +sub _cache_tmpdir { + @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; + return $tmpdir = $_[1]; +} +# Retrieve the cached tmpdir, checking first whether relevant env vars have +# changed and invalidated the cache. +sub _cached_tmpdir { + shift; + local $^W; + return if grep $ENV{$_} ne $tmpenv{$_}, @_; + return $tmpdir; +} +sub _tmpdir { + my $self = shift; + my @dirlist = @_; + my $taint = do { no strict 'refs'; ${"\cTAINT"} }; + if ($taint) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + elsif ($] < 5.007) { # No ${^TAINT} before 5.8 + @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; + } + + foreach (@dirlist) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = $self->curdir unless defined $tmpdir; + $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + if ( !$self->file_name_is_absolute($tmpdir) ) { + # See [perl #120593] for the full details + # If possible, return a full path, rather than '.' or 'lib', but + # jump through some hoops to avoid returning a tainted value. + ($tmpdir) = grep { + $taint ? ! Scalar::Util::tainted($_) : + $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 + } $self->rel2abs($tmpdir), $tmpdir; + } + return $tmpdir; +} + +sub tmpdir { + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); +} + +=item updir + +Returns a string representation of the parent directory. ".." on UNIX. + +=cut + +sub updir { '..' } +use constant _fn_updir => ".."; + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + +=cut + +sub no_upwards { + my $self = shift; + return grep(!/^\.{1,2}\z/s, @_); +} + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +is not or is significant when comparing file specifications. + +=cut + +sub case_tolerant { 0 } +use constant _fn_case_tolerant => 0; + +=item file_name_is_absolute + +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, OS/2 or Mac +OS (Classic). It does consult the working environment for VMS (see +L<File::Spec::VMS/file_name_is_absolute>). + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. + +=cut + +sub path { + return () unless exists $ENV{PATH}; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +=item join + +join is the same as catfile. + +=cut + +sub join { + my $self = shift; + return $self->catfile(@_); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); + +Splits a path into volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless $no_file is true or a +trailing separator or /. or /.. is present. On Unix this means that $no_file +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSs. + +On Unix, + + File::Spec->splitdir( "/a/b//c/" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + return split m|/|, $_[1], -1; # Preserve trailing fields +} + + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and directory and file are concatenated. A '/' is +inserted if needed (though if the directory portion doesn't start with +'/' it is not added). On other OSs, $volume is significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; +} + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<cwd()|Cwd>. + +No checks against the filesystem are made, so the result may not be correct if +C<$base> contains symbolic links. (Apply +L<Cwd::abs_path()|Cwd/abs_path> beforehand if that +is a concern.) On VMS, there is interaction with the working environment, as +logicals and macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + ($path, $base) = map $self->canonpath($_), $path, $base; + + my $path_directories; + my $base_directories; + + if (grep $self->file_name_is_absolute($_), $path, $base) { + ($path, $base) = map $self->rel2abs($_), $path, $base; + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + $path_directories = ($self->splitpath($path, 1))[1]; + $base_directories = ($self->splitpath($base, 1))[1]; + + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } + } + else { + my $wd= ($self->splitpath($self->_cwd(), 1))[1]; + $path_directories = $self->catdir($wd, $path); + $base_directories = $self->catdir($wd, $base); + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + if ($base_directories eq $self->rootdir) { + return $self->curdir if $path_directories eq $self->rootdir; + shift @pathchunks; + return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); + } + + my @common; + while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { + push @common, shift @pathchunks ; + shift @basechunks ; + } + return $self->curdir unless @pathchunks || @basechunks; + + # @basechunks now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. If there + # are updir components, we must descend into the corresponding directories + # (this only works if they are no symlinks). + my @reverse_base; + while( defined(my $dir= shift @basechunks) ) { + if( $dir ne $self->updir ) { + unshift @reverse_base, $self->updir; + push @common, $dir; + } + elsif( @common ) { + if( @reverse_base && $reverse_base[0] eq $self->updir ) { + shift @reverse_base; + pop @common; + } + else { + unshift @reverse_base, pop @common; + } + } + } + my $result_dirs = $self->catdir( @reverse_base, @pathchunks ); + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} + +sub _same { + $_[1] eq $_[2]; +} + +=item rel2abs() + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores +the $base filename. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=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. + +Please submit bug reports and patches to perlbug@perl.org. + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +# Internal routine to File::Spec, no point in making this public since +# it is the standard Cwd interface. Most of the platform-specific +# File::Spec subclasses use this. +sub _cwd { + require Cwd; + Cwd::getcwd(); +} + + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + pop @dirs if @dirs && $dirs[-1] eq ''; + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + + +1; diff --git a/cpan/dist/PathTools/lib/File/Spec/VMS.pm b/cpan/dist/PathTools/lib/File/Spec/VMS.pm new file mode 100644 index 00000000..600c49fa --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/VMS.pm @@ -0,0 +1,568 @@ +package File::Spec::VMS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +use File::Basename; +use VMS::Filespec; + +=head1 NAME + +File::Spec::VMS - methods for VMS file specs + +=head1 SYNOPSIS + + require File::Spec::VMS; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +The default behavior is to allow either VMS or Unix syntax on input and to +return VMS syntax on output unless Unix syntax has been explicitly requested +via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature. + +=over 4 + +=cut + +# Need to look up the feature settings. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. + +my $use_feature; +BEGIN { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_feature = 1; + } +} + +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _unix_rpt { + my $unix_rpt; + if ($use_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + } + return $unix_rpt; +} + +=item canonpath (override) + +Removes redundant portions of file specifications and returns results +in native syntax unless Unix filename reporting has been enabled. + +=cut + + +sub canonpath { + my($self,$path) = @_; + + return undef unless defined $path; + + my $unix_rpt = $self->_unix_rpt; + + if ($path =~ m|/|) { + my $pathify = $path =~ m|/\Z(?!\n)|; + $path = $self->SUPER::canonpath($path); + + return $path if $unix_rpt; + $path = $pathify ? vmspath($path) : vmsify($path); + } + + $path =~ s/(?<!\^)</[/; # < and > ==> [ and ] + $path =~ s/(?<!\^)>/]/; + $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ + $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ + $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] + $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar + 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); + # That loop does the following + # with any amount of dashes: + # .-.-. ==> .--. + # [-.-. ==> [--. + # .-.-] ==> .--] + # [-.-] ==> [--] + 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + # That loop does the following + # with any amount (minimum 2) + # of dashes: + # .foo.--. ==> .-. + # .foo.--] ==> .-] + # [foo.--. ==> [-. + # [foo.--] ==> [-] + # + # And then, the remaining cases + $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [- + $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . + $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + # [foo.-] ==> [000000] + $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g; + # [] ==> + $path =~ s/(?<!\^)\[\]// unless $path eq '[]'; + return $unix_rpt ? unixify($path) : $path; +} + +=item catdir (override) + +Concatenates a list of file specifications, and returns the result as a +native directory specification unless the Unix filename reporting feature +has been enabled. No check is made for "impossible" cases (e.g. elements +other than the first being absolute filespecs). + +=cut + +sub catdir { + my $self = shift; + my $dir = pop; + + my $unix_rpt = $self->_unix_rpt; + + my @dirs = grep {defined() && length()} @_; + + my $rslt; + if (@dirs) { + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; + + if ($unix_rpt) { + $spath = unixify($spath) unless $spath =~ m#/#; + $sdir= unixify($sdir) unless $sdir =~ m#/#; + return $self->SUPER::catdir($spath, $sdir) + } + + $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 + # eliminate_macros(), since Unix syntax has no way to express + # "absolute from the top of this device's directory tree". + if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } + + } else { + # Single directory. Return an empty string on null input; otherwise + # just return a canonical path. + + if (not defined $dir or not length $dir) { + $rslt = ''; + } else { + $rslt = $unix_rpt ? $dir : vmspath($dir); + } + } + return $self->canonpath($rslt); +} + +=item catfile (override) + +Concatenates a list of directory specifications with a filename specification +to build a path. + +=cut + +sub catfile { + my $self = shift; + my $tfile = pop(); + my $file = $self->canonpath($tfile); + my @files = grep {defined() && length()} @_; + + my $unix_rpt = $self->_unix_rpt; + + my $rslt; + if (@files) { + my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + my $spath = $path; + + # Something building a VMS path in pieces may try to pass a + # directory name in filename format, so normalize it. + $spath =~ s/\.dir\Z(?!\n)//i; + + # If the spath ends with a directory delimiter and the file is bare, + # then just concatenate them. + if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } else { + $rslt = unixify($spath); + $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); + $rslt = vmsify($rslt) unless $unix_rpt; + } + } + else { + # Only passed a single file? + my $xfile = (defined($file) && length($file)) ? $file : ''; + + $rslt = $unix_rpt ? $xfile : vmsify($xfile); + } + return $self->canonpath($rslt) unless $unix_rpt; + + # In Unix report mode, do not strip off redundant path information. + return $rslt; +} + + +=item curdir (override) + +Returns a string representation of the current directory: '[]' or '.' + +=cut + +sub curdir { + my $self = shift @_; + return '.' if ($self->_unix_rpt); + return '[]'; +} + +=item devnull (override) + +Returns a string representation of the null device: '_NLA0:' or '/dev/null' + +=cut + +sub devnull { + my $self = shift @_; + return '/dev/null' if ($self->_unix_rpt); + return "_NLA0:"; +} + +=item rootdir (override) + +Returns a string representation of the root directory: 'SYS$DISK:[000000]' +or '/' + +=cut + +sub rootdir { + my $self = shift @_; + if ($self->_unix_rpt) { + # Root may exist, try it first. + my $try = '/'; + my ($dev1, $ino1) = stat('/'); + my ($dev2, $ino2) = stat('.'); + + # Perl falls back to '.' if it can not determine '/' + if (($dev1 != $dev2) || ($ino1 != $ino2)) { + return $try; + } + # Fall back to UNIX format sys$disk. + return '/sys$disk/'; + } + return 'SYS$DISK:[000000]'; +} + +=item tmpdir (override) + +Returns a string representation of the first writable directory +from the following list or '' if none are writable: + + /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled. + sys$scratch: + $ENV{TMPDIR} + +If running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +sub tmpdir { + my $self = shift @_; + my $tmpdir = $self->_cached_tmpdir('TMPDIR'); + return $tmpdir if defined $tmpdir; + if ($self->_unix_rpt) { + $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); + } + else { + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + } + $self->_cache_tmpdir($tmpdir, 'TMPDIR'); +} + +=item updir (override) + +Returns a string representation of the parent directory: '[-]' or '..' + +=cut + +sub updir { + my $self = shift @_; + return '..' if ($self->_unix_rpt); + return '[-]'; +} + +=item case_tolerant (override) + +VMS file specification syntax is case-tolerant. + +=cut + +sub case_tolerant { + return 1; +} + +=item path (override) + +Translate logical name DCL$PATH as a searchlist, rather than trying +to C<split> string value of C<$ENV{'PATH'}>. + +=cut + +sub path { + my (@dirs,$dir,$i); + while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } + return @dirs; +} + +=item file_name_is_absolute (override) + +Checks for VMS directory spec as well as Unix separators. + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + # If it's a logical name, expand it. + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; + return scalar($file =~ m!^/!s || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/); +} + +=item splitpath (override) + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); + +Passing a true value for C<$no_file> indicates that the path being +split only contains directory components, even on systems where you +can usually (when not supporting a foreign syntax) tell the difference +between directories and files at a glance. + +=cut + +sub splitpath { + my($self,$path, $nofile) = @_; + my($dev,$dir,$file) = ('','',''); + my $vmsify_path = vmsify($path); + + if ( $nofile ) { + #vmsify('d1/d2/d3') returns '[.d1.d2]d3' + #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' + if( $vmsify_path =~ /(.*)\](.+)/ ){ + $vmsify_path = $1.'.'.$2.']'; + } + $vmsify_path =~ /(.+:)?(.*)/s; + $dir = defined $2 ? $2 : ''; # dir can be '0' + return ($1 || '',$dir,$file); + } + else { + $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); + } +} + +=item splitdir (override) + +Split a directory specification into the components. + +=cut + +sub splitdir { + my($self,$dirspec) = @_; + my @dirs = (); + return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); + + $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ] + $dirspec =~ s/(?<!\^)>/]/; + $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ + $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ + $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] + $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar + while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} + # That loop does the following + # with any amount of dashes: + # .--. ==> .-.-. + # [--. ==> [-.-. + # .--] ==> .-.-] + # [--] ==> [-.-] + $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal + $dirspec =~ s/^(\[|<)\./$1/; + @dirs = split /(?<!\^)\./, vmspath($dirspec); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec. + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + + # We look for a volume in $dev, then in $dir, but not both + my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); + $dev = $dir_volume unless length $dev; + $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; + + if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } + if (length($dev) or length($dir)) { + $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/; + $dir = vmspath($dir); + } + $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>'); + "$dev$dir$file"; +} + +=item abs2rel (override) + +Attempt to convert an absolute file specification to a relative specification. + +=cut + +sub abs2rel { + my $self = shift; + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if ((grep m{/}, @_) && !(grep m{(?<!\^)[\[<:]}, @_)); + + my($path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + # 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" + # but the comparison that ignores device differences so as to concatenate + # [---] up directory specs is not even a good idea in cases where there is + # a logical path difference between $path and $base nodename and/or device. + # Hence we fall back to returning the absolute $path spec + # if there is a case blind device (or node) difference of any sort + # and we do not even try to call $parse() or consult %ENV for $trnlnm() + # (this module needs to run on non VMS platforms after all). + + my ($path_volume, $path_directories, $path_file) = $self->splitpath($path); + my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); + return $path unless lc($path_volume) eq lc($base_volume); + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my $pathchunks = @pathchunks; + unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; + my @basechunks = $self->splitdir( $base_directories ); + my $basechunks = @basechunks; + unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @basechunks now contains the directories to climb out of, + # @pathchunks now has the directories to descend in to. + if ((@basechunks > 0) || ($basechunks != $pathchunks)) { + $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + } + else { + $path_directories = join '.', @pathchunks; + } + $path_directories = '['.$path_directories.']'; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +Return an absolute file specification from a relative one. + +=cut + +sub rel2abs { + my $self = shift ; + my ($path,$base ) = @_; + return undef unless defined $path; + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + $base = vmspath($base) if defined $base && $base =~ m/\//; + + # Clean up and split up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_directories, $path_file ) = + ($self->splitpath( $path ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base ) ; + + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; + my $sep = '' ; + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + + $path = $self->catpath( $base_volume, $base_directories, $path_file ); + } + + return $self->canonpath( $path ) ; +} + + +=back + +=head1 COPYRIGHT + +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. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +An explanation of VMS file specs can be found at +L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>. + +=cut + +1; diff --git a/cpan/dist/PathTools/lib/File/Spec/Win32.pm b/cpan/dist/PathTools/lib/File/Spec/Win32.pm new file mode 100644 index 00000000..6df7ee87 --- /dev/null +++ b/cpan/dist/PathTools/lib/File/Spec/Win32.pm @@ -0,0 +1,446 @@ +package File::Spec::Win32; + +use strict; + +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +# Some regexes we use for path splitting +my $DRIVE_RX = '[a-zA-Z]:'; +my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; +my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; + + +=head1 NAME + +File::Spec::Win32 - methods for Win32 file specs + +=head1 SYNOPSIS + + require File::Spec::Win32; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over 4 + +=item devnull + +Returns a string representation of the null device. + +=cut + +sub devnull { + return "nul"; +} + +sub rootdir { '\\' } + + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + SYS:/temp + C:\system\temp + C:/temp + /tmp + / + +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). + +If running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +sub tmpdir { + my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP)); + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), + 'SYS:/temp', + 'C:\system\temp', + 'C:/temp', + '/tmp', + '/' ); + $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP)); +} + +=item case_tolerant + +MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. +See http://cygwin.com/ml/cygwin/2007-07/msg00891.html +Default: 1 + +=cut + +sub case_tolerant { + eval { require Win32API::File; } or return 1; + my $drive = shift || "C:"; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } +} + +=item file_name_is_absolute + +As of right now, this returns 2 if the path is absolute with a +volume, 1 if it's absolute with no volume, 0 otherwise. + +=cut + +sub file_name_is_absolute { + + my ($self,$file) = @_; + + if ($file =~ m{^($VOL_RX)}o) { + my $vol = $1; + return ($vol =~ m{^$UNC_RX}o ? 2 + : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 + : 0); + } + return $file =~ m{^[\\/]} ? 1 : 0; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + shift; + + # Legacy / compatibility support + # + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catfile('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); +} + +sub catdir { + shift; + + # Legacy / compatibility support + # + return "" + unless @_; + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catdir('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); +} + +sub path { + my @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + unshift(@path, "."); + return @path; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". +On Win32 makes + + dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even + dir1\dir2\dir3\...\dir4 -> \dir\dir4 + +=cut + +sub canonpath { + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); + +Splits a path into volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, '' ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L</catpath> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^ ( $VOL_RX ? ) (.*) }sox; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( $VOL_RX ? ) + ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }sox; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L<catdir()|File::Spec/catdir>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\Z(?!\n)| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + my $v; + $volume .= $v + if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + +sub _same { + lc($_[1]) eq lc($_[2]); +} + +sub rel2abs { + my ($self,$path,$base ) = @_; + + my $is_abs = $self->file_name_is_absolute($path); + + # Check for volume (should probably document the '2' thing...) + return $self->canonpath( $path ) if $is_abs == 2; + + if ($is_abs) { + # It's missing a volume, add one + my $vol = ($self->splitpath( $self->_cwd() ))[0]; + return $self->canonpath( $vol . $path ); + } + + if ( !defined( $base ) || $base eq '' ) { + require Cwd ; + $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; + $base = $self->_cwd() unless defined $base ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + + return $self->canonpath( $path ) ; +} + +=back + +=head2 Note For File::Spec::Win32 Maintainers + +Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. + +=head1 COPYRIGHT + +Copyright (c) 2004,2007 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. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + + +sub _canon_cat # @path -> path +{ + my ($first, @rest) = @_; + + my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter + ? ucfirst( $1 ).( $2 ? "\\" : "" ) + : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) + (?: [\\/] ([^\\/]+) )? + [\\/]? }{}xs # UNC volume + ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" + : $first =~ s{ \A [\\/] }{}x # root dir + ? "\\" + : ""; + my $path = join "\\", $first, @rest; + + $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy + + # xx/././yy --> xx/yy + $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + \. + (?:\\\.)* # and more + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}gx; + + # XXX I do not know whether more dots are supported by the OS supporting + # this ... annotation (NetWare or symbian but not MSWin32). + # Then .... could easily become ../../.. etc: + # Replace \.\.\. by (\.\.\.+) and substitute with + # { $1 . ".." . "\\.." x (length($2)-2) }gex + # ... --> ../.. + $path =~ s{ (\A|\\) # at begin or after a slash + \.\.\. + (?=\\|\z) # at end or followed by slash + }{$1..\\..}gx; + # xx\yy\..\zz --> xx\zz + while ( $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + [^\\]+ # rip this 'yy' off + \\\.\. + (?<!\A\.\.\\\.\.) # do *not* replace ^..\.. + (?<!\\\.\.\\\.\.) # do *not* replace \..\.. + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}sx ) {} + + $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # <vol>\.. --> <vol>\ + $path =~ s{ \A # at begin + \.\. + (?:\\\.\.)* # and more + (?:\\|\z) # at end or followed by slash + }{}x; + + return $1 # \\HOST\SHARE\ --> \\HOST\SHARE + if $path eq "" + and $volume =~ m#\A(\\\\.*)\\\z#s; + } + return $path ne "" || $volume ? $volume.$path : "."; +} + +1; diff --git a/cpan/dist/PathTools/ppport.h b/cpan/dist/PathTools/ppport.h new file mode 100644 index 00000000..dd8b73cf --- /dev/null +++ b/cpan/dist/PathTools/ppport.h @@ -0,0 +1,7748 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.31 + + Automatically created by Devel::PPPort running under perl 5.023001. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.31 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.20. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F<ppport.h>. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagically add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions or variables will be marked C<explicit> in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C<static> or global +variants. + +For a C<static> function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C<DPPP_NAMESPACE> +macro. Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report here: L<https://github.com/mhx/Devel-PPPort/issues/> + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.31; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +ASCII_TO_NEED||5.007001|n +AvFILLp|5.004050||p +AvFILL||| +BhkDISABLE||5.021008| +BhkENABLE||5.021008| +BhkENTRY_set||5.021008| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002|5.004050|p +Copy||| +CvPADLIST||5.008001| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvAV||| +GvCV||| +GvHV||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY|5.003070||p +HeHASH||5.003070| +HeKEY||5.003070| +HeKLEN||5.003070| +HePV||5.004000| +HeSVKEY_force||5.003070| +HeSVKEY_set||5.004000| +HeSVKEY||5.003070| +HeUTF8|5.010001|5.008000|p +HeVAL||5.003070| +HvENAMELEN||5.015004| +HvENAMEUTF8||5.015004| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAMELEN||5.015004| +HvNAMEUTF8||5.015004| +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.021008| +MUTABLE_PTR|5.010001||p +MUTABLE_SV|5.010001||p +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002|5.004050|p +Move||| +NATIVE_TO_NEED||5.007001|n +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +OP_TYPE_IS_OR_WAS||5.019010| +OP_TYPE_IS||5.019007| +ORIGMARK||| +OpHAS_SIBLING||5.021007| +OpSIBLING_set||5.021007| +OpSIBLING||5.021007| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.021008||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.003070||p +PERL_INT_MAX|5.003070||p +PERL_INT_MIN|5.003070||p +PERL_LONG_MAX|5.003070||p +PERL_LONG_MIN|5.003070||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.021008||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.021008||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.021008||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.021008||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.003070||p +PERL_QUAD_MIN|5.003070||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.003070||p +PERL_SHORT_MIN|5.003070||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.021008| +PERL_UCHAR_MAX|5.003070||p +PERL_UCHAR_MIN|5.003070||p +PERL_UINT_MAX|5.003070||p +PERL_UINT_MIN|5.003070||p +PERL_ULONG_MAX|5.003070||p +PERL_ULONG_MIN|5.003070||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.003070||p +PERL_UQUAD_MIN|5.003070||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.003070||p +PERL_USHORT_MIN|5.003070||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.021008||p +PL_bufptr|5.021008||p +PL_check||5.006000| +PL_compiling|5.004050||p +PL_comppad_name||5.017004| +PL_comppad||5.008001| +PL_copline|5.021008||p +PL_curcop|5.004050||p +PL_curpad||5.005000| +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.021008||p +PL_expect|5.021008||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.021008||p +PL_in_my|5.021008||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.021008||p +PL_lex_stuff|5.021008||p +PL_linestr|5.021008||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005||p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.021008||p +PL_rsfp|5.021008||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.021008||p +POP_MULTICALL||5.021008| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.021008| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PadARRAY||5.021008| +PadMAX||5.021008| +PadlistARRAY||5.021008| +PadlistMAX||5.021008| +PadlistNAMESARRAY||5.021008| +PadlistNAMESMAX||5.021008| +PadlistNAMES||5.021008| +PadlistREFCNT||5.017004| +PadnameIsOUR||| +PadnameIsSTATE||| +PadnameLEN||5.021008| +PadnameOURSTASH||| +PadnameOUTER||| +PadnamePV||5.021008| +PadnameREFCNT_dec||5.021008| +PadnameREFCNT||5.021008| +PadnameSV||5.021008| +PadnameTYPE||| +PadnameUTF8||5.021007| +PadnamelistARRAY||5.021008| +PadnamelistMAX||5.021008| +PadnamelistREFCNT_dec||5.021008| +PadnamelistREFCNT||5.021008| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_restore_errno||| +PerlIO_save_errno||| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +READ_XDIGIT||5.017006| +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_INVLIST||5.019002| +SVt_IV||| +SVt_NULL||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVFM||| +SVt_PVGV||| +SVt_PVHV||| +SVt_PVIO||| +SVt_PVIV||| +SVt_PVLV||| +SVt_PVMG||| +SVt_PVNV||| +SVt_PV||| +SVt_REGEXP||5.011000| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_ro||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen|5.013007||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec_NN||5.017007| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTHINKFIRST||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.021008||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +WIDEST_UTYPE|5.015004||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.021008| +XS_EXTERNAL||5.021008| +XS_INTERNAL||5.021008| +XS_VERSION_BOOTCHECK||5.021008| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.021008| +XopENABLE||5.021008| +XopENTRYCUSTOM||5.021008| +XopENTRY_set||5.021008| +XopENTRY||5.021008| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_add_range_to_invlist||| +_append_range_to_invlist||| +_core_swash_init||| +_get_encoding||| +_get_regclass_nonbitmap_data||| +_get_swash_invlist||| +_invlist_array_init|||n +_invlist_contains_cp|||n +_invlist_contents||| +_invlist_dump||| +_invlist_intersection_maybe_complement_2nd||| +_invlist_intersection||| +_invlist_invert||| +_invlist_len|||n +_invlist_populate_swatch|||n +_invlist_search|||n +_invlist_subtract||| +_invlist_union_maybe_complement_2nd||| +_invlist_union||| +_is_cur_LC_category_utf8||| +_is_in_locale_category||5.021001| +_is_uni_FOO||5.017008| +_is_uni_perl_idcont||5.017008| +_is_uni_perl_idstart||5.017007| +_is_utf8_FOO||5.017008| +_is_utf8_char_slow||5.021001|n +_is_utf8_idcont||5.021001| +_is_utf8_idstart||5.021001| +_is_utf8_mark||5.017008| +_is_utf8_perl_idcont||5.017008| +_is_utf8_perl_idstart||5.017007| +_is_utf8_xidcont||5.021001| +_is_utf8_xidstart||5.021001| +_load_PL_utf8_foldclosures||| +_make_exactf_invlist||| +_new_invlist_C_array||| +_new_invlist||| +_pMY_CXT|5.007003||p +_setup_canned_invlist||| +_swash_inversion_hash||| +_swash_to_invlist||| +_to_fold_latin1||| +_to_uni_fold_flags||5.014000| +_to_upper_title_latin1||| +_to_utf8_fold_flags||5.019009| +_to_utf8_lower_flags||5.019009| +_to_utf8_title_flags||5.019009| +_to_utf8_upper_flags||5.019009| +_warn_problematic_locale|||n +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.021008||p +aTHXR|5.021008||p +aTHX_|5.006000||p +aTHX|5.006000||p +aassign_common_vars||| +add_above_Latin1_folds||| +add_cp_to_invlist||| +add_data|||n +add_multi_match||| +add_utf16_textfilter||| +adjust_size_and_find_bucket|||n +advance_one_SB||| +advance_one_WB||| +alloc_maybe_populate_EXACT||| +alloccopstash||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_is_enabled||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_utf8_from_native_byte||5.019004|n +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +assignment_type||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend_guts||| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_tindex||5.017009| +av_top_index||5.017009| +av_undef||| +av_unshift||| +ax|||n +backup_one_SB||| +backup_one_WB||| +bad_type_gv||| +bad_type_pv||| +bind_match||| +block_end||5.004000| +block_gimme||5.004000| +block_start||5.004000| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx|5.013005|5.006000|p +calloc||5.007002|n +cando||| +cast_i32||5.006000|n +cast_iv||5.006000|n +cast_ulong||5.006000|n +cast_uv||5.006000|n +check_locale_boundary_crossing||| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +ckWARN|5.006000||p +ck_entersub_args_core||| +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +clear_placeholders||| +clear_special_blocks||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +cntrl_to_mnemonic|||n +compute_EXACTish|||n +construct_ahocorasick_from_trie||| +cop_fetch_label||5.015001| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cop_store_label||5.015001| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.021008| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +core_prototype||| +coresub_op||| +could_it_be_a_POSIX_class|||n +cr_textfilter||| +create_eval_scope||| +croak_memory_wrap||5.019003|n +croak_no_mem|||n +croak_no_modify||5.013003|n +croak_nocontext|||vn +croak_popstack|||n +croak_sv||5.013001| +croak_xs_usage||5.010001|n +croak|||v +csighandler||5.009003|n +current_re_engine||| +curse||| +custom_op_desc||5.007003| +custom_op_get_field||| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len_flags||| +cv_clone_into||| +cv_clone||| +cv_const_sv_or_av|||n +cv_const_sv||5.003070|n +cv_dump||| +cv_forget_slab||| +cv_get_call_checker||5.013006| +cv_name||5.021005| +cv_set_call_checker_flags||5.021004| +cv_set_call_checker||5.013006| +cv_undef_flags||| +cv_undef||| +cvgv_from_hek||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.021008||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +defelem_target||| +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_ncmp||| +do_oddball||| +do_op_dump||5.006000| +do_open6||| +do_open9||5.006000| +do_open_raw||| +do_openn||5.007001| +do_open||5.003070| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +drand48_init_r|||n +drand48_r|||n +dump_all_perl||| +dump_all||5.006000| +dump_c_backtrace||| +dump_eval||5.006000| +dump_exec_pos||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +finalize_optree||| +finalize_op||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_default_stash||| +find_hash_subscript||| +find_in_my_stash||| +find_lexical_cv||| +find_runcv_where||| +find_runcv||5.008001| +find_rundefsv2||| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +fixup_errno_string||| +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident_maybe_lex||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form_short_octal_warning||| +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_c_backtrace||| +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_ANYOF_cp_list_for_ssc||| +get_and_check_backslash_N_name||| +get_aux_mg||| +get_av|5.006000||p +get_c_backtrace_dump||| +get_c_backtrace||| +get_context||5.006000|n +get_cvn_flags|5.009005||p +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_invlist_iter_addr|||n +get_invlist_offset_addr|||n +get_invlist_previous_index_addr|||n +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +gp_dup||| +gp_free||| +gp_ref||| +grok_atoUV|||n +grok_bin|5.007003||p +grok_bslash_N||| +grok_bslash_c||| +grok_bslash_o||| +grok_bslash_x||| +grok_hex|5.007003||p +grok_infnan||5.021004| +grok_number_flags||5.021002| +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_autoload_pvn||5.015004| +gv_autoload_pv||5.015004| +gv_autoload_sv||5.015004| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.003070| +gv_efullname4||5.006001| +gv_efullname||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmeth_internal||| +gv_fetchmeth_pv_autoload||5.015004| +gv_fetchmeth_pvn_autoload||5.015004| +gv_fetchmeth_pvn||5.015004| +gv_fetchmeth_pv||5.015004| +gv_fetchmeth_sv_autoload||5.015004| +gv_fetchmeth_sv||5.015004| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_pv_flags||5.015004| +gv_fetchmethod_pvn_flags||5.015004| +gv_fetchmethod_sv_flags||5.015004| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.003070| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_pvn||5.015004| +gv_init_pv||5.015004| +gv_init_svtype||| +gv_init_sv||5.015004| +gv_init||| +gv_is_in_main||| +gv_magicalize_isa||| +gv_magicalize||| +gv_name_set||5.009004| +gv_override||| +gv_setref||| +gv_stashpvn_internal||| +gv_stashpvn|5.003070||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsvpvn_cached||| +gv_stashsv||| +gv_try_downgrade||| +handle_regex_sets||| +he_dup||| +hek_dup||| +hfree_next_entry||| +hfreeentries||| +hsplit||| +hv_assert||| +hv_auxinit_internal|||n +hv_auxinit||| +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.003070| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.003070| +hv_exists||| +hv_fetch_ent||5.003070| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent_ret||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.003070| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.003070| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||| +hv_placeholders_set||5.009003| +hv_rand_set||5.018000| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.003070| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_constants||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +inplace_aassign||| +instr|||n +intro_my||5.004000| +intuit_method||| +intuit_more||| +invert||| +invlist_array|||n +invlist_clone||| +invlist_extend||| +invlist_highest|||n +invlist_is_iterating|||n +invlist_iterfinish|||n +invlist_iterinit|||n +invlist_iternext|||n +invlist_max|||n +invlist_previous_index|||n +invlist_set_len||| +invlist_set_previous_index|||n +invlist_trim|||n +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALNUM_lazy||5.021001| +isALPHANUMERIC||5.017008| +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +isFOO_lc||| +isFOO_utf8_lc||| +isGCB|||n +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isIDCONT||5.017008| +isIDFIRST_lazy||5.021001| +isIDFIRST||| +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSB||| +isSPACE||| +isUPPER||| +isUTF8_CHAR||5.021001| +isWB||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000| +is_handle_constructor|||n +is_invariant_string||5.021007|n +is_lvalue_sub||5.007001| +is_safe_syscall||5.019004| +is_ssc_worth_it|||n +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.017007| +is_uni_alnumc||5.017007| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_blank_lc||5.017002| +is_uni_blank||5.017002| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.017007| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_blank||5.017002| +is_utf8_char_buf||5.015008|n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +isinfnansv||| +isinfnan||5.021004|n +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_common||| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_cleararylen_p||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_copycallchecker||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdebugvar||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdebugvar||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setlvref||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||5.021001| +matcher_matches_sv||| +maybe_multimagic_gv||| +mayberelocate||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess_sv||5.013001| +mess||5.006000|v +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find_mglob||| +mg_findext|5.013008||pn +mg_find|||n +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical|||n +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002|n +minus_v||| +missingterm||| +mode_from_discipline||| +modkids||| +more_bodies||| +more_sv||| +moreswitches||| +move_proto_attr||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +multideref_stringify||| +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_bytes_to_utf8|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005|n +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_kid||| +my_lstat_flags||| +my_lstat||5.021008| +my_memcmp|||n +my_memset|||n +my_pclose||5.003070| +my_popen_list||5.007001| +my_popen||5.003070| +my_setenv||| +my_setlocale||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.021008| +my_strerror||5.021001| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB_x||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB_flags||5.015006| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||5.021006| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen_flags||5.015004| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMETHOP_internal||| +newMETHOP_named||5.021005| +newMETHOP||5.021005| +newMYSUB||5.017004| +newNULLLIST||| +newOP||| +newPADNAMELIST||5.021007|n +newPADNAMEouter||5.021007|n +newPADNAMEpvn||5.021007|n +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSTUB||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVavdefelem||| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpadname||5.017004| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP_AUX||5.021007| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_deffile||| +newXS_flags||5.009004| +newXS_len_flags||| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +noperl_die|||vn +not_a_number||| +not_incrementable||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_contextualize||5.013006| +op_convert_list||5.021006| +op_dump||5.006000| +op_free||| +op_integerize||| +op_linklist||5.013006| +op_lvalue_flags||| +op_lvalue||5.013007| +op_null||5.007002| +op_parent||5.021002|n +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_relocate_sv||| +op_scope||5.013007| +op_sibling_splice||5.021002|n +op_std_init||| +op_unscope||| +open_script||| +openn_cleanup||| +openn_setup||| +opmethod_stash||| +opslab_force_free||| +opslab_free_nopad||| +opslab_free||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||5.008001| +pad_add_name_pvn||5.015001| +pad_add_name_pvs||5.015001| +pad_add_name_pv||5.015001| +pad_add_name_sv||5.015001| +pad_add_weakref||| +pad_alloc_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||5.009003| +pad_findlex||| +pad_findmy_pvn||5.015001| +pad_findmy_pvs||5.015001| +pad_findmy_pv||5.015001| +pad_findmy_sv||5.015001| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||5.008001| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||5.008001| +padlist_dup||| +padlist_store||| +padname_dup||| +padname_free||| +padnamelist_dup||| +padnamelist_fetch||5.021007|n +padnamelist_free||| +padnamelist_store||5.021007| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_gv_stash_name||| +parse_ident||| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_lparen_question_flags||| +parse_stmtseq||5.013006| +parse_subsignature||| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free_nexttoke_ops||| +parser_free||| +path_is_searchable|||n +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +populate_ANYOF_from_invlist||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_hash|||n +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_charclass_bitmap_innards||| +put_code_point||| +put_range||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +quadmath_format_needed|||n +quadmath_format_single|||n +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.019001| +re_intuit_string||5.006000| +re_op_compile||| +realloc||5.007002|n +reentrant_free||5.021008| +reentrant_init||5.021008| +reentrant_retry||5.021008|vn +reentrant_size||5.021008| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.021008| +reg2Lanode||| +reg_check_named_buff_matched|||n +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment|||n +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly|||n +regdump_extflags||| +regdump_intflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regnode_guts||| +regpatws|||n +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reg||| +repeatcpy|||n +report_evil_fh||| +report_redefined_cv||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem_flags||5.011000| +save_aelem||5.004050| +save_aliased_sv||| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic_flags||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_strlen||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +search_const||| +seed||5.008001| +sequence_num||| +set_ANYOF_arg||| +set_caret_X||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +set_padlist|||n +setdefout||| +share_hek_flags||| +share_hek||5.004000| +should_warn_nl|||n +si_dup||| +sighandler|||n +simplify_sort||| +skipspace_flags||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +ssc_add_range||| +ssc_and||| +ssc_anything||| +ssc_clear_locale|||n +ssc_cp_and||| +ssc_finalize||| +ssc_init||| +ssc_intersection||| +ssc_is_anything|||n +ssc_is_cp_posixl_init|||n +ssc_or||| +ssc_union||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff|||n +sv_bless||| +sv_buf_to_ro||| +sv_buf_to_rw||| +sv_cat_decode||5.008001| +sv_catpv_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_copypv_flags||5.017002| +sv_copypv_nomg||5.017002| +sv_copypv||| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from_pvn||5.015004| +sv_derived_from_pv||5.015004| +sv_derived_from_sv||5.015004| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_display||| +sv_does_pvn||5.015004| +sv_does_pv||5.015004| +sv_does_sv||5.015004| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_get_backrefs||5.021008|n +sv_gets||5.003070| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8_nomg||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.021008|5.004000|p +sv_magicext_mglob||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy_flags||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_only_taint_gmagic|||n +sv_or_pv_pos_u2b||| +sv_peek||5.005000| +sv_pos_b2u_flags||5.019003| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_ref||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_resetpvn||| +sv_reset||| +sv_rvweaken||5.006000| +sv_sethek||| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.021008| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext|5.013008||p +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn_flags||5.017002| +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +swash_scan_list_line||| +swatch_get||| +sync_locale||5.021004| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow_p||| +toFOLD_uni||5.007003| +toFOLD_utf8||5.019001| +toFOLD||5.019001| +toLOWER_L1||5.019001| +toLOWER_LC||5.004000| +toLOWER_uni||5.007003| +toLOWER_utf8||5.015007| +toLOWER||| +toTITLE_uni||5.007003| +toTITLE_utf8||5.015007| +toTITLE||5.019001| +toUPPER_uni||5.007003| +toUPPER_utf8||5.015007| +toUPPER||| +to_byte_substr||| +to_lower_latin1|||n +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.015007| +to_utf8_lower||5.015007| +to_utf8_substr||| +to_utf8_title||5.015007| +to_utf8_upper||5.015007| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments_pv||| +too_many_arguments_pv||| +translate_substr_offsets|||n +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.003070| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000|n +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr_buf||5.015009| +utf8_to_uvchr||5.007001| +utf8_to_uvuni_buf||5.015009| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvoffuni_to_utf8_flags||5.019004| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +valid_utf8_to_uvchr||5.015009| +valid_utf8_to_uvuni||5.015009| +validate_proto||| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warn_sv||5.013001| +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +was_lvalue_sub||| +watch||| +whichsig_pvn||5.015004| +whichsig_pv||5.015004| +whichsig_sv||5.015004| +whichsig||| +win32_croak_not_implemented|||n +with_queued_errors||| +wrap_op_checker||5.015008| +write_to_stderr||| +xs_boot_epilog||| +xs_handshake|||vn +xs_version_bootcheck||| +yyerror_pvn||| +yyerror_pv||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while (<DATA>) { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef LONGSIZE +# define LONGSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef LONGSIZE +# define LONGSIZE 4 +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include <note.h> +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif + +#ifdef HAS_QUAD +# ifdef U64TYPE +# define WIDEST_UTYPE U64TYPE +# else +# define WIDEST_UTYPE Quad_t +# endif +#else +# define WIDEST_UTYPE U32 +#endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +/* Until we figure out how to support this in older perls... */ +#if (PERL_BCDVERSION >= 0x5008000) +#ifndef HeUTF8 +# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#elif (PERL_BCDVERSION > 0x5003000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# elif IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# else +# error "cannot define IV/UV formats" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif + +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif + +/* Some random bits for sv_unmagicext. These should probably be pulled in for + real and organized at some point */ +#ifndef HEf_SVKEY +# define HEf_SVKEY -2 +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +#else +# define MUTABLE_PTR(p) ((void *) (p)) +#endif + +#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) + +/* end of random bits */ +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#if !defined(mg_findext) +#if defined(NEED_mg_findext) +static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +static +#else +extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +#endif + +#define mg_findext DPPP_(my_mg_findext) +#define Perl_mg_findext DPPP_(my_mg_findext) + +#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) + +MAGIC * +DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { + if (sv) { + MAGIC *mg; + +#ifdef AvPAD_NAMELIST + assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); +#endif + + for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && mg->mg_virtual == vtbl) + return mg; + } + } + + return NULL; +} + +#endif +#endif + +#if !defined(sv_unmagicext) +#if defined(NEED_sv_unmagicext) +static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +static +#else +extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +#endif + +#ifdef sv_unmagicext +# undef sv_unmagicext +#endif +#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) +#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) + +#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) + +int +DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) +{ + MAGIC* mg; + MAGIC** mgp; + + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) + return 0; + mgp = &(SvMAGIC(sv)); + for (mg = *mgp; mg; mg = *mgp) { + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && virt == vtbl) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; + } + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } + return 0; +} + +#endif +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ + +#if (PERL_BCDVERSION >= 0x5006000) +#ifndef caller_cx + +# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) +static I32 +DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) +{ + I32 i; + + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT * const cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: + case CXt_FORMAT: + return i; + } + } + return i; +} +# endif + +# if defined(NEED_caller_cx) +static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +static +#else +extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +#endif + +#ifdef caller_cx +# undef caller_cx +#endif +#define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) +#define Perl_caller_cx DPPP_(my_caller_cx) + +#if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) + +const PERL_CONTEXT * +DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) +{ + register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); + register const PERL_CONTEXT *cx; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + + for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) + return NULL; + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + } + + cx = &ccstack[cxix]; + if (dbcxp) *dbcxp = cx; + + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the + field below is defined for any cx. */ + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; + } + + return cx; +} + +# endif +#endif /* caller_cx */ +#endif /* 5.6.0 */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%" UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%" UVxf "}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/cpan/dist/PathTools/t/Functions.t b/cpan/dist/PathTools/t/Functions.t new file mode 100644 index 00000000..122c529a --- /dev/null +++ b/cpan/dist/PathTools/t/Functions.t @@ -0,0 +1,19 @@ +#!/usr/bin/perl -w + +use Test::More tests => 15; +BEGIN {use_ok('File::Spec::Functions', ':ALL');} + +is(canonpath('a/b/c'), File::Spec->canonpath('a/b/c')); +is(case_tolerant(), File::Spec->case_tolerant()); +is(catdir(), File::Spec->catdir()); +is(catdir('a'), File::Spec->catdir('a')); +is(catdir('a','b'), File::Spec->catdir('a','b')); +is(catdir('a','b','c'), File::Spec->catdir('a','b','c')); +is(catfile(), File::Spec->catfile()); +is(catfile('a'), File::Spec->catfile('a')); +is(catfile('a','b'), File::Spec->catfile('a','b')); +is(catfile('a','b','c'), File::Spec->catfile('a','b','c')); +is(curdir(), File::Spec->curdir()); +is(devnull(), File::Spec->devnull()); +is(rootdir(), File::Spec->rootdir()); +is(updir(), File::Spec->updir()); diff --git a/cpan/dist/PathTools/t/Spec-taint.t b/cpan/dist/PathTools/t/Spec-taint.t new file mode 100644 index 00000000..ef4f1ee3 --- /dev/null +++ b/cpan/dist/PathTools/t/Spec-taint.t @@ -0,0 +1,17 @@ +#!./perl -Tw +# Testing File::Spec under taint mode. + +use strict; + +chdir 't' unless $ENV{PERL_CORE}; + +use File::Spec; +use lib File::Spec->catdir('t', 'lib'); +use Test::More tests => 2; + +use Scalar::Util qw/tainted/; + +my $ret; +eval { $ret = File::Spec->tmpdir }; +is( $@, '', "tmpdir should not explode under taint mode" ); +ok( !tainted($ret), "its return value should not be tainted" ); diff --git a/cpan/dist/PathTools/t/Spec.t b/cpan/dist/PathTools/t/Spec.t new file mode 100644 index 00000000..74c18aac --- /dev/null +++ b/cpan/dist/PathTools/t/Spec.t @@ -0,0 +1,841 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +require_ok('File::Spec'); + +require Cwd; + +my $vms_unix_rpt; + +if ($^O eq 'VMS') { + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + } +} + + +my $skip_exception = "Needs VMS::Filespec (and thus VMS)" ; + +eval { + require VMS::Filespec ; +} ; + +if ( $@ ) { + # Not pretty, but it allows testing of things not implemented solely + # on VMS. It might be better to change File::Spec::VMS to do this, + # making it more usable when running on (say) Unix but working with + # VMS paths. + eval qq- + sub File::Spec::VMS::vmsify { die "$skip_exception" } + sub File::Spec::VMS::unixify { die "$skip_exception" } + sub File::Spec::VMS::vmspath { die "$skip_exception" } + - ; + $INC{"VMS/Filespec.pm"} = 1 ; +} + +foreach (qw(Unix Win32 VMS OS2 Mac Epoc Cygwin)) { + require_ok("File::Spec::$_"); +} + +# Each element in this array is a single test. Storing them this way makes +# maintenance easy, and should be OK since perl should be pretty functional +# before these tests are run. + +my @tests = ( +# [ Function , Expected , Platform ] + +[ "Unix->case_tolerant()", '0' ], + +[ "Unix->catfile('a','b','c')", 'a/b/c' ], +[ "Unix->catfile('a','b','./c')", 'a/b/c' ], +[ "Unix->catfile('./a','b','c')", 'a/b/c' ], +[ "Unix->catfile('c')", 'c' ], +[ "Unix->catfile('./c')", 'c' ], +[ "Unix->catfile('a', 'b'.chr(0xaf))", 'a/b'.chr(0xaf) ], +($] >= 5.008 ? ( +[ "Unix->catfile('a', do { my \$x = 'b'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", 'a/b'.chr(0xaf) ], +) : ()), +[ "Unix->catfile(substr('foo', 2))", 'o' ], + +[ "Unix->splitpath('file')", ',,file' ], +[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], +[ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], +[ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], +[ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], +[ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], +[ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], +[ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ], +[ "Unix->splitpath('/././d1/')", ',/././d1/,' ], + +[ "Unix->catpath('','','file')", 'file' ], +[ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], +[ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], +[ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], +[ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], +[ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], +[ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], +[ "Unix->catpath('','/../../d1/','')", '/../../d1/' ], +[ "Unix->catpath('','/././d1/','')", '/././d1/' ], +[ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ], +[ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ], + +[ "Unix->splitdir('')", '' ], +[ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], +[ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], +[ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], +[ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], + +[ "Unix->catdir()", '' ], +[ "Unix->catdir('')", '/' ], +[ "Unix->catdir('/')", '/' ], +[ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], +[ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], +[ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ], +[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ], +# QNX is POSIXly special +[ "Unix->catdir('/','d2/d3')", ( $^O =~ m!^(nto|qnx)! ? '//d2/d3' : '/d2/d3' ) ], +[ "Unix->catdir('a', 'b'.chr(0xaf))", 'a/b'.chr(0xaf) ], +($] >= 5.008 ? ( +[ "Unix->catdir('a', do { my \$x = 'b'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", 'a/b'.chr(0xaf) ], +) : ()), + +[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], +[ "Unix->canonpath('')", '' ], +# rt.perl.org 27052 +[ "Unix->canonpath('a/../../b/c')", 'a/../../b/c' ], +[ "Unix->canonpath('/')", '/' ], +[ "Unix->canonpath('///')", '/' ], +[ "Unix->canonpath('/.')", '/' ], +[ "Unix->canonpath('/./')", '/' ], +[ "Unix->canonpath('///.')", '/' ], +[ "Unix->canonpath('///.///')", '/' ], +[ "Unix->canonpath('///..')", '/' ], +[ "Unix->canonpath('///..///')", '/' ], +[ "Unix->canonpath('///..///.///..///')", '/' ], +[ "Unix->canonpath('.')", '.' ], +[ "Unix->canonpath('.///')", '.' ], +[ "Unix->canonpath('.///.')", '.' ], +[ "Unix->canonpath('.///.///')", '.' ], +[ "Unix->canonpath('..')", '..' ], +[ "Unix->canonpath('..///')", '..' ], +[ "Unix->canonpath('../..')", '../..' ], +[ "Unix->canonpath('../../')", '../..' ], +[ "Unix->canonpath('..///.///..///')", '../..' ], +[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], +[ "Unix->canonpath('a/../../b/c')", 'a/../../b/c' ], +[ "Unix->canonpath('a///..///..///b////c')", 'a/../../b/c' ], +[ "Unix->canonpath('.///a///.///..///.///..///.///b///.////c///.')", 'a/../../b/c' ], +[ "Unix->canonpath('/a/./')", '/a' ], +[ "Unix->canonpath('/a/.')", '/a' ], +[ "Unix->canonpath('/../../')", '/' ], +[ "Unix->canonpath('/../..')", '/' ], +[ "Unix->canonpath('/foo', '/bar')", '/foo' ], +[ "Unix->canonpath('///a'.chr(0xaf))", '/a'.chr(0xaf) ], +($] >= 5.008 ? ( +[ "Unix->canonpath(do { my \$x = '///a'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", '/a'.chr(0xaf) ], +) : ()), + +[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], +[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], +#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('/.','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ], +#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/t1/t2/t3', '/')", 't1/t2/t3' ], +[ "Unix->abs2rel('/t1/t2/t3', '/t1')", 't2/t3' ], +[ "Unix->abs2rel('t1/t2/t3', 't1')", 't2/t3' ], +[ "Unix->abs2rel('t1/t2/t3', 't4')", '../t1/t2/t3' ], + [ "Unix->abs2rel('.', '.')", '.' ], + [ "Unix->abs2rel('/', '/')", '.' ], + [ "Unix->abs2rel('../t1', 't2/t3')", '../../../t1' ], + [ "Unix->abs2rel('t1', 't2/../t3')", '../t1' ], + +[ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], +[ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], +[ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], +[ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], +[ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], +[ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ], + +[ "Win32->case_tolerant()", '1' ], +[ "Win32->rootdir()", '\\' ], + +[ "Win32->splitpath('file')", ',,file' ], +[ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ], +[ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ], +[ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ], +[ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ], +[ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ], +[ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ], +[ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ], +[ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ], +[ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ], +[ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ], +[ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ], +[ "Win32->splitpath('file',1)", ',file,' ], +[ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ], +[ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ], + +[ "Win32->catpath('','','file')", 'file' ], +[ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ], +[ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ], +[ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ], +[ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ], +[ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ], +[ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ], +[ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ], +[ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ], +[ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ], +[ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ], +[ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ], +[ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ], +[ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ], +[ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ], +[ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ], + +[ "Win32->splitdir('')", '' ], +[ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ], +[ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ], +[ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ], +[ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ], + +[ "Win32->catdir()", '' ], +[ "Win32->catdir('')", '\\' ], +[ "Win32->catdir('/')", '\\' ], +[ "Win32->catdir('/', '../')", '\\' ], +[ "Win32->catdir('/', '..\\')", '\\' ], +[ "Win32->catdir('\\', '../')", '\\' ], +[ "Win32->catdir('\\', '..\\')", '\\' ], +[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ], +[ "Win32->catdir('\\d1\\','d2')", '\\d1\\d2' ], +[ "Win32->catdir('\\d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('\\d1','\\d2')", '\\d1\\d2' ], +[ "Win32->catdir('\\d1','\\d2\\')", '\\d1\\d2' ], +[ "Win32->catdir('','/d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','','/d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','//d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','','//d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], +[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], +[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], +[ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ], +[ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ], +#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], +[ "Win32->catdir('A:/')", 'A:\\' ], +[ "Win32->catdir('\\', 'foo')", '\\foo' ], +[ "Win32->catdir('','','..')", '\\' ], +[ "Win32->catdir('A:', 'foo')", 'A:\\foo' ], + +[ "Win32->catfile('a','b','c')", 'a\\b\\c' ], +[ "Win32->catfile('a','b','.\\c')", 'a\\b\\c' ], +[ "Win32->catfile('.\\a','b','c')", 'a\\b\\c' ], +[ "Win32->catfile('c')", 'c' ], +[ "Win32->catfile('.\\c')", 'c' ], +[ "Win32->catfile('a/..','../b')", '..\\b' ], +[ "Win32->catfile('A:', 'foo')", 'A:\\foo' ], + + +[ "Win32->canonpath('')", '' ], +[ "Win32->canonpath('a:')", 'A:' ], +[ "Win32->canonpath('A:f')", 'A:f' ], +[ "Win32->canonpath('A:/')", 'A:\\' ], +# rt.perl.org 27052 +[ "Win32->canonpath('a\\..\\..\\b\\c')", '..\\b\\c' ], +[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], +[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('////')", '\\' ], +[ "Win32->canonpath('//')", '\\' ], +[ "Win32->canonpath('/.')", '\\' ], +[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('//a/b/c/../d')", '\\\\a\\b\\d' ], +[ "Win32->canonpath('//a/b/c/../../d')",'\\\\a\\b\\d' ], +[ "Win32->canonpath('//a/b/c/.../d')", '\\\\a\\b\\d' ], +[ "Win32->canonpath('/a/b/c/../../d')", '\\a\\d' ], +[ "Win32->canonpath('/a/b/c/.../d')", '\\a\\d' ], +[ "Win32->canonpath('\\../temp\\')", '\\temp' ], +[ "Win32->canonpath('\\../')", '\\' ], +[ "Win32->canonpath('\\..\\')", '\\' ], +[ "Win32->canonpath('/../')", '\\' ], +[ "Win32->canonpath('/..\\')", '\\' ], +[ "Win32->canonpath('d1/../foo')", 'foo' ], + +# FakeWin32 subclass (see below) just sets CWD to C:\one\two and getdcwd('D') to D:\alpha\beta + +[ "FakeWin32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], +[ "FakeWin32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], +[ "FakeWin32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "FakeWin32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "FakeWin32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ], +[ "FakeWin32->abs2rel('../t4','/t1/t2/t3')", '..\\..\\..\\one\\t4' ], # Uses _cwd() +[ "FakeWin32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ], +[ "FakeWin32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ], +[ "FakeWin32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..' ], +[ "FakeWin32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ], +[ "FakeWin32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '\\\\a\\t1\\t2\\t4' ], +[ "FakeWin32->abs2rel('//a/t1/t2/t4','/t2/t3')", '\\\\a\\t1\\t2\\t4' ], +[ "FakeWin32->abs2rel('A:/t1/t2/t3','A:/t1/t2/t3')", '.' ], +[ "FakeWin32->abs2rel('A:/t1/t2/t3/t4','A:/t1/t2/t3')", 't4' ], +[ "FakeWin32->abs2rel('A:/t1/t2/t3','A:/t1/t2/t3/t4')", '..' ], +[ "FakeWin32->abs2rel('A:/t1/t2/t3','B:/t1/t2/t3')", 'A:\\t1\\t2\\t3' ], +[ "FakeWin32->abs2rel('A:/t1/t2/t3/t4','B:/t1/t2/t3')", 'A:\\t1\\t2\\t3\\t4' ], +[ "FakeWin32->abs2rel('E:/foo/bar/baz')", 'E:\\foo\\bar\\baz' ], +[ "FakeWin32->abs2rel('C:/one/two/three')", 'three' ], +[ "FakeWin32->abs2rel('C:\\Windows\\System32', 'C:\\')", 'Windows\System32' ], +[ "FakeWin32->abs2rel('\\\\computer2\\share3\\foo.txt', '\\\\computer2\\share3')", 'foo.txt' ], +[ "FakeWin32->abs2rel('C:\\one\\two\\t\\asd1\\', 't\\asd\\')", '..\\asd1' ], +[ "FakeWin32->abs2rel('\\one\\two', 'A:\\foo')", 'C:\\one\\two' ], + +[ "FakeWin32->rel2abs('temp','C:/')", 'C:\\temp' ], +[ "FakeWin32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ], +[ "FakeWin32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ], +[ "FakeWin32->rel2abs('../','C:/')", 'C:\\' ], +[ "FakeWin32->rel2abs('../','C:/a')", 'C:\\' ], +[ "FakeWin32->rel2abs('\\foo','C:/a')", 'C:\\foo' ], +[ "FakeWin32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], +[ "FakeWin32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], +[ "FakeWin32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ], +[ "FakeWin32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work' ], +[ "FakeWin32->rel2abs('D:foo.txt')", 'D:\\alpha\\beta\\foo.txt' ], + +[ "VMS->case_tolerant()", '1' ], + +[ "VMS->catfile('a','b','c')", $vms_unix_rpt ? 'a/b/c' : '[.a.b]c' ], +[ "VMS->catfile('a','b','[]c')", $vms_unix_rpt ? 'a/b/c' : '[.a.b]c' ], +[ "VMS->catfile('[.a]','b','c')", $vms_unix_rpt ? 'a/b/c' : '[.a.b]c' ], +[ "VMS->catfile('a/b/','c')", $vms_unix_rpt ? 'a/b/c' : '[.a.b]c' ], +[ "VMS->catfile('c')", 'c' ], +[ "VMS->catfile('[]c')", 'c' ], + +[ "VMS->catfile('0','b','c')", $vms_unix_rpt ? '0/b/c' : '[.0.b]c' ], +[ "VMS->catfile('a','0','c')", $vms_unix_rpt ? 'a/0/c' : '[.a.0]c' ], +[ "VMS->catfile('a','b','0')", $vms_unix_rpt ? 'a/b/0' : '[.a.b]0' ], +[ "VMS->catfile('0','0','c')", $vms_unix_rpt ? '0/0/c' : '[.0.0]c' ], +[ "VMS->catfile('a','0','0')", $vms_unix_rpt ? 'a/0/0' : '[.a.0]0' ], +[ "VMS->catfile('0','b','0')", $vms_unix_rpt ? '0/b/0' : '[.0.b]0' ], +[ "VMS->catfile('0','0','0')", $vms_unix_rpt ? '0/0/0' : '[.0.0]0' ], + + +[ "VMS->splitpath('file')", ',,file' ], +[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], +[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], +[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], +[ "VMS->splitpath('d1/d2/d3/file')", + $vms_unix_rpt ? ',d1/d2/d3/,file' : ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('/d1/d2/d3/file')", + $vms_unix_rpt ? ',/d1/d2/d3/,file' : 'd1:,[d2.d3],file' ], +[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], + +[ "VMS->splitpath('[]')", ',[],' ], +[ "VMS->splitpath('[-]')", ',[-],' ], +[ "VMS->splitpath('[]file')", ',[],file' ], +[ "VMS->splitpath('[-]file')", ',[-],file' ], +[ "VMS->splitpath('')", ',,' ], +[ "VMS->splitpath('0')", ',,0' ], +[ "VMS->splitpath('[0]')", ',[0],' ], +[ "VMS->splitpath('[.0]')", ',[.0],' ], +[ "VMS->splitpath('[0.0.0]')", ',[0.0.0],' ], +[ "VMS->splitpath('[.0.0.0]')", ',[.0.0.0],' ], +[ "VMS->splitpath('[0]0')", ',[0],0' ], +[ "VMS->splitpath('[0.0.0]0')", ',[0.0.0],0' ], +[ "VMS->splitpath('[.0.0.0]0')", ',[.0.0.0],0' ], +[ "VMS->splitpath('0/0')", $vms_unix_rpt ? ',0/,0' : ',[.0],0' ], +[ "VMS->splitpath('0/0/0')", $vms_unix_rpt ? ',0/0/,0' : ',[.0.0],0' ], +[ "VMS->splitpath('/0/0')", $vms_unix_rpt ? ',/0/,0' : '0:,[000000],0' ], +[ "VMS->splitpath('/0/0/0')", $vms_unix_rpt ? ',/0/0/,0' : '0:,[0],0' ], +[ "VMS->splitpath('d1',1)", ',d1,' ], +# $no_file tests +[ "VMS->splitpath('[d1.d2.d3]',1)", ',[d1.d2.d3],' ], +[ "VMS->splitpath('[.d1.d2.d3]',1)", ',[.d1.d2.d3],' ], +[ "VMS->splitpath('d1/d2/d3',1)", $vms_unix_rpt ? ',d1/d2/d3,' : ',[.d1.d2.d3],' ], +[ "VMS->splitpath('/d1/d2/d3',1)", $vms_unix_rpt ? ',/d1/d2/d3,' : 'd1:,[d2.d3],' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]',1)", 'node::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]',1)", 'node"access_spec"::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('[]',1)", ',[],' ], +[ "VMS->splitpath('[-]',1)", ',[-],' ], +[ "VMS->splitpath('',1)", ',,' ], +[ "VMS->splitpath('0',1)", ',0,' ], +[ "VMS->splitpath('[0]',1)", ',[0],' ], +[ "VMS->splitpath('[.0]',1)", ',[.0],' ], +[ "VMS->splitpath('[0.0.0]',1)", ',[0.0.0],' ], +[ "VMS->splitpath('[.0.0.0]',1)", ',[.0.0.0],' ], +[ "VMS->splitpath('0/0',1)", $vms_unix_rpt ? ',0/0,' : ',[.0.0],' ], +[ "VMS->splitpath('0/0/0',1)", $vms_unix_rpt ? ',0/0/0,' : ',[.0.0.0],' ], +[ "VMS->splitpath('/0/0',1)", $vms_unix_rpt ? ',/0/0,' : '0:,[000000.0],' ], +[ "VMS->splitpath('/0/0/0',1)", $vms_unix_rpt ? ',/0/0/0,' : '0:,[0.0],' ], + +[ "VMS->catpath('','','file')", 'file' ], +[ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], +[ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], +[ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], +[ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], +[ "VMS->catpath('','d1/d2/d3','file')", + $vms_unix_rpt ? 'd1/d2/d3/file' : '[.d1.d2.d3]file' ], +[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], +[ "VMS->catpath('v','','file')", 'v:file' ], +[ "VMS->catpath('v','w:[d1.d2.d3]','file')", 'v:[d1.d2.d3]file' ], +[ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], +[ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], +[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], +[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ], + +[ "VMS->canonpath('')", '' ], +[ "VMS->canonpath('volume:[d1]file')", $vms_unix_rpt ? '/volume/d1/file' : 'volume:[d1]file' ], +[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", $vms_unix_rpt ? '/volume/d2/d3/' : 'volume:[d2.d3]' ], +[ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", $vms_unix_rpt ? '/volume/d1/d2.dir.1' : 'volume:[d1]d2.dir;1' ], +[ "VMS->canonpath('volume:[d1.d2.d3]file.txt')", $vms_unix_rpt ? '/volume/d1/d2/d3/file.txt' : 'volume:[d1.d2.d3]file.txt' ], +[ "VMS->canonpath('[d1.d2.d3]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/d2/d3/file.txt' : '[d1.d2.d3]file.txt' ], +[ "VMS->canonpath('volume:[-.d1.d2.d3]file.txt')", $vms_unix_rpt ? '/volume/../d1/d2/d3/file.txt' : 'volume:[-.d1.d2.d3]file.txt' ], +[ "VMS->canonpath('[-.d1.d2.d3]file.txt')", $vms_unix_rpt ? '../d1/d2/d3/file.txt' : '[-.d1.d2.d3]file.txt' ], +[ "VMS->canonpath('volume:[--.d1.d2.d3]file.txt')", $vms_unix_rpt ? '/volume/../../d1/d2/d3/file.txt' : 'volume:[--.d1.d2.d3]file.txt' ], +[ "VMS->canonpath('[--.d1.d2.d3]file.txt')", $vms_unix_rpt ? '../../d1/d2/d3/file.txt' : '[--.d1.d2.d3]file.txt' ], +[ "VMS->canonpath('volume:[d1.-.d2.d3]file.txt')", $vms_unix_rpt ? '/volume/d2/d3/file.txt' : 'volume:[d2.d3]file.txt' ], +[ "VMS->canonpath('[d1.-.d2.d3]file.txt')", $vms_unix_rpt ? '/sys$disk/d2/d3/file.txt' : '[d2.d3]file.txt' ], +[ "VMS->canonpath('volume:[d1.--.d2.d3]file.txt')", $vms_unix_rpt ? '/volume/../d2/d3/file.txt' : 'volume:[-.d2.d3]file.txt' ], +[ "VMS->canonpath('[d1.--.d2.d3]file.txt')", $vms_unix_rpt ? '../d2/d3/file.txt' : '[-.d2.d3]file.txt' ], +[ "VMS->canonpath('volume:[d1.d2.-.d3]file.txt')", $vms_unix_rpt ? '/volume/d1/d3/file.txt' : 'volume:[d1.d3]file.txt' ], +[ "VMS->canonpath('[d1.d2.-.d3]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/d3/file.txt' : '[d1.d3]file.txt' ], +[ "VMS->canonpath('volume:[d1.d2.--.d3]file.txt')", $vms_unix_rpt ? '/volume/d3/file.txt' : 'volume:[d3]file.txt' ], +[ "VMS->canonpath('[d1.d2.--.d3]file.txt')", $vms_unix_rpt ? '/sys$disk/d3/file.txt' : '[d3]file.txt' ], +[ "VMS->canonpath('volume:[d1.d2.d3.-]file.txt')", $vms_unix_rpt ? '/volume/d1/d2/file.txt' : 'volume:[d1.d2]file.txt' ], +[ "VMS->canonpath('[d1.d2.d3.-]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/d2/file.txt' : '[d1.d2]file.txt' ], +[ "VMS->canonpath('volume:[d1.d2.d3.--]file.txt')", $vms_unix_rpt ? '/volume/d1/file.txt' : 'volume:[d1]file.txt' ], +[ "VMS->canonpath('[d1.d2.d3.--]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/file.txt' : '[d1]file.txt' ], +[ "VMS->canonpath('volume:[d1.000000.][000000.][d3.--]file.txt')", $vms_unix_rpt ? '/volume/d1/file.txt' + : 'volume:[d1]file.txt' ], +[ "VMS->canonpath('[d1.000000.][000000.][d3.--]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/file.txt' + : '[d1]file.txt' ], +[ "VMS->canonpath('volume:[d1.000000.][000000.][d2.000000]file.txt')", $vms_unix_rpt ? '/volume/d1/000000/d2/000000/file.txt' + : 'volume:[d1.000000.d2.000000]file.txt' ], +[ "VMS->canonpath('[d1.000000.][000000.][d2.000000]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/000000/d2/000000/file.txt' + : '[d1.000000.d2.000000]file.txt' ], +[ "VMS->canonpath('volume:[d1.000000.][000000.][d3.--.000000]file.txt')", $vms_unix_rpt ? '/volume/d1/000000/file.txt' + : 'volume:[d1.000000]file.txt' ], +[ "VMS->canonpath('[d1.000000.][000000.][d3.--.000000]file.txt')", $vms_unix_rpt ? '/sys$disk/d1/000000/file.txt' + : '[d1.000000]file.txt' ], +[ "VMS->canonpath('volume:[d1.000000.][000000.][-.-.000000]file.txt')", $vms_unix_rpt ? '/volume/file.txt' + : 'volume:[000000]file.txt' ], +[ "VMS->canonpath('[d1.000000.][000000.][--.-.000000]file.txt')", $vms_unix_rpt ? '../file.txt' : '[-.000000]file.txt' ], +[ "VMS->canonpath('[d1.d2.--]file')", $vms_unix_rpt ? '../file.txt' : '[000000]file' ], +# During the Perl 5.8 era, FS::Unix stopped eliminating redundant path elements, so mimic that here. +[ "VMS->canonpath('a/../../b/c.dat')", $vms_unix_rpt ? 'a/../../b/c.dat' : '[-.b]c.dat' ], +[ "VMS->canonpath('^<test^.new.-.caret^ escapes^>')", '^<test^.new.-.caret^ escapes^>' ], + +[ "VMS->splitdir('')", '' ], +[ "VMS->splitdir('[]')", '' ], +[ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ], +[ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ], +[ "VMS->splitdir('.d1.d2.d3')", 'd1,d2,d3' ], +[ "VMS->splitdir('[.d1.d2.d3]')", 'd1,d2,d3' ], +[ "VMS->splitdir('.-.d2.d3')", '-,d2,d3' ], +[ "VMS->splitdir('[.-.d2.d3]')", '-,d2,d3' ], +[ "VMS->splitdir('[d1.d2]')", 'd1,d2' ], +[ "VMS->splitdir('[d1-.--d2]')", 'd1-,--d2' ], +[ "VMS->splitdir('[d1---.-.d2]')", 'd1---,-,d2' ], +[ "VMS->splitdir('[d1.---.d2]')", 'd1,-,-,-,d2' ], +[ "VMS->splitdir('[d1---d2]')", 'd1---d2' ], +[ "VMS->splitdir('[d1.][000000.d2]')", 'd1,d2' ], +[ "VMS->splitdir('[.d1.d2^.d3]')", 'd1,d2^.d3' ], + +[ "VMS->catdir('')", '' ], +[ "VMS->catdir('foo')", $vms_unix_rpt ? 'foo' : '[.foo]' ], +[ "VMS->catdir('d1','d2','d3')", $vms_unix_rpt ? 'd1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('d1','d2/','d3')", $vms_unix_rpt ? 'd1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('','d1','d2','d3')",$vms_unix_rpt ? '/d1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('','-','d2','d3')", $vms_unix_rpt ? '-/d2/d3' : '[-.d2.d3]' ], +[ "VMS->catdir('','-','','d3')", $vms_unix_rpt ? '-/d3' : '[-.d3]' ], +[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", $vms_unix_rpt ? 'dir/d2/d3' + : '[.dir.d2.d3]' ], +[ "VMS->catdir('[.name]')", $vms_unix_rpt ? 'name/' : '[.name]' ], +[ "VMS->catdir('[.name]','[.name]')", $vms_unix_rpt ? 'name/name' :'[.name.name]' ], +[ "VMS->catdir('/a/b/c','[-]')", $vms_unix_rpt ? '/a/b/c/..' : 'a:[b]'], +[ "VMS->catdir('a:[b.c]','..')", $vms_unix_rpt ? '/a/b/c/..' : 'a:[b]'], + +[ "VMS->abs2rel('node::volume:[t1.t2.t3]','node::volume:[t1.t2.t3]')", $vms_unix_rpt ? './' : '[]' ], +[ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", $vms_unix_rpt ? '/node//volume/t1/t2/t3/' : 'node::volume:[t1.t2.t3]' ], +[ "VMS->abs2rel('node::volume:[t1.t2.t4]','node::volume:[t1.t2.t3]')", $vms_unix_rpt ? '../t4/' : '[-.t4]' ], +[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", $vms_unix_rpt ? '/node//volume/t1/t2/t4/' : 'node::volume:[t1.t2.t4]' ], +[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", $vms_unix_rpt ? './' : '[]' ], +[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ], +[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2]')", $vms_unix_rpt ? 't3/file' : '[.t3]file' ], +[ "VMS->abs2rel('v:[t1.t2.t3]file','v:[t1.t2]')", $vms_unix_rpt ? 't3/file' : '[.t3]file' ], +[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", $vms_unix_rpt ? '../t4/' : '[-.t4]' ], +[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", $vms_unix_rpt ? '../file' : '[-]file' ], +[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", $vms_unix_rpt ? 't4/' : '[.t4]' ], +[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", $vms_unix_rpt ? '../../../t4/t5/t6/' : '[---.t4.t5.t6]' ], +[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", $vms_unix_rpt ? '../../../' : '[---]' ], +[ "VMS->abs2rel('a:[t1.t2.t4]','a:[t1.t2.t3]')", $vms_unix_rpt ? '../t4/' : '[-.t4]' ], +[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", $vms_unix_rpt ? '/a/t1/t2/t4/' : 'a:[t1.t2.t4]' ], +[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", $vms_unix_rpt ? '../../../b/' : '[---.b]' ], + +[ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", $vms_unix_rpt ? '/sys$disk/t1/t2/t3/t4/' : '[t1.t2.t3.t4]' ], +[ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", $vms_unix_rpt ? '/sys$disk/t1/t2/t3/t4/t5/' : '[t1.t2.t3.t4.t5]' ], +[ "VMS->rel2abs('[]','[t1.t2.t3]')", $vms_unix_rpt ? '/sys$disk/t1/t2/t3/' : '[t1.t2.t3]' ], +[ "VMS->rel2abs('[-]','[t1.t2.t3]')", $vms_unix_rpt ? '/sys$disk/t1/t2/' : '[t1.t2]' ], +[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", $vms_unix_rpt ? '/sys$disk/t1/t2/t4/' : '[t1.t2.t4]' ], +[ "VMS->rel2abs('[t1]','[t1.t2.t3]')", $vms_unix_rpt ? '/sys$disk/t1/' : '[t1]' ], + +[ "VMS->file_name_is_absolute('foo:')", '1' ], +[ "VMS->file_name_is_absolute('foo:bar.dat')", '1' ], +[ "VMS->file_name_is_absolute('foo:[000000]bar.dat')", '1' ], + +[ "OS2->case_tolerant()", '1' ], + +[ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], + +[ "OS2->catfile('a','b','c')", 'a/b/c' ], +[ "OS2->catfile('a','b','./c')", 'a/b/c' ], +[ "OS2->catfile('./a','b','c')", 'a/b/c' ], +[ "OS2->catfile('c')", 'c' ], +[ "OS2->catfile('./c')", 'c' ], + +[ "OS2->catdir('/', '../')", '/' ], +[ "OS2->catdir('/', '..\\')", '/' ], +[ "OS2->catdir('\\', '../')", '/' ], +[ "OS2->catdir('\\', '..\\')", '/' ], + +[ "Mac->case_tolerant()", '1' ], + +[ "Mac->catpath('','','')", '' ], +[ "Mac->catpath('',':','')", ':' ], +[ "Mac->catpath('','::','')", '::' ], + +[ "Mac->catpath('hd','','')", 'hd:' ], +[ "Mac->catpath('hd:','','')", 'hd:' ], +[ "Mac->catpath('hd:',':','')", 'hd:' ], +[ "Mac->catpath('hd:','::','')", 'hd::' ], + +[ "Mac->catpath('hd','','file')", 'hd:file' ], +[ "Mac->catpath('hd',':','file')", 'hd:file' ], +[ "Mac->catpath('hd','::','file')", 'hd::file' ], +[ "Mac->catpath('hd',':::','file')", 'hd:::file' ], + +[ "Mac->catpath('hd:','',':file')", 'hd:file' ], +[ "Mac->catpath('hd:',':',':file')", 'hd:file' ], +[ "Mac->catpath('hd:','::',':file')", 'hd::file' ], +[ "Mac->catpath('hd:',':::',':file')", 'hd:::file' ], + +[ "Mac->catpath('hd:','d1','file')", 'hd:d1:file' ], +[ "Mac->catpath('hd:',':d1:',':file')", 'hd:d1:file' ], +[ "Mac->catpath('hd:','hd:d1','')", 'hd:d1:' ], + +[ "Mac->catpath('','d1','')", ':d1:' ], +[ "Mac->catpath('',':d1','')", ':d1:' ], +[ "Mac->catpath('',':d1:','')", ':d1:' ], + +[ "Mac->catpath('','d1','file')", ':d1:file' ], +[ "Mac->catpath('',':d1:',':file')", ':d1:file' ], + +[ "Mac->catpath('','','file')", 'file' ], +[ "Mac->catpath('','',':file')", 'file' ], # ! +[ "Mac->catpath('',':',':file')", ':file' ], # ! + + +[ "Mac->splitpath(':')", ',:,' ], +[ "Mac->splitpath('::')", ',::,' ], +[ "Mac->splitpath(':::')", ',:::,' ], + +[ "Mac->splitpath('file')", ',,file' ], +[ "Mac->splitpath(':file')", ',:,file' ], + +[ "Mac->splitpath('d1',1)", ',:d1:,' ], # dir, not volume +[ "Mac->splitpath(':d1',1)", ',:d1:,' ], +[ "Mac->splitpath(':d1:',1)", ',:d1:,' ], +[ "Mac->splitpath(':d1:')", ',:d1:,' ], +[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], +[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], +[ "Mac->splitpath(':d1:file')", ',:d1:,file' ], +[ "Mac->splitpath('::d1:file')", ',::d1:,file' ], + +[ "Mac->splitpath('hd:', 1)", 'hd:,,' ], +[ "Mac->splitpath('hd:')", 'hd:,,' ], +[ "Mac->splitpath('hd:d1:d2:')", 'hd:,:d1:d2:,' ], +[ "Mac->splitpath('hd:d1:d2',1)", 'hd:,:d1:d2:,' ], +[ "Mac->splitpath('hd:d1:d2:file')", 'hd:,:d1:d2:,file' ], +[ "Mac->splitpath('hd:d1:d2::file')", 'hd:,:d1:d2::,file' ], +[ "Mac->splitpath('hd::d1:d2:file')", 'hd:,::d1:d2:,file' ], # invalid path +[ "Mac->splitpath('hd:file')", 'hd:,,file' ], + +[ "Mac->splitdir()", '' ], +[ "Mac->splitdir('')", '' ], +[ "Mac->splitdir(':')", ':' ], +[ "Mac->splitdir('::')", '::' ], +[ "Mac->splitdir(':::')", '::,::' ], +[ "Mac->splitdir(':::d1:d2')", '::,::,d1,d2' ], + +[ "Mac->splitdir(':d1:d2:d3::')", 'd1,d2,d3,::'], +[ "Mac->splitdir(':d1:d2:d3:')", 'd1,d2,d3' ], +[ "Mac->splitdir(':d1:d2:d3')", 'd1,d2,d3' ], + +# absolute paths in splitdir() work, but you'd better use splitpath() +[ "Mac->splitdir('hd:')", 'hd:' ], +[ "Mac->splitdir('hd::')", 'hd:,::' ], # invalid path, but it works +[ "Mac->splitdir('hd::d1:')", 'hd:,::,d1' ], # invalid path, but it works +[ "Mac->splitdir('hd:d1:d2:::')", 'hd:,d1,d2,::,::' ], +[ "Mac->splitdir('hd:d1:d2::')", 'hd:,d1,d2,::' ], +[ "Mac->splitdir('hd:d1:d2:')", 'hd:,d1,d2' ], +[ "Mac->splitdir('hd:d1:d2')", 'hd:,d1,d2' ], +[ "Mac->splitdir('hd:d1::d2::')", 'hd:,d1,::,d2,::' ], + +[ "Mac->catdir()", '' ], +[ "Mac->catdir(':')", ':' ], + +[ "Mac->catdir(':', ':')", ':' ], +[ "Mac->catdir(':', '')", ':' ], + +[ "Mac->catdir(':', '::')", '::' ], + +[ "Mac->catdir('::', '')", '::' ], +[ "Mac->catdir('::', ':')", '::' ], + +[ "Mac->catdir('::', '::')", ':::' ], + +[ "Mac->catdir(':d1')", ':d1:' ], +[ "Mac->catdir(':d1:')", ':d1:' ], +[ "Mac->catdir(':d1','d2')", ':d1:d2:' ], +[ "Mac->catdir(':d1',':d2')", ':d1:d2:' ], +[ "Mac->catdir(':d1',':d2:')", ':d1:d2:' ], +[ "Mac->catdir(':d1',':d2::')", ':d1:d2::' ], +[ "Mac->catdir(':',':d1',':d2')", ':d1:d2:' ], +[ "Mac->catdir('::',':d1',':d2')", '::d1:d2:' ], +[ "Mac->catdir('::','::',':d1',':d2')", ':::d1:d2:' ], +[ "Mac->catdir(':',':',':d1',':d2')", ':d1:d2:' ], +[ "Mac->catdir('::',':',':d1',':d2')", '::d1:d2:' ], + +[ "Mac->catdir('d1')", ':d1:' ], +[ "Mac->catdir('d1','d2','d3')", ':d1:d2:d3:' ], +[ "Mac->catdir('d1','d2/','d3')", ':d1:d2/:d3:' ], +[ "Mac->catdir('d1','',':d2')", ':d1:d2:' ], +[ "Mac->catdir('d1',':',':d2')", ':d1:d2:' ], +[ "Mac->catdir('d1','::',':d2')", ':d1::d2:' ], +[ "Mac->catdir('d1',':::',':d2')", ':d1:::d2:' ], +[ "Mac->catdir('d1','::','::',':d2')", ':d1:::d2:' ], +[ "Mac->catdir('d1','d2')", ':d1:d2:' ], +[ "Mac->catdir('d1','d2', '')", ':d1:d2:' ], +[ "Mac->catdir('d1','d2', ':')", ':d1:d2:' ], +[ "Mac->catdir('d1','d2', '::')", ':d1:d2::' ], +[ "Mac->catdir('d1','d2','','')", ':d1:d2:' ], +[ "Mac->catdir('d1','d2',':','::')", ':d1:d2::' ], +[ "Mac->catdir('d1','d2','::','::')", ':d1:d2:::' ], +[ "Mac->catdir('d1',':d2')", ':d1:d2:' ], +[ "Mac->catdir('d1',':d2:')", ':d1:d2:' ], + +[ "Mac->catdir('hd:',':d1')", 'hd:d1:' ], +[ "Mac->catdir('hd:d1:',':d2')", 'hd:d1:d2:' ], +[ "Mac->catdir('hd:','d1')", 'hd:d1:' ], +[ "Mac->catdir('hd:d1:',':d2')", 'hd:d1:d2:' ], +[ "Mac->catdir('hd:d1:',':d2:')", 'hd:d1:d2:' ], + +[ "Mac->catfile()", '' ], +[ "Mac->catfile('')", '' ], +[ "Mac->catfile(':')", ':' ], +[ "Mac->catfile(':', '')", ':' ], + +[ "Mac->catfile('d1','d2','file')", ':d1:d2:file' ], +[ "Mac->catfile('d1','d2',':file')", ':d1:d2:file' ], +[ "Mac->catfile('file')", 'file' ], +[ "Mac->catfile(':', 'file')", ':file' ], + +[ "Mac->canonpath('')", '' ], +[ "Mac->canonpath(':')", ':' ], +[ "Mac->canonpath('::')", '::' ], +[ "Mac->canonpath('a::')", 'a::' ], +[ "Mac->canonpath(':a::')", ':a::' ], + +[ "Mac->abs2rel('hd:d1:d2:','hd:d1:d2:')", ':' ], +[ "Mac->abs2rel('hd:d1:d2:','hd:d1:d2:file')", ':' ], # ignore base's file portion +[ "Mac->abs2rel('hd:d1:d2:file','hd:d1:d2:')", ':file' ], +[ "Mac->abs2rel('hd:d1:','hd:d1:d2:')", '::' ], +[ "Mac->abs2rel('hd:d3:','hd:d1:d2:')", ':::d3:' ], +[ "Mac->abs2rel('hd:d3:','hd:d1:d2::')", '::d3:' ], +[ "Mac->abs2rel('hd:d1:d4:d5:','hd:d1::d2:d3::')", '::d1:d4:d5:' ], +[ "Mac->abs2rel('hd:d1:d4:d5:','hd:d1::d2:d3:')", ':::d1:d4:d5:' ], # first, resolve updirs in base +[ "Mac->abs2rel('hd:d1:d3:','hd:d1:d2:')", '::d3:' ], +[ "Mac->abs2rel('hd:d1::d3:','hd:d1:d2:')", ':::d3:' ], +[ "Mac->abs2rel('hd:d3:','hd:d1:d2:')", ':::d3:' ], # same as above +[ "Mac->abs2rel('hd:d1:d2:d3:','hd:d1:d2:')", ':d3:' ], +[ "Mac->abs2rel('hd:d1:d2:d3::','hd:d1:d2:')", ':d3::' ], +[ "Mac->abs2rel('hd1:d3:d4:d5:','hd2:d1:d2:')", 'hd1:d3:d4:d5:'], # volume mismatch +[ "Mac->abs2rel('hd:','hd:d1:d2:')", ':::' ], + +[ "Mac->rel2abs(':d3:','hd:d1:d2:')", 'hd:d1:d2:d3:' ], +[ "Mac->rel2abs(':d3:d4:','hd:d1:d2:')", 'hd:d1:d2:d3:d4:' ], +[ "Mac->rel2abs('','hd:d1:d2:')", '' ], +[ "Mac->rel2abs('::','hd:d1:d2:')", 'hd:d1:d2::' ], +[ "Mac->rel2abs('::','hd:d1:d2:file')", 'hd:d1:d2::' ],# ignore base's file portion +[ "Mac->rel2abs(':file','hd:d1:d2:')", 'hd:d1:d2:file' ], +[ "Mac->rel2abs('::file','hd:d1:d2:')", 'hd:d1:d2::file' ], +[ "Mac->rel2abs('::d3:','hd:d1:d2:')", 'hd:d1:d2::d3:' ], +[ "Mac->rel2abs('hd:','hd:d1:d2:')", 'hd:' ], # path already absolute +[ "Mac->rel2abs('hd:d3:file','hd:d1:d2:')", 'hd:d3:file' ], +[ "Mac->rel2abs('hd:d3:','hd:d1:file')", 'hd:d3:' ], + +[ "Epoc->case_tolerant()", '1' ], + +[ "Epoc->canonpath('')", '' ], +[ "Epoc->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], +[ "Epoc->canonpath('/./')", '/' ], +[ "Epoc->canonpath('/a/./')", '/a' ], + +# XXX Todo, copied from Unix, but fail. Should they? 2003-07-07 Tels +#[ "Epoc->canonpath('/a/.')", '/a' ], +#[ "Epoc->canonpath('/.')", '/' ], + +[ "Cygwin->case_tolerant()", '1' ], +[ "Cygwin->catfile('a','b','c')", 'a/b/c' ], +[ "Cygwin->catfile('a','b','./c')", 'a/b/c' ], +[ "Cygwin->catfile('./a','b','c')", 'a/b/c' ], +[ "Cygwin->catfile('c')", 'c' ], +[ "Cygwin->catfile('./c')", 'c' ], + +[ "Cygwin->splitpath('file')", ',,file' ], +[ "Cygwin->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], +[ "Cygwin->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], +[ "Cygwin->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], +[ "Cygwin->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], +[ "Cygwin->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], +[ "Cygwin->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], +[ "Cygwin->splitpath('/../../d1/')", ',/../../d1/,' ], +[ "Cygwin->splitpath('/././d1/')", ',/././d1/,' ], + +[ "Cygwin->catpath('','','file')", 'file' ], +[ "Cygwin->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], +[ "Cygwin->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], +[ "Cygwin->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], +[ "Cygwin->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], +[ "Cygwin->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], +[ "Cygwin->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], +[ "Cygwin->catpath('','/../../d1/','')", '/../../d1/' ], +[ "Cygwin->catpath('','/././d1/','')", '/././d1/' ], +[ "Cygwin->catpath('d1','d2/d3/','')", 'd2/d3/' ], +[ "Cygwin->catpath('d1','d2','d3/')", 'd2/d3/' ], + +[ "Cygwin->splitdir('')", '' ], +[ "Cygwin->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], +[ "Cygwin->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], +[ "Cygwin->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], +[ "Cygwin->splitdir('d1/d2/d3')", 'd1,d2,d3' ], + +[ "Cygwin->catdir()", '' ], +[ "Cygwin->catdir('/')", '/' ], +[ "Cygwin->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], +[ "Cygwin->catdir('d1','d2','d3','')", 'd1/d2/d3' ], +[ "Cygwin->catdir('','d1','d2','d3')", '/d1/d2/d3' ], +[ "Cygwin->catdir('d1','d2','d3')", 'd1/d2/d3' ], +[ "Cygwin->catdir('/','d2/d3')", '/d2/d3' ], + +[ "Cygwin->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], +[ "Cygwin->canonpath('')", '' ], +[ "Cygwin->canonpath('a/../../b/c')", 'a/../../b/c' ], +[ "Cygwin->canonpath('/.')", '/' ], +[ "Cygwin->canonpath('/./')", '/' ], +[ "Cygwin->canonpath('/a/./')", '/a' ], +[ "Cygwin->canonpath('/a/.')", '/a' ], +[ "Cygwin->canonpath('/../../')", '/' ], +[ "Cygwin->canonpath('/../..')", '/' ], + +[ "Cygwin->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], +[ "Cygwin->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], +[ "Cygwin->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "Cygwin->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "Cygwin->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], +#[ "Cygwin->abs2rel('../t4','/t1/t2/t3')", '../t4' ], +[ "Cygwin->abs2rel('/','/t1/t2/t3')", '../../..' ], +[ "Cygwin->abs2rel('///','/t1/t2/t3')", '../../..' ], +[ "Cygwin->abs2rel('/.','/t1/t2/t3')", '../../..' ], +[ "Cygwin->abs2rel('/./','/t1/t2/t3')", '../../..' ], +#[ "Cygwin->abs2rel('../t4','/t1/t2/t3')", '../t4' ], +[ "Cygwin->abs2rel('/t1/t2/t3', '/')", 't1/t2/t3' ], +[ "Cygwin->abs2rel('/t1/t2/t3', '/t1')", 't2/t3' ], +[ "Cygwin->abs2rel('t1/t2/t3', 't1')", 't2/t3' ], +[ "Cygwin->abs2rel('t1/t2/t3', 't4')", '../t1/t2/t3' ], + +[ "Cygwin->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], +[ "Cygwin->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], +[ "Cygwin->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], +[ "Cygwin->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], +[ "Cygwin->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], +[ "Cygwin->rel2abs('/t1','/t1/t2/t3')", '/t1' ], +[ "Cygwin->rel2abs('//t1/t2/t3','/foo')", '//t1/t2/t3' ], + +) ; + +can_ok('File::Spec::Win32', '_cwd'); + +{ + package File::Spec::FakeWin32; + use vars qw(@ISA); + @ISA = qw(File::Spec::Win32); + + sub _cwd { 'C:\\one\\two' } + + # Some funky stuff to override Cwd::getdcwd() for testing purposes, + # in the limited scope of the rel2abs() method. + if ($Cwd::VERSION && $Cwd::VERSION gt '2.17') { # Avoid a 'used only once' warning + local $^W; + *rel2abs = sub { + my $self = shift; + local $^W; + local *Cwd::getdcwd = sub { + return 'D:\alpha\beta' if $_[0] eq 'D:'; + return 'C:\one\two' if $_[0] eq 'C:'; + return; + }; + *Cwd::getdcwd = *Cwd::getdcwd; # Avoid a 'used only once' warning + return $self->SUPER::rel2abs(@_); + }; + *rel2abs = *rel2abs; # Avoid a 'used only once' warning + } +} + +# Tries a named function with the given args and compares the result against +# an expected result. Works with functions that return scalars or arrays. +for ( @tests ) { + my ($function, $expected) = @$_; + + $function =~ s#\\#\\\\#g ; + $function =~ s/^([^\$].*->)/File::Spec::$1/; + my $got = join ',', eval $function; + + SKIP: { + if ($@) { + skip "skip $function: $skip_exception", 1 + if $@ =~ /^\Q$skip_exception/; + is($@, '', $function); + } else { + is($got, $expected, $function); + } + } +} + +is +File::Spec::Unix->canonpath(), undef; + +done_testing(); diff --git a/cpan/dist/PathTools/t/abs2rel.t b/cpan/dist/PathTools/t/abs2rel.t new file mode 100644 index 00000000..5e33ab6c --- /dev/null +++ b/cpan/dist/PathTools/t/abs2rel.t @@ -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 --git a/cpan/dist/PathTools/t/crossplatform.t b/cpan/dist/PathTools/t/crossplatform.t new file mode 100644 index 00000000..b7c76fc1 --- /dev/null +++ b/cpan/dist/PathTools/t/crossplatform.t @@ -0,0 +1,173 @@ +#!/usr/bin/perl -w + +use strict; +use File::Spec; +use lib File::Spec->catfile('t', 'lib'); +use Test::More; +local $|=1; + +my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32); +my $tests_per_platform = 10; + +my $vms_unix_rpt = 0; +my $vms_efs = 0; +my $vms_unix_mode = 0; +my $vms_real_root = 0; + +if ($^O eq 'VMS') { + $vms_unix_mode = 0; + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + } + + # Traditional VMS mode only if VMS is not in UNIX compatible mode. + $vms_unix_mode = ($vms_efs && $vms_unix_rpt); + + # If we are in UNIX mode, we may or may not have a real root. + if ($vms_unix_mode) { + my $rootdir = File::Spec->rootdir; + $vms_real_root = 1 if ($rootdir eq '/'); + } + +} + + +plan tests => 1 + @platforms * $tests_per_platform; + +my %volumes = ( + Mac => 'Macintosh HD', + OS2 => 'A:', + Win32 => 'A:', + VMS => 'v', + ); +my %other_vols = ( + Mac => 'Mounted Volume', + OS2 => 'B:', + Win32 => 'B:', + VMS => 'w', + ); + +ok 1, "Loaded"; + +foreach my $platform (@platforms) { + my $module = "File::Spec::$platform"; + + SKIP: + { + eval "require $module; 1"; + + skip "Can't load $module", $tests_per_platform + if $@; + + my $v = $volumes{$platform} || ''; + my $other_v = $other_vols{$platform} || ''; + + # Fake out the environment on MacOS and Win32 + no strict 'refs'; + my $save_w = $^W; + $^W = 0; + local *{"File::Spec::Mac::rootdir"} = sub { "Macintosh HD:" }; + local *{"File::Spec::Win32::_cwd"} = sub { "C:\\foo" }; + $^W = $save_w; + use strict 'refs'; + + + my ($file, $base, $result); + + $base = $module->catpath($v, $module->catdir('', 'foo'), ''); + $base = $module->catdir($module->rootdir, 'foo'); + + is $module->file_name_is_absolute($base), 1, "$base is absolute on $platform"; + + # splitdir('') -> () + my @result = $module->splitdir(''); + is @result, 0, "$platform->splitdir('') -> ()"; + + # canonpath() -> undef + $result = $module->canonpath(); + is $result, undef, "$platform->canonpath() -> undef"; + + # canonpath(undef) -> undef + $result = $module->canonpath(undef); + is $result, undef, "$platform->canonpath(undef) -> undef"; + + # abs2rel('A:/foo/bar', 'A:/foo') -> 'bar' + $file = $module->catpath($v, $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); + $base = $module->catpath($v, $module->catdir($module->rootdir, 'foo'), ''); + $result = $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 56 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + $result =~ s/\.$//; + + # If we have a real root, then we are dealing with absolute directories + $result =~ s/\[\./\[/ if $vms_real_root; + } + + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + + + # abs2rel('A:/foo/bar', 'B:/foo') -> 'A:/foo/bar' + $base = $module->catpath($other_v, $module->catdir($module->rootdir, 'foo'), ''); + $result = volumes_differ($module, $file, $base) ? $file : $module->catfile('bar', 'file'); + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + + + # abs2rel('A:/foo/bar', '/foo') -> 'A:/foo/bar' + $base = $module->catpath('', $module->catdir($module->rootdir, 'foo'), ''); + $result = volumes_differ($module, $file, $base) ? $file : $module->catfile('bar', 'file'); + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + + + # abs2rel('/foo/bar/file', 'A:/foo') -> '/foo/bar' + $file = $module->catpath('', $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); + $base = $module->catpath($v, $module->catdir($module->rootdir, 'foo'), ''); + $result = volumes_differ($module, $file, $base) ? $module->rel2abs($file) : $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 59 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + } + + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + + + # abs2rel('/foo/bar', 'B:/foo') -> '/foo/bar' + $base = $module->catpath($other_v, $module->catdir($module->rootdir, 'foo'), ''); + $result = volumes_differ($module, $file, $base) ? $module->rel2abs($file) : $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 60 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + } + + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + + + # abs2rel('/foo/bar', '/foo') -> 'bar' + $base = $module->catpath('', $module->catdir($module->rootdir, 'foo'), ''); + $result = $module->catfile('bar', 'file'); + + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + } +} + +sub volumes_differ { + my ($module, $one, $two) = @_; + my ($one_v) = $module->splitpath( $module->rel2abs($one) ); + my ($two_v) = $module->splitpath( $module->rel2abs($two) ); + return $one_v ne $two_v; +} diff --git a/cpan/dist/PathTools/t/cwd.t b/cpan/dist/PathTools/t/cwd.t new file mode 100644 index 00000000..57fd866f --- /dev/null +++ b/cpan/dist/PathTools/t/cwd.t @@ -0,0 +1,284 @@ +#!./perl -w + +use strict; + +use Cwd; + +chdir 't'; +@INC = '../../../lib' if $ENV{PERL_CORE}; + +use Config; +use File::Spec; +use File::Path; + +use lib File::Spec->catdir('t', 'lib'); +use Test::More; + +my $IsVMS = $^O eq 'VMS'; + +my $vms_unix_rpt = 0; +my $vms_efs = 0; +my $vms_mode = 0; + +if ($IsVMS) { + require VMS::Filespec; + use Carp; + use Carp::Heavy; + $vms_mode = 1; + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + } + $vms_mode = 0 if ($vms_unix_rpt); +} + +my $tests = 31; +# _perl_abs_path() currently only works when the directory separator +# is '/', so don't test it when it won't work. +my $EXTRA_ABSPATH_TESTS = ($Config{prefix} =~ m/\//) && $^O ne 'cygwin'; +$tests += 4 if $EXTRA_ABSPATH_TESTS; +plan tests => $tests; + +SKIP: { + skip "no need to check for blib/ in the core", 1 if $ENV{PERL_CORE}; + like $INC{'Cwd.pm'}, qr{blib}i, "Cwd should be loaded from blib/ during testing"; +} + + +# check imports +can_ok('main', qw(cwd getcwd fastcwd fastgetcwd)); +ok( !defined(&chdir), 'chdir() not exported by default' ); +ok( !defined(&abs_path), ' nor abs_path()' ); +ok( !defined(&fast_abs_path), ' nor fast_abs_path()'); + +{ + my @fields = qw(PATH IFS CDPATH ENV BASH_ENV); + my $before = grep exists $ENV{$_}, @fields; + cwd(); + my $after = grep exists $ENV{$_}, @fields; + is($before, $after, "cwd() shouldn't create spurious entries in %ENV"); +} + +# XXX force Cwd to bootstrap its XSUBs since we have set @INC = "../lib" +# XXX and subsequent chdir()s can make them impossible to find +eval { fastcwd }; + +# Must find an external pwd (or equivalent) command. + +my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd"; +my $pwd_cmd = + ($^O eq "NetWare") ? + "cd" : + (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" } + split m/$Config{path_sep}/, $ENV{PATH})[0]; + +$pwd_cmd = 'SHOW DEFAULT' if $IsVMS; +if ($^O eq 'MSWin32') { + $pwd_cmd =~ s,/,\\,g; + $pwd_cmd = "$pwd_cmd /c cd"; +} +$pwd_cmd =~ s=\\=/=g if ($^O eq 'dos'); + +SKIP: { + skip "No native pwd command found to test against", 4 unless $pwd_cmd; + + print "# native pwd = '$pwd_cmd'\n"; + + local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; + my ($pwd_cmd_untainted) = $pwd_cmd =~ /^(.+)$/; # Untaint. + chomp(my $start = `$pwd_cmd_untainted`); + + # Win32's cd returns native C:\ style + $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare"); + if ($IsVMS) { + # DCL SHOW DEFAULT has leading spaces + $start =~ s/^\s+//; + + # When in UNIX report mode, need to convert to compare it. + if ($vms_unix_rpt) { + $start = VMS::Filespec::unixpath($start); + # Remove trailing slash. + $start =~ s#/$##; + } + } + SKIP: { + skip("'$pwd_cmd' failed, nothing to test against", 4) if $?; + skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|; + + # Darwin's getcwd(3) (which Cwd.xs:bsd_realpath() uses which + # Cwd.pm:getcwd uses) has some magic related to the PWD + # environment variable: if PWD is set to a directory that + # looks about right (guess: has the same (dev,ino) as the '.'?), + # the PWD is returned. However, if that path contains + # symlinks, the path will not be equal to the one returned by + # /bin/pwd (which probably uses the usual walking upwards in + # the path -trick). This situation is easy to reproduce since + # /tmp is a symlink to /private/tmp. Therefore we invalidate + # the PWD to force getcwd(3) to (re)compute the cwd in full. + # Admittedly fixing this in the Cwd module would be better + # long-term solution but deleting $ENV{PWD} should not be + # done light-heartedly. --jhi + delete $ENV{PWD} if $^O eq 'darwin'; + + my $cwd = cwd; + my $getcwd = getcwd; + my $fastcwd = fastcwd; + my $fastgetcwd = fastgetcwd; + + is($cwd, $start, 'cwd()'); + is($getcwd, $start, 'getcwd()'); + is($fastcwd, $start, 'fastcwd()'); + is($fastgetcwd, $start, 'fastgetcwd()'); + } +} + +my @test_dirs = qw{_ptrslt_ _path_ _to_ _a_ _dir_}; +my $Test_Dir = File::Spec->catdir(@test_dirs); + +mkpath([$Test_Dir], 0, 0777); +Cwd::chdir $Test_Dir; + +foreach my $func (qw(cwd getcwd fastcwd fastgetcwd)) { + my $result = eval "$func()"; + is $@, ''; + dir_ends_with( $result, $Test_Dir, "$func()" ); +} + +{ + # Some versions of File::Path (e.g. that shipped with perl 5.8.5) + # call getcwd() with an argument (perhaps by calling it as a + # method?), so make sure that doesn't die. + is getcwd(), getcwd('foo'), "Call getcwd() with an argument"; +} + +# Cwd::chdir should also update $ENV{PWD} +dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' ); +my $updir = File::Spec->updir; + +for (1..@test_dirs) { + Cwd::chdir $updir; + print "#$ENV{PWD}\n"; +} + +rmtree($test_dirs[0], 0, 0); + +{ + my $check = ($vms_mode ? qr|\b((?i)t)\]$| : + qr|\bt$| ); + + like($ENV{PWD}, $check); +} + +{ + # Make sure abs_path() doesn't trample $ENV{PWD} + my $start_pwd = $ENV{PWD}; + mkpath([$Test_Dir], 0, 0777); + Cwd::abs_path($Test_Dir); + is $ENV{PWD}, $start_pwd; + rmtree($test_dirs[0], 0, 0); +} + +SKIP: { + skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink} && $^O !~ m!^(qnx|nto)!; + + my $file = "linktest"; + mkpath([$Test_Dir], 0, 0777); + symlink $Test_Dir, $file; + + my $abs_path = Cwd::abs_path($file); + my $fast_abs_path = Cwd::fast_abs_path($file); + my $want = quotemeta( + File::Spec->rel2abs( $Test_Dir ) + ); + if ($^O eq 'VMS') { + # Not easy to predict the physical volume name + $want = $ENV{PERL_CORE} ? $Test_Dir : File::Spec->catdir('t', $Test_Dir); + + # So just use the relative volume name + $want =~ s/^\[//; + + $want = quotemeta($want); + } + + like($abs_path, qr|$want$|i); + like($fast_abs_path, qr|$want$|i); + like(Cwd::_perl_abs_path($file), qr|$want$|i) if $EXTRA_ABSPATH_TESTS; + + rmtree($test_dirs[0], 0, 0); + 1 while unlink $file; +} + +# Make sure we can run abs_path() on files, not just directories +my $path = 'cwd.t'; +path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file'); +path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file'); +path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file') + if $EXTRA_ABSPATH_TESTS; + +$path = File::Spec->catfile(File::Spec->updir, 't', $path); +path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file'); +path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file'); +path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file') + if $EXTRA_ABSPATH_TESTS; + + + +SKIP: { + my $file; + { + my $root = Cwd::abs_path(File::Spec->rootdir); # Add drive letter? + local *FH; + opendir FH, $root or skip("Can't opendir($root): $!", 2+$EXTRA_ABSPATH_TESTS); + ($file) = grep {-f $_ and not -l $_} map File::Spec->catfile($root, $_), readdir FH; + closedir FH; + } + skip "No plain file in root directory to test with", 2+$EXTRA_ABSPATH_TESTS unless $file; + + $file = VMS::Filespec::rmsexpand($file) if $^O eq 'VMS'; + is Cwd::abs_path($file), $file, 'abs_path() works on files in the root directory'; + is Cwd::fast_abs_path($file), $file, 'fast_abs_path() works on files in the root directory'; + is Cwd::_perl_abs_path($file), $file, '_perl_abs_path() works on files in the root directory' + if $EXTRA_ABSPATH_TESTS; +} + +SKIP: { + my $dir = "${$}a\nx"; + mkdir $dir or skip "OS does not support dir names containing LF"; + chdir $dir or skip "OS cannot chdir into LF"; + eval { Cwd::fast_abs_path() }; + is $@, "", 'fast_abs_path does not die in dir whose name contains LF'; + chdir File::Spec->updir; + rmdir $dir; +} + + +############################################# +# These routines give us sort of a poor-man's cross-platform +# directory or path comparison capability. + +sub bracketed_form_dir { + return join '', map "[$_]", + grep length, File::Spec->splitdir(File::Spec->canonpath( shift() )); +} + +sub dir_ends_with { + my ($dir, $expect) = (shift, shift); + my $bracketed_expect = quotemeta bracketed_form_dir($expect); + like( bracketed_form_dir($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) ); +} + +sub bracketed_form_path { + return join '', map "[$_]", + grep length, File::Spec->splitpath(File::Spec->canonpath( shift() )); +} + +sub path_ends_with { + my ($dir, $expect) = (shift, shift); + my $bracketed_expect = quotemeta bracketed_form_path($expect); + like( bracketed_form_path($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) ); +} diff --git a/cpan/dist/PathTools/t/lib/Test/Builder.pm b/cpan/dist/PathTools/t/lib/Test/Builder.pm new file mode 100644 index 00000000..541a8512 --- /dev/null +++ b/cpan/dist/PathTools/t/lib/Test/Builder.pm @@ -0,0 +1,1499 @@ +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@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@pobox.comE<gt> + +=head1 COPYRIGHT + +Copyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>, + Michael G Schwern E<lt>schwern@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 --git a/cpan/dist/PathTools/t/lib/Test/More.pm b/cpan/dist/PathTools/t/lib/Test/More.pm new file mode 100644 index 00000000..db16079e --- /dev/null +++ b/cpan/dist/PathTools/t/lib/Test/More.pm @@ -0,0 +1,1330 @@ +package Test::More; + +use 5.004; + +use strict; +use Test::Builder; + + +# Can't use Carp because it might cause use_ok() to accidentally succeed +# even though the module being used forgot to use Carp. Yes, this +# actually happened. +sub _carp { + my($file, $line) = (caller(1))[1,2]; + warn @_, " at $file line $line\n"; +} + + + +require Exporter; +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +$VERSION = '0.49'; +@ISA = qw(Exporter); +@EXPORT = qw(ok use_ok require_ok + is isnt like unlike is_deeply + cmp_ok + skip todo todo_skip + pass fail + eq_array eq_hash eq_set + $TODO + plan + can_ok isa_ok + diag + ); + +my $Test = Test::Builder->new; +my $Show_Diag = 1; + + +# 5.004's Exporter doesn't have export_to_level. +sub _export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => $Num_Tests; + # or + use Test::More qw(no_plan); + # or + use Test::More skip_all => $reason; + + BEGIN { use_ok( 'Some::Module' ); } + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($this eq $that, $test_name); + + is ($this, $that, $test_name); + isnt($this, $that, $test_name); + + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); + + like ($this, qr/that/, $test_name); + unlike($this, qr/that/, $test_name); + + cmp_ok($this, '==', $that, $test_name); + + is_deeply($complex_structure1, $complex_structure2, $test_name); + + SKIP: { + skip $why, $how_many unless $have_some_feature; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + can_ok($module, @methods); + isa_ok($object, $class); + + pass($test_name); + fail($test_name); + + # Utility comparison functions. + eq_array(\@this, \@that); + eq_hash(\%this, \%that); + eq_set(\@this, \@that); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + # UNIMPLEMENTED!!! + BAIL_OUT($why); + + +=head1 DESCRIPTION + +B<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@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@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 --git a/cpan/dist/PathTools/t/lib/Test/Simple.pm b/cpan/dist/PathTools/t/lib/Test/Simple.pm new file mode 100644 index 00000000..d7c5cbe9 --- /dev/null +++ b/cpan/dist/PathTools/t/lib/Test/Simple.pm @@ -0,0 +1,235 @@ +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@pobox.comE<gt>, wardrobe by Calvin Klein. + + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern E<lt>schwern@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 --git a/cpan/dist/PathTools/t/lib/Test/Tutorial.pod b/cpan/dist/PathTools/t/lib/Test/Tutorial.pod new file mode 100644 index 00000000..7a6c084d --- /dev/null +++ b/cpan/dist/PathTools/t/lib/Test/Tutorial.pod @@ -0,0 +1,603 @@ +=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@pobox.comE<gt> and the perl-qa dancers! + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern E<lt>schwern@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 --git a/cpan/dist/PathTools/t/rel2abs2rel.t b/cpan/dist/PathTools/t/rel2abs2rel.t new file mode 100644 index 00000000..0d684f19 --- /dev/null +++ b/cpan/dist/PathTools/t/rel2abs2rel.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w + +# Here we make sure File::Spec can properly deal with executables. +# VMS has some trouble with these. + +use File::Spec; +use lib File::Spec->catdir('t', 'lib'); + +use Test::More (-x $^X + ? (tests => 5) + : (skip_all => "Can't find an executable file") + ); + +BEGIN { # Set up a tiny script file + local *F; + open(F, ">rel2abs2rel$$.pl") + or die "Can't open rel2abs2rel$$.pl file for script -- $!\n"; + print F qq(print "ok\\n"\n); + close(F); +} +END { + 1 while unlink("rel2abs2rel$$.pl"); + 1 while unlink("rel2abs2rel$$.tmp"); +} + +use Config; + + +# Change 'perl' to './perl' so the shell doesn't go looking through PATH. +sub safe_rel { + my($perl) = shift; + $perl = File::Spec->catfile(File::Spec->curdir, $perl) unless + File::Spec->file_name_is_absolute($perl); + + return $perl; +} +# Make a putative perl binary say "ok\n". We have to do it this way +# because the filespec of the binary may contain characters that a +# command interpreter considers special, so we can't use the obvious +# `$perl -le "print 'ok'"`. And, for portability, we can't use fork(). +sub sayok{ + my $perl = shift; + open(STDOUTDUP, '>&STDOUT'); + open(STDOUT, ">rel2abs2rel$$.tmp") + or die "Can't open scratch file rel2abs2rel$$.tmp -- $!\n"; + system($perl, "rel2abs2rel$$.pl"); + open(STDOUT, '>&STDOUTDUP'); + close(STDOUTDUP); + + local *F; + open(F, "rel2abs2rel$$.tmp"); + local $/ = undef; + my $output = <F>; + close(F); + return $output; +} + +print "# Checking manipulations of \$^X=$^X\n"; + +my $perl = safe_rel($^X); +is( sayok($perl), "ok\n", "'$perl rel2abs2rel$$.pl' works" ); + +$perl = File::Spec->rel2abs($^X); +is( sayok($perl), "ok\n", "'$perl rel2abs2rel$$.pl' works" ); + +$perl = File::Spec->canonpath($perl); +is( sayok($perl), "ok\n", "canonpath(rel2abs($^X)) = $perl" ); + +$perl = safe_rel(File::Spec->abs2rel($perl)); +is( sayok($perl), "ok\n", "safe_rel(abs2rel(canonpath(rel2abs($^X)))) = $perl" ); + +$perl = safe_rel(File::Spec->canonpath($^X)); +is( sayok($perl), "ok\n", "safe_rel(canonpath($^X)) = $perl" ); diff --git a/cpan/dist/PathTools/t/rel2abs_vs_symlink.t b/cpan/dist/PathTools/t/rel2abs_vs_symlink.t new file mode 100644 index 00000000..556cff2d --- /dev/null +++ b/cpan/dist/PathTools/t/rel2abs_vs_symlink.t @@ -0,0 +1,37 @@ +#!/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/cpan/dist/PathTools/t/taint.t b/cpan/dist/PathTools/t/taint.t new file mode 100644 index 00000000..48f8c5bc --- /dev/null +++ b/cpan/dist/PathTools/t/taint.t @@ -0,0 +1,53 @@ +#!./perl -Tw +# Testing Cwd under taint mode. + +use strict; + +use Cwd; +chdir 't' unless $ENV{PERL_CORE}; + +use File::Spec; +use lib File::Spec->catdir('t', 'lib'); +use Test::More; +BEGIN { + plan( + ${^TAINT} + ? (tests => 21) + : (skip_all => "A perl without taint support") + ); +} + +use Scalar::Util qw/tainted/; + +my @Functions = qw(getcwd cwd fastcwd fastgetcwd + abs_path fast_abs_path + realpath fast_realpath + ); + +foreach my $func (@Functions) { + no strict 'refs'; + my $cwd; + eval { $cwd = &{'Cwd::'.$func} }; + is( $@, '', "$func() should not explode under taint mode" ); + ok( tainted($cwd), "its return value should be tainted" ); +} + +# Previous versions of Cwd tainted $^O +is !tainted($^O), 1, "\$^O should not be tainted"; + +{ + # [perl #126862] canonpath() loses taint + my $tainted = substr($ENV{PATH}, 0, 0); + # yes, getcwd()'s result should be tainted, and is tested above + # but be sure + ok tainted(File::Spec->canonpath($tainted . Cwd::getcwd)), + "canonpath() keeps taint on non-empty string"; + ok tainted(File::Spec->canonpath($tainted)), + "canonpath() keeps taint on empty string"; + + (Cwd::getcwd() =~ /^(.*)/); + my $untainted = $1; + ok !tainted($untainted), "make sure our untainted value is untainted"; + ok !tainted(File::Spec->canonpath($untainted)), + "canonpath() doesn't add taint to untainted string"; +} diff --git a/cpan/dist/PathTools/t/tmpdir.t b/cpan/dist/PathTools/t/tmpdir.t new file mode 100644 index 00000000..0f03dc55 --- /dev/null +++ b/cpan/dist/PathTools/t/tmpdir.t @@ -0,0 +1,53 @@ +use strict; +use Test::More tests => 8; + +# Grab all of the plain routines from File::Spec +use File::Spec; +use File::Spec::Win32; + +require_ok($_) foreach qw(File::Spec File::Spec::Win32); + + +if ($^O eq 'VMS') { + # hack: + # Need to cause the %ENV to get populated or you only get the builtins at + # first, and then something else can cause the hash to get populated. + my %look_env = %ENV; +} +my $num_keys = keys %ENV; +File::Spec->tmpdir; +is scalar keys %ENV, $num_keys, "tmpdir() shouldn't change the contents of %ENV"; + +SKIP: { + skip("Can't make list assignment to %ENV on this system", 1) + if $^O eq 'VMS'; + + local %ENV; + File::Spec::Win32->tmpdir; + is(scalar keys %ENV, 0, "Win32->tmpdir() shouldn't change the contents of %ENV"); +} + +File::Spec::Win32->tmpdir; +is(scalar keys %ENV, $num_keys, "Win32->tmpdir() shouldn't change the contents of %ENV"); + +# Changing tmpdir dynamically +for ('File::Spec', "File::Spec::Win32") { + SKIP: { + skip('sys$scratch: takes precedence over env on vms', 1) + if $^O eq 'VMS'; + local $ENV{TMPDIR} = $_->catfile($_->curdir, 'lib'); + -d $ENV{TMPDIR} && -w _ + or skip "Can't create usable TMPDIR env var", 1; + my $tmpdir1 = $_->tmpdir; + $ENV{TMPDIR} = $_->catfile($_->curdir, 't'); + -d $ENV{TMPDIR} && -w _ + or skip "Can't create usable TMPDIR env var", 1; + my $tmpdir2 = $_->tmpdir; + isn't $tmpdir2, $tmpdir1, "$_->tmpdir works with changing env"; + } +} + +ok( + File::Spec->file_name_is_absolute(File::Spec->tmpdir()), + "tmpdir() always returns an absolute path" +); diff --git a/cpan/dist/PathTools/t/win32.t b/cpan/dist/PathTools/t/win32.t new file mode 100644 index 00000000..3fa5cb86 --- /dev/null +++ b/cpan/dist/PathTools/t/win32.t @@ -0,0 +1,32 @@ +#!./perl + +use File::Spec; +use lib File::Spec->catdir('t', 'lib'); +use Test::More; + +if( $^O eq 'MSWin32' ) { + plan tests => 4; +} else { + plan skip_all => 'this is not win32'; +} + +use Cwd; +ok 1; + +my $cdir = getdcwd('C:'); +like $cdir, qr{^C:}i; + +my $ddir = getdcwd('D:'); +if (defined $ddir) { + like $ddir, qr{^D:}i; +} else { + # May not have a D: drive mounted + ok 1; +} + +# Ensure compatibility with naughty versions of Template::Toolkit, +# which pass in a bare $1 as an argument +'Foo/strawberry' =~ /(.*)/; +my $result = File::Spec::Win32->catfile('C:/cache', $1); +is( $result, 'C:\cache\Foo\strawberry' ); + diff --git a/cpan/lib/File/Spec.pm b/cpan/lib/File/Spec.pm index a911fa29..2709c39f 100644 --- a/cpan/lib/File/Spec.pm +++ b/cpan/lib/File/Spec.pm @@ -3,7 +3,8 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '0.85_03'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', @@ -11,8 +12,10 @@ my %module = (MacOS => 'Mac', VMS => 'VMS', epoc => 'Epoc', NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. - dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. - cygwin => 'Cygwin'); + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. + dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. + cygwin => 'Cygwin', + amigaos => 'AmigaOS'); my $module = $module{$^O} || 'Unix'; @@ -81,23 +84,33 @@ forms of these methods. =over 2 =item canonpath +X<canonpath> No physical check on the filesystem, but a logical cleanup of a path. $cpath = File::Spec->canonpath( $path ) ; +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + =item catdir +X<catdir> Concatenate two or more directory names to form a complete path ending with a directory. But remove the trailing slash from the resulting string, because it doesn't look good, isn't necessary and confuses -OS2. Of course, if this is the root directory, don't cut off the +OS/2. Of course, if this is the root directory, don't cut off the trailing slash :-) $path = File::Spec->catdir( @directories ); =item catfile +X<catfile> Concatenate one or more directory names and a filename to form a complete path ending with a filename @@ -105,34 +118,39 @@ complete path ending with a filename $path = File::Spec->catfile( @directories, $filename ); =item curdir +X<curdir> Returns a string representation of the current directory. $curdir = File::Spec->curdir(); =item devnull +X<devnull> Returns a string representation of the null device. $devnull = File::Spec->devnull(); =item rootdir +X<rootdir> Returns a string representation of the root directory. $rootdir = File::Spec->rootdir(); =item tmpdir +X<tmpdir> Returns a string representation of the first writable directory from a list of possible temporary directories. Returns the current directory if no writable temporary directories are found. The list of directories -checked depends on the platform; e.g. File::Spec::Unix checks $ENV{TMPDIR} -(unless taint is on) and /tmp. +checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> +(unless taint is on) and F</tmp>. $tmpdir = File::Spec->tmpdir(); =item updir +X<updir> Returns a string representation of the parent directory. @@ -148,13 +166,14 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) =item case_tolerant Returns a true or false value indicating, respectively, that alphabetic -is not or is significant when comparing file specifications. +case is not or is significant when comparing file specifications. +Cygwin and Win32 accept an optional drive argument. $is_case_tolerant = File::Spec->case_tolerant(); =item file_name_is_absolute -Takes as argument a path and returns true if it is an absolute path. +Takes as its argument a path, and returns true if it is an absolute path. $is_absolute = File::Spec->file_name_is_absolute( $path ); @@ -163,27 +182,32 @@ Mac OS (Classic). It does consult the working environment for VMS (see L<File::Spec::VMS/file_name_is_absolute>). =item path +X<path> -Takes no argument, returns the environment variable PATH (or the local +Takes no argument. Returns the environment variable C<PATH> (or the local platform's equivalent) as a list. @PATH = File::Spec->path(); =item join +X<join, path> join is the same as catfile. =item splitpath +X<splitpath> X<split, path> Splits a path in to volume, directory, and filename portions. On systems with no concept of volume, returns '' for volume. - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + ($volume,$directories,$file) = + File::Spec->splitpath( $path ); + ($volume,$directories,$file) = + File::Spec->splitpath( $path, $no_file ); For systems with no syntax differentiating filenames from directories, -assumes that the last file is a path unless $no_file is true or a -trailing separator or /. or /.. is present. On Unix this means that $no_file +assumes that the last file is a path unless C<$no_file> is true or a +trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> true makes this return ( '', $path, '' ). The directory portion may or may not be returned with a trailing '/'. @@ -192,28 +216,30 @@ The results can be passed to L</catpath()> to get back a path equivalent to (usually identical to) the original path. =item splitdir +X<splitdir> X<split, dir> -The opposite of L</catdir()>. +The opposite of L</catdir>. @dirs = File::Spec->splitdir( $directories ); -$directories must be only the directory portion of the path on systems +C<$directories> must be only the directory portion of the path on systems that have the concept of a volume or that have path syntax that differentiates files from directories. Unlike just splitting the directories on the separator, empty directory names (C<''>) can be returned, because these are significant -on some OSs. +on some OSes. =item catpath() Takes volume, directory and file portions and returns an entire path. Under -Unix, $volume is ignored, and directory and file are concatenated. A '/' is -inserted if need be. On other OSs, $volume is significant. +Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is +inserted if need be. On other OSes, C<$volume> is significant. $full_path = File::Spec->catpath( $volume, $directory, $file ); =item abs2rel +X<abs2rel> X<absolute, path> X<relative, path> Takes a destination path and an optional base path returns a relative path from the base path to the destination path: @@ -221,23 +247,23 @@ from the base path to the destination path: $rel_path = File::Spec->abs2rel( $path ) ; $rel_path = File::Spec->abs2rel( $path, $base ) ; -If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, then it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to -L<cwd()|Cwd>. +L<Cwd::cwd()|Cwd>. -On systems with the concept of volume, if $path and $base appear to be +On systems with the concept of volume, if C<$path> and C<$base> appear to be on two different volumes, we will not attempt to resolve the two -paths, and we will instead simply return $path. Note that previous -versions of this module ignored the volume of $base, which resulted in +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in garbage results part of the time. On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be +C<$base> filename as well. Otherwise all path components are assumed to be directories. -If $path is relative, it is converted to absolute form using L</rel2abs()>. -This means that it is taken to be relative to L<cwd()|Cwd>. +If C<$path> is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<Cwd::cwd()|Cwd>. No checks against the filesystem are made. On VMS, there is interaction with the working environment, as logicals and @@ -246,27 +272,28 @@ macros are expanded. Based on code written by Shigio Yamaguchi. =item rel2abs() +X<rel2abs> X<absolute, path> X<relative, path> Converts a relative path to an absolute path. $abs_path = File::Spec->rel2abs( $path ) ; $abs_path = File::Spec->rel2abs( $path, $base ) ; -If $base is not present or '', then L<cwd()|Cwd> is used. If $base is relative, +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, then it is converted to absolute form using L</rel2abs()>. This means that it -is taken to be relative to L<cwd()|Cwd>. +is taken to be relative to L<Cwd::cwd()|Cwd>. -On systems with the concept of volume, if $path and $base appear to be +On systems with the concept of volume, if C<$path> and C<$base> appear to be on two different volumes, we will not attempt to resolve the two -paths, and we will instead simply return $path. Note that previous -versions of this module ignored the volume of $base, which resulted in +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in garbage results part of the time. On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be +C<$base> filename as well. Otherwise all path components are assumed to be directories. -If $path is absolute, it is cleaned up and returned using L</canonpath()>. +If C<$path> is absolute, it is cleaned up and returned using L</canonpath>. No checks against the filesystem are made. On VMS, there is interaction with the working environment, as logicals and @@ -286,17 +313,28 @@ L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, L<ExtUtils::MakeMaker> -=head1 AUTHORS - -Kenneth Albanowski <kjahds@kjahds.com>, Andy Dougherty -<doughera@lafayette.edu>, Andreas KE<ouml>nig -<A.Koenig@franz.ww.TU-Berlin.DE>, Tim Bunce <Tim.Bunce@ig.co.uk. -VMS support by Charles Bailey <bailey@newman.upenn.edu>. -OS/2 support by Ilya Zakharevich <ilya@math.ohio-state.edu>. -Mac support by Paul Schinder <schinder@pobox.com>, and Thomas Wegner -<wegner_thomas@yahoo.com>. abs2rel() and rel2abs() written by Shigio -Yamaguchi <shigio@tamacom.com>, modified by Barrie Slaymaker -<barries@slaysys.com>. splitpath(), splitdir(), catpath() and -catdir() by Barrie Slaymaker. +=head1 AUTHOR + +Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< <kjahds@kjahds.com> >>, +Andy Dougherty C<< <doughera@lafayette.edu> >>, +Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>, +Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>. +VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>. +OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>. +Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and +Thomas Wegner C<< <wegner_thomas@yahoo.com> >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>, +modified by Barrie Slaymaker C<< <barries@slaysys.com> >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004-2013 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. =cut diff --git a/cpan/lib/File/Spec/AmigaOS.pm b/cpan/lib/File/Spec/AmigaOS.pm new file mode 100644 index 00000000..e6d6f5f2 --- /dev/null +++ b/cpan/lib/File/Spec/AmigaOS.pm @@ -0,0 +1,61 @@ +package File::Spec::AmigaOS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::AmigaOS - File::Spec for AmigaOS + +=head1 SYNOPSIS + + require File::Spec::AmigaOS; # Done automatically by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item tmpdir + +Returns $ENV{TMPDIR} or if that is unset, "/t". + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/t" ); +} + +=item file_name_is_absolute + +Returns true if there's a colon in the file name, +or if it begins with a slash. + +=cut + +sub file_name_is_absolute { + my ($self, $file) = @_; + + # Not 100% robust as a "/" must not preceded a ":" + # but this cannot happen in a well formed path. + return $file =~ m{^/|:}s; +} + +=back + +All the other methods are from L<File::Spec::Unix>. + +=cut + +1; diff --git a/cpan/lib/File/Spec/Cygwin.pm b/cpan/lib/File/Spec/Cygwin.pm index 0712add8..67f056f5 100644 --- a/cpan/lib/File/Spec/Cygwin.pm +++ b/cpan/lib/File/Spec/Cygwin.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.1'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -39,8 +40,29 @@ and then File::Spec::Unix canonpath() is called on the result. sub canonpath { my($self,$path) = @_; + return unless defined $path; + $path =~ s|\\|/|g; - return $self->SUPER::canonpath($path); + + # Handle network path names beginning with double slash + my $node = ''; + if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) { + $node = $1; + } + return $node . $self->SUPER::canonpath($path); +} + +sub catdir { + my $self = shift; + return unless @_; + + # Don't create something that looks like a //network/path + if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { + shift; + return $self->SUPER::catdir('', @_); + } + + $self->SUPER::catdir(@_); } =pod @@ -66,22 +88,73 @@ from the following list: $ENV{TMPDIR} /tmp + $ENV{'TMP'} + $ENV{'TEMP'} C:/temp -Since Perl 5.8.0, if running under taint mode, and if the environment +If running under taint mode, and if the environment variables are tainted, they are not used. =cut -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( $ENV{TMPDIR}, "/tmp", 'C:/temp' ); + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( + $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' + ), + qw 'TMPDIR TMP TEMP' + ); +} + +=item case_tolerant + +Override Unix. Cygwin case-tolerance depends on managed mount settings and +as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Default: 1 + +=cut + +sub case_tolerant { + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + + my $drive = shift; + if (! $drive) { + my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); + my $prefix = pop(@flags); + if (! $prefix || $prefix eq 'cygdrive') { + $drive = '/cygdrive/c'; + } elsif ($prefix eq '/') { + $drive = '/c'; + } else { + $drive = "$prefix/c"; + } + } + my $mntopts = Cygwin::mount_flags($drive); + if ($mntopts and ($mntopts =~ /,managed/)) { + return 0; + } + eval { require Win32API::File; } or return 1; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } } =back +=head1 COPYRIGHT + +Copyright (c) 2004,2007 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. + =cut 1; diff --git a/cpan/lib/File/Spec/Epoc.pm b/cpan/lib/File/Spec/Epoc.pm index 89ca0b99..17e3f54d 100644 --- a/cpan/lib/File/Spec/Epoc.pm +++ b/cpan/lib/File/Spec/Epoc.pm @@ -3,7 +3,8 @@ package File::Spec::Epoc; use strict; use vars qw($VERSION @ISA); -$VERSION = '1.1'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; require File::Spec::Unix; @ISA = qw(File::Spec::Unix); @@ -19,14 +20,10 @@ File::Spec::Epoc - methods for Epoc file specs =head1 DESCRIPTION See File::Spec::Unix for a documentation of the methods provided -there. This package overrides the implementation of these methods, not +there. This package overrides the implementation of these methods, not the semantics. -This package is still work in progress ;-) - -=head1 AUTHORS - -o.flebbe@gmx.de +This package is still a work in progress. ;-) =cut @@ -41,7 +38,7 @@ sub case_tolerant { =item canonpath() No physical check on the filesystem, but a logical cleanup of a -path. On UNIX eliminated successive slashes and successive "/.". +path. On UNIX eliminated successive slashes and successive "/.". =back @@ -49,6 +46,7 @@ path. On UNIX eliminated successive slashes and successive "/.". sub canonpath { my ($self,$path) = @_; + return unless defined $path; $path =~ s|/+|/|g; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx @@ -60,6 +58,17 @@ sub canonpath { =pod +=head1 AUTHOR + +o.flebbe@gmx.de + +=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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the diff --git a/cpan/lib/File/Spec/Functions.pm b/cpan/lib/File/Spec/Functions.pm index 1c36e8b9..470c7718 100644 --- a/cpan/lib/File/Spec/Functions.pm +++ b/cpan/lib/File/Spec/Functions.pm @@ -5,7 +5,8 @@ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '1.3'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; require Exporter; @@ -36,10 +37,30 @@ require Exporter; %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); +require File::Spec::Unix; +my %udeps = ( + canonpath => [], + catdir => [qw(canonpath)], + catfile => [qw(canonpath catdir)], + case_tolerant => [], + curdir => [], + devnull => [], + rootdir => [], + updir => [], +); + foreach my $meth (@EXPORT, @EXPORT_OK) { my $sub = File::Spec->can($meth); no strict 'refs'; - *{$meth} = sub {&$sub('File::Spec', @_)}; + if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) && + !(grep { + File::Spec->can($_) != File::Spec::Unix->can($_) + } @{$udeps{$meth}}) && + defined(&{"File::Spec::Unix::_fn_$meth"})) { + *{$meth} = \&{"File::Spec::Unix::_fn_$meth"}; + } else { + *{$meth} = sub {&$sub('File::Spec', @_)}; + } } @@ -93,7 +114,17 @@ The following functions are exported only by request. All the functions may be imported using the C<:ALL> tag. +=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. + =head1 SEE ALSO File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker + +=cut + diff --git a/cpan/lib/File/Spec/Mac.pm b/cpan/lib/File/Spec/Mac.pm index 34a7a015..329451fb 100644 --- a/cpan/lib/File/Spec/Mac.pm +++ b/cpan/lib/File/Spec/Mac.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.4'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -53,7 +54,7 @@ done in MacPerl's environment and helps to distinguish a file path from a directory path. B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting -path is relative by default and I<not> absolute. This descision was made due +path is relative by default and I<not> absolute. This decision was made due to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths on all other operating systems, it will now also follow this convention on Mac OS. Note that this may break some existing scripts. @@ -155,13 +156,16 @@ their Unix counterparts: Unix: Unix->catdir("","") = "/" Unix->catdir("",".") = "/" - Unix->catdir("","..") = "/" # can't go beyond root + Unix->catdir("","..") = "/" # can't go + # beyond root Unix->catdir("",".","..","..","a") = "/a" Mac: - Mac->catdir("","") = rootdir() # (e.g. "HD:") + Mac->catdir("","") = rootdir() # (e.g. "HD:") Mac->catdir("",":") = rootdir() - Mac->catdir("","::") = rootdir() # can't go beyond root - Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:") + Mac->catdir("","::") = rootdir() # can't go + # beyond root + Mac->catdir("",":","::","::","a") = rootdir() . "a:" + # (e.g. "HD:a:") However, this approach is limited to the first arguments following "root" (again, see C<Unix-E<gt>canonpath()> ). If there are more @@ -272,7 +276,7 @@ by default, but can be forced to be absolute (but avoid this). B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting path is relative by default and I<not> absolute. This -descision was made due to portability reasons. Since +decision was made due to portability reasons. Since C<File::Spec-E<gt>catfile()> returns relative paths on all other operating systems, it will now also follow this convention on Mac OS. Note that this may break some existing scripts. @@ -370,11 +374,10 @@ directory on your startup volume. =cut -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( $ENV{TMPDIR} ); + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), 'TMPDIR'); } =item updir @@ -400,10 +403,11 @@ the filename '' is always considered to be absolute. Note that with version E.g. - File::Spec->file_name_is_absolute("a"); # false (relative) - File::Spec->file_name_is_absolute(":a:b:"); # false (relative) - File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute) - File::Spec->file_name_is_absolute(""); # true (absolute) + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); + # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) =cut @@ -440,7 +444,8 @@ sub path { =item splitpath ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Splits a path into volume, directory, and filename portions. @@ -531,7 +536,7 @@ sub splitdir { my @result = (); my ($head, $sep, $tail, $volume, $directories); - return ('') if ( (!defined($path)) || ($path eq '') ); + return @result if ( (!defined($path)) || ($path eq '') ); return (':') if ($path eq ':'); ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; @@ -740,7 +745,7 @@ sub rel2abs { # Split up paths - # igonore $path's volume + # ignore $path's volume my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; # ignore $base's file part @@ -764,6 +769,13 @@ sub rel2abs { See the authors list in I<File::Spec>. Mac OS support by Paul Schinder <schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. +=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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the diff --git a/cpan/lib/File/Spec/OS2.pm b/cpan/lib/File/Spec/OS2.pm index 47dc0a6a..55e6d335 100644 --- a/cpan/lib/File/Spec/OS2.pm +++ b/cpan/lib/File/Spec/OS2.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.2'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -34,13 +35,13 @@ sub _cwd { return Cwd::sys_cwd(); } -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - '/tmp', - '/' ); + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); + return $cached if defined $cached; + my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP' + ); } sub catdir { @@ -56,6 +57,8 @@ sub catdir { sub canonpath { my ($self,$path) = @_; + return unless defined $path; + $path =~ s/^([a-z]:)/\l$1/s; $path =~ s|\\|/|g; $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx @@ -263,4 +266,11 @@ Volumes can be drive letters or UNC sharenames (\\server\share). =back +=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. + =cut diff --git a/cpan/lib/File/Spec/Unix.pm b/cpan/lib/File/Spec/Unix.pm index 349757b6..586e9b0a 100644 --- a/cpan/lib/File/Spec/Unix.pm +++ b/cpan/lib/File/Spec/Unix.pm @@ -3,7 +3,23 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '1.5'; +$VERSION = '3.62'; +my $xs_version = $VERSION; +$VERSION =~ tr/_//d; + +#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); + } else { + require Cwd; + } + }; +} =head1 NAME @@ -30,32 +46,45 @@ path. On UNIX eliminates successive slashes and successive "/.". $cpath = File::Spec->canonpath( $path ) ; +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + =cut -sub canonpath { +sub _pp_canonpath { my ($self,$path) = @_; + return unless defined $path; # Handle POSIX-style node names beginning with double slash (qnx, nto) - # Handle network path names beginning with double slash (cygwin) # (POSIX says: "a pathname that begins with two successive slashes # may be interpreted in an implementation-defined manner, although # more than two leading slashes shall be treated as a single slash.") my $node = ''; - if ( $^O =~ m/^(?:qnx|nto|cygwin)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) { + my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; + + + if ( $double_slashes_special + && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { $node = $1; } # This used to be - # $path =~ s|/+|/|g unless($^O eq 'cygwin'); + # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail # (Mainly because trailing "" directories didn't get stripped). # Why would cygwin avoid collapsing multiple slashes into one? --jhi - $path =~ s|/+|/|g; # xx////xx -> xx/xx - $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx - $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx - $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx - $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx + $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx + $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx return "$node$path"; } +*canonpath = \&_pp_canonpath unless defined &canonpath; =item catdir() @@ -67,11 +96,12 @@ trailing slash :-) =cut -sub catdir { +sub _pp_catdir { my $self = shift; $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' } +*catdir = \&_pp_catdir unless defined &catdir; =item catfile @@ -80,7 +110,7 @@ complete path ending with a filename =cut -sub catfile { +sub _pp_catfile { my $self = shift; my $file = $self->canonpath(pop @_); return $file unless @_; @@ -88,6 +118,7 @@ sub catfile { $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } +*catfile = \&_pp_catfile unless defined &catfile; =item curdir @@ -95,7 +126,8 @@ Returns a string representation of the current directory. "." on UNIX. =cut -sub curdir () { '.' } +sub curdir { '.' } +use constant _fn_curdir => "."; =item devnull @@ -103,7 +135,8 @@ Returns a string representation of the null device. "/dev/null" on UNIX. =cut -sub devnull () { '/dev/null' } +sub devnull { '/dev/null' } +use constant _fn_devnull => "/dev/null"; =item rootdir @@ -111,7 +144,8 @@ Returns a string representation of the root directory. "/" on UNIX. =cut -sub rootdir () { '/' } +sub rootdir { '/' } +use constant _fn_rootdir => "/"; =item tmpdir @@ -122,23 +156,38 @@ writable: $ENV{TMPDIR} /tmp -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +If running under taint mode, and if $ENV{TMPDIR} is tainted, it is not used. =cut -my $tmpdir; +my ($tmpdir, %tmpenv); +# Cache and return the calculated tmpdir, recording which env vars +# determined it. +sub _cache_tmpdir { + @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; + return $tmpdir = $_[1]; +} +# Retrieve the cached tmpdir, checking first whether relevant env vars have +# changed and invalidated the cache. +sub _cached_tmpdir { + shift; + local $^W; + return if grep $ENV{$_} ne $tmpenv{$_}, @_; + return $tmpdir; +} sub _tmpdir { - return $tmpdir if defined $tmpdir; my $self = shift; my @dirlist = @_; - { - no strict 'refs'; - if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 - require Scalar::Util; - @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; - } + my $taint = do { no strict 'refs'; ${"\cTAINT"} }; + if ($taint) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + elsif ($] < 5.007) { # No ${^TAINT} before 5.8 + @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; } + foreach (@dirlist) { next unless defined && -d && -w _; $tmpdir = $_; @@ -146,13 +195,22 @@ sub _tmpdir { } $tmpdir = $self->curdir unless defined $tmpdir; $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + if ( !$self->file_name_is_absolute($tmpdir) ) { + # See [perl #120593] for the full details + # If possible, return a full path, rather than '.' or 'lib', but + # jump through some hoops to avoid returning a tainted value. + ($tmpdir) = grep { + $taint ? ! Scalar::Util::tainted($_) : + $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 + } $self->rel2abs($tmpdir), $tmpdir; + } return $tmpdir; } sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( $ENV{TMPDIR}, "/tmp" ); + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); } =item updir @@ -161,7 +219,8 @@ Returns a string representation of the parent directory. ".." on UNIX. =cut -sub updir () { '..' } +sub updir { '..' } +use constant _fn_updir => ".."; =item no_upwards @@ -172,7 +231,7 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) sub no_upwards { my $self = shift; - return grep(!/^\.{1,2}\Z(?!\n)/s, @_); + return grep(!/^\.{1,2}\z/s, @_); } =item case_tolerant @@ -182,7 +241,8 @@ is not or is significant when comparing file specifications. =cut -sub case_tolerant () { 0 } +sub case_tolerant { 0 } +use constant _fn_case_tolerant => 0; =item file_name_is_absolute @@ -226,7 +286,8 @@ sub join { =item splitpath ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Splits a path into volume, directory, and filename portions. On systems with no concept of volume, returns '' for volume. @@ -252,7 +313,7 @@ sub splitpath { $directory = $path; } else { - $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; $directory = $1; $file = $2; } @@ -336,9 +397,11 @@ directories. If $path is relative, it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to L<cwd()|Cwd>. -No checks against the filesystem are made. On VMS, there is -interaction with the working environment, as logicals and -macros are expanded. +No checks against the filesystem are made, so the result may not be correct if +C<$base> contains symbolic links. (Apply +L<Cwd::abs_path()|Cwd/abs_path> beforehand if that +is a concern.) On VMS, there is interaction with the working environment, as +logicals and macros are expanded. Based on code written by Shigio Yamaguchi. @@ -346,52 +409,81 @@ Based on code written by Shigio Yamaguchi. sub abs2rel { my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; - # Clean up $path - if ( ! $self->file_name_is_absolute( $path ) ) { - $path = $self->rel2abs( $path ) ; - } - else { - $path = $self->canonpath( $path ) ; - } + ($path, $base) = map $self->canonpath($_), $path, $base; - # Figure out the effective $base and clean it up. - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; + my $path_directories; + my $base_directories; + + if (grep $self->file_name_is_absolute($_), $path, $base) { + ($path, $base) = map $self->rel2abs($_), $path, $base; + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + $path_directories = ($self->splitpath($path, 1))[1]; + $base_directories = ($self->splitpath($base, 1))[1]; + + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } } else { - $base = $self->canonpath( $base ) ; + my $wd= ($self->splitpath($self->_cwd(), 1))[1]; + $path_directories = $self->catdir($wd, $path); + $base_directories = $self->catdir($wd, $base); } # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path); - my @basechunks = $self->splitdir( $base); + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); - while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { - shift @pathchunks ; - shift @basechunks ; + if ($base_directories eq $self->rootdir) { + return $self->curdir if $path_directories eq $self->rootdir; + shift @pathchunks; + return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); } - $path = CORE::join( '/', @pathchunks ); - $base = CORE::join( '/', @basechunks ); - - # $base now contains the directories the resulting relative path - # must ascend out of before it can descend to $path_directory. So, - # replace all names with $parentDir - $base =~ s|[^/]+|..|g ; - - # Glue the two together, using a separator if necessary, and preventing an - # empty result. - if ( $path ne '' && $base ne '' ) { - $path = "$base/$path" ; - } else { - $path = "$base$path" ; + my @common; + while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { + push @common, shift @pathchunks ; + shift @basechunks ; } + return $self->curdir unless @pathchunks || @basechunks; + + # @basechunks now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. If there + # are updir components, we must descend into the corresponding directories + # (this only works if they are no symlinks). + my @reverse_base; + while( defined(my $dir= shift @basechunks) ) { + if( $dir ne $self->updir ) { + unshift @reverse_base, $self->updir; + push @common, $dir; + } + elsif( @common ) { + if( @reverse_base && $reverse_base[0] eq $self->updir ) { + shift @reverse_base; + pop @common; + } + else { + unshift @reverse_base, pop @common; + } + } + } + my $result_dirs = $self->catdir( @reverse_base, @pathchunks ); + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} - return $self->canonpath( $path ) ; +sub _same { + $_[1] eq $_[2]; } =item rel2abs() @@ -445,6 +537,15 @@ sub rel2abs { =back +=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. + +Please submit bug reports and patches to perlbug@perl.org. + =head1 SEE ALSO L<File::Spec> @@ -456,7 +557,42 @@ L<File::Spec> # File::Spec subclasses use this. sub _cwd { require Cwd; - Cwd::cwd(); + Cwd::getcwd(); } + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + pop @dirs if @dirs && $dirs[-1] eq ''; + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + + 1; diff --git a/cpan/lib/File/Spec/VMS.pm b/cpan/lib/File/Spec/VMS.pm index 362cdaa2..600c49fa 100644 --- a/cpan/lib/File/Spec/VMS.pm +++ b/cpan/lib/File/Spec/VMS.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.4'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -25,239 +26,238 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. -=over 4 - -=item eliminate_macros +The default behavior is to allow either VMS or Unix syntax on input and to +return VMS syntax on output unless Unix syntax has been explicitly requested +via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature. -Expands MM[KS]/Make macros in a text string, using the contents of -identically named elements of C<%$self>, and returns the result -as a file specification in Unix syntax. +=over 4 =cut -sub eliminate_macros { - my($self,$path) = @_; - return '' unless $path; - $self = {} unless ref $self; +# Need to look up the feature settings. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. - if ($path =~ /\s/) { - return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; +my $use_feature; +BEGIN { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_feature = 1; } - - my($npath) = unixify($path); - 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 ($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; } -=item fixpath - -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. - -If optional second argument has a TRUE value, then the return string is -a VMS-syntax directory specification, if it is FALSE, the return string -is a VMS-syntax file specification, and if it is not specified, fixpath() -checks to see whether it matches the name of a directory in the current -default directory, and returns a directory or file specification accordingly. - -=cut - -sub fixpath { - my($self,$path,$force_path) = @_; - return '' unless $path; - $self = bless {} 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; +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _unix_rpt { + my $unix_rpt; + if ($use_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; } - - # 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; + return $unix_rpt; } -=back - -=head2 Methods always loaded - -=over 4 - =item canonpath (override) -Removes redundant portions of file specifications according to VMS syntax. +Removes redundant portions of file specifications and returns results +in native syntax unless Unix filename reporting has been enabled. =cut + sub canonpath { my($self,$path) = @_; - if ($path =~ m|/|) { # Fake Unix + return undef unless defined $path; + + my $unix_rpt = $self->_unix_rpt; + + if ($path =~ m|/|) { my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); - if ($pathify) { return vmspath($path); } - else { return vmsify($path); } - } - else { - $path =~ s/([\[<])000000\./$1/g; # [000000.foo ==> [foo - $path =~ s/([^-]+)\.(\]\[|><)?000000([\]\>])/$1$3/g; # foo.000000] ==> foo] - $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar - 1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [-- - $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar] - $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s - $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo - $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode - $path =~ s/^[\[<\]>]{2}//; # []foo ==> foo - return $path; + + return $path if $unix_rpt; + $path = $pathify ? vmspath($path) : vmsify($path); } + + $path =~ s/(?<!\^)</[/; # < and > ==> [ and ] + $path =~ s/(?<!\^)>/]/; + $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ + $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ + $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] + $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar + 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); + # That loop does the following + # with any amount of dashes: + # .-.-. ==> .--. + # [-.-. ==> [--. + # .-.-] ==> .--] + # [-.-] ==> [--] + 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + # That loop does the following + # with any amount (minimum 2) + # of dashes: + # .foo.--. ==> .-. + # .foo.--] ==> .-] + # [foo.--. ==> [-. + # [foo.--] ==> [-] + # + # And then, the remaining cases + $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [- + $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . + $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + # [foo.-] ==> [000000] + $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g; + # [] ==> + $path =~ s/(?<!\^)\[\]// unless $path eq '[]'; + return $unix_rpt ? unixify($path) : $path; } -=item catdir +=item catdir (override) Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" -cases (e.g. elements other than the first being absolute filespecs). +native directory specification unless the Unix filename reporting feature +has been enabled. No check is made for "impossible" cases (e.g. elements +other than the first being absolute filespecs). =cut sub catdir { - my ($self,@dirs) = @_; - my $dir = pop @dirs; - @dirs = grep($_,@dirs); + my $self = shift; + my $dir = pop; + + my $unix_rpt = $self->_unix_rpt; + + my @dirs = grep {defined() && length()} @_; + my $rslt; if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",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". + $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; + + if ($unix_rpt) { + $spath = unixify($spath) unless $spath =~ m#/#; + $sdir= unixify($sdir) unless $sdir =~ m#/#; + return $self->SUPER::catdir($spath, $sdir) + } + + $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 + # eliminate_macros(), since Unix syntax has no way to express + # "absolute from the top of this device's directory tree". if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } - } - else { - if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + + } else { + # Single directory. Return an empty string on null input; otherwise + # just return a canonical path. + + if (not defined $dir or not length $dir) { + $rslt = ''; + } else { + $rslt = $unix_rpt ? $dir : vmspath($dir); + } } return $self->canonpath($rslt); } -=item catfile +=item catfile (override) -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. +Concatenates a list of directory specifications with a filename specification +to build a path. =cut sub catfile { - my ($self,@files) = @_; - my $file = $self->canonpath(pop @files); - @files = grep($_,@files); + my $self = shift; + my $tfile = pop(); + my $file = $self->canonpath($tfile); + my @files = grep {defined() && length()} @_; + + my $unix_rpt = $self->_unix_rpt; + my $rslt; if (@files) { my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; - if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { + + # Something building a VMS path in pieces may try to pass a + # directory name in filename format, so normalize it. + $spath =~ s/\.dir\Z(?!\n)//i; + + # If the spath ends with a directory delimiter and the file is bare, + # then just concatenate them. + if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } else { + $rslt = unixify($spath); + $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); + $rslt = vmsify($rslt) unless $unix_rpt; } } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); + else { + # Only passed a single file? + my $xfile = (defined($file) && length($file)) ? $file : ''; + + $rslt = $unix_rpt ? $xfile : vmsify($xfile); + } + return $self->canonpath($rslt) unless $unix_rpt; + + # In Unix report mode, do not strip off redundant path information. + return $rslt; } =item curdir (override) -Returns a string representation of the current directory: '[]' +Returns a string representation of the current directory: '[]' or '.' =cut sub curdir { + my $self = shift @_; + return '.' if ($self->_unix_rpt); return '[]'; } =item devnull (override) -Returns a string representation of the null device: '_NLA0:' +Returns a string representation of the null device: '_NLA0:' or '/dev/null' =cut sub devnull { + my $self = shift @_; + return '/dev/null' if ($self->_unix_rpt); return "_NLA0:"; } =item rootdir (override) Returns a string representation of the root directory: 'SYS$DISK:[000000]' +or '/' =cut sub rootdir { + my $self = shift @_; + if ($self->_unix_rpt) { + # Root may exist, try it first. + my $try = '/'; + my ($dev1, $ino1) = stat('/'); + my ($dev2, $ino2) = stat('.'); + + # Perl falls back to '.' if it can not determine '/' + if (($dev1 != $dev2) || ($ino1 != $ino2)) { + return $try; + } + # Fall back to UNIX format sys$disk. + return '/sys$disk/'; + } return 'SYS$DISK:[000000]'; } @@ -266,28 +266,37 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: + /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled. sys$scratch: $ENV{TMPDIR} -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +If running under taint mode, and if $ENV{TMPDIR} is tainted, it is not used. =cut -my $tmpdir; sub tmpdir { + my $self = shift @_; + my $tmpdir = $self->_cached_tmpdir('TMPDIR'); return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + if ($self->_unix_rpt) { + $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); + } + else { + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + } + $self->_cache_tmpdir($tmpdir, 'TMPDIR'); } =item updir (override) -Returns a string representation of the parent directory: '[-]' +Returns a string representation of the parent directory: '[-]' or '..' =cut sub updir { + my $self = shift @_; + return '..' if ($self->_unix_rpt); return '[-]'; } @@ -326,34 +335,71 @@ sub file_name_is_absolute { $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; return scalar($file =~ m!^/!s || $file =~ m![<\[][^.\-\]>]! || - $file =~ /:[^<\[]/); + $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/); } =item splitpath (override) -Splits using VMS syntax. + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); + +Passing a true value for C<$no_file> indicates that the path being +split only contains directory components, even on systems where you +can usually (when not supporting a foreign syntax) tell the difference +between directories and files at a glance. =cut sub splitpath { - my($self,$path) = @_; - my($dev,$dir,$file) = ('','',''); - - vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; - return ($1 || '',$2 || '',$3); + my($self,$path, $nofile) = @_; + my($dev,$dir,$file) = ('','',''); + my $vmsify_path = vmsify($path); + + if ( $nofile ) { + #vmsify('d1/d2/d3') returns '[.d1.d2]d3' + #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' + if( $vmsify_path =~ /(.*)\](.+)/ ){ + $vmsify_path = $1.'.'.$2.']'; + } + $vmsify_path =~ /(.+:)?(.*)/s; + $dir = defined $2 ? $2 : ''; # dir can be '0' + return ($1 || '',$dir,$file); + } + else { + $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); + } } =item splitdir (override) -Split dirspec using VMS syntax. +Split a directory specification into the components. =cut sub splitdir { my($self,$dirspec) = @_; - $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; - $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal - my(@dirs) = split('\.', vmspath($dirspec)); + my @dirs = (); + return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); + + $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ] + $dirspec =~ s/(?<!\^)>/]/; + $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ + $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ + $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] + $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar + while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} + # That loop does the following + # with any amount of dashes: + # .--. ==> .-.-. + # [--. ==> [-.-. + # .--] ==> .-.-] + # [--] ==> [-.-] + $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal + $dirspec =~ s/^(\[|<)\./$1/; + @dirs = split /(?<!\^)\./, vmspath($dirspec); $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; @dirs; } @@ -361,7 +407,7 @@ sub splitdir { =item catpath (override) -Construct a complete filespec using VMS syntax +Construct a complete filespec. =cut @@ -373,30 +419,35 @@ sub catpath { $dev = $dir_volume unless length $dev; $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; - if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; } else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { - $dir = "[$dir]" unless $dir =~ /[\[<\/]/; - $dir = vmspath($dir); + $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/; + $dir = vmspath($dir); } + $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>'); "$dev$dir$file"; } =item abs2rel (override) -Use VMS syntax when converting filespecs. +Attempt to convert an absolute file specification to a relative specification. =cut 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" @@ -412,12 +463,12 @@ sub abs2rel { 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; unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; my @basechunks = $self->splitdir( $base_directories ); + my $basechunks = @basechunks; unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; while ( @pathchunks && @@ -430,23 +481,34 @@ sub abs2rel { # @basechunks now contains the directories to climb out of, # @pathchunks now has the directories to descend in to. - $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + if ((@basechunks > 0) || ($basechunks != $pathchunks)) { + $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + } + else { + $path_directories = join '.', @pathchunks; + } + $path_directories = '['.$path_directories.']'; return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; } =item rel2abs (override) -Use VMS syntax when converting filespecs. +Return an absolute file specification from a relative one. =cut sub rel2abs { my $self = shift ; - return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) - if ( join( '', @_ ) =~ m{/} ) ; - my ($path,$base ) = @_; + return undef unless defined $path; + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + $base = vmspath($base) if defined $base && $base =~ m/\//; + # Clean up and split up $path if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. @@ -486,13 +548,20 @@ sub rel2abs { =back +=head1 COPYRIGHT + +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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the implementation of these methods, not the semantics. An explanation of VMS file specs can be found at -L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">. +L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>. =cut diff --git a/cpan/lib/File/Spec/Win32.pm b/cpan/lib/File/Spec/Win32.pm index 1a91b95a..6df7ee87 100644 --- a/cpan/lib/File/Spec/Win32.pm +++ b/cpan/lib/File/Spec/Win32.pm @@ -5,10 +5,17 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.4'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); +# Some regexes we use for path splitting +my $DRIVE_RX = '[a-zA-Z]:'; +my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; +my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; + + =head1 NAME File::Spec::Win32 - methods for Win32 file specs @@ -35,6 +42,9 @@ sub devnull { return "nul"; } +sub rootdir { '\\' } + + =item tmpdir Returns a string representation of the first existing directory @@ -44,36 +54,70 @@ from the following list: $ENV{TEMP} $ENV{TMP} SYS:/temp + C:\system\temp C:/temp /tmp / -The SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32 -is used also for NetWare). +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). -Since Perl 5.8.0, if running under taint mode, and if the environment +If running under taint mode, and if the environment variables are tainted, they are not used. =cut -my $tmpdir; sub tmpdir { + my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP)); return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, + $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), 'SYS:/temp', + 'C:\system\temp', 'C:/temp', '/tmp', '/' ); + $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP)); } +=item case_tolerant + +MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. +See http://cygwin.com/ml/cygwin/2007-07/msg00891.html +Default: 1 + +=cut + sub case_tolerant { - return 1; + eval { require Win32API::File; } or return 1; + my $drive = shift || "C:"; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } } +=item file_name_is_absolute + +As of right now, this returns 2 if the path is absolute with a +volume, 1 if it's absolute with no volume, 0 otherwise. + +=cut + sub file_name_is_absolute { + my ($self,$file) = @_; - return scalar($file =~ m{^([a-z]:)?[\\/]}is); + + if ($file =~ m{^($VOL_RX)}o) { + my $vol = $1; + return ($vol =~ m{^$UNC_RX}o ? 2 + : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 + : 0); + } + return $file =~ m{^[\\/]} ? 1 : 0; } =item catfile @@ -84,29 +128,44 @@ complete path ending with a filename =cut sub catfile { - my $self = shift; - my $file = $self->canonpath(pop @_); - return $file unless @_; - my $dir = $self->catdir(@_); - $dir .= "\\" unless substr($dir,-1) eq "\\"; - return $dir.$file; + shift; + + # Legacy / compatibility support + # + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catfile('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); } sub catdir { - my $self = shift; - my @args = @_; - foreach (@args) { - tr[/][\\]; - # append a backslash to each argument unless it has one there - $_ .= "\\" unless m{\\$}; - } - return $self->canonpath(join('', @args)); + shift; + + # Legacy / compatibility support + # + return "" + unless @_; + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catdir('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); } sub path { - my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; - my @path = split(';',$path); - foreach (@path) { $_ = '.' if $_ eq '' } + my @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + unshift(@path, "."); return @path; } @@ -122,53 +181,17 @@ On Win32 makes =cut sub canonpath { - my ($self,$path) = @_; - my $orig_path = $path; - $path =~ s/^([a-z]:)/\u$1/s; - $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx - $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx - $path =~ s|\\\Z(?!\n)|| - unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx - # xx1/xx2/xx3/../../xx -> xx1/xx - $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up - $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up - return $path if $path =~ m|^\.\.|; # skip relative paths - return $path unless $path =~ /\.\./; # too few .'s to cleanup - return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup - $path =~ s{^\\\.\.$}{\\}; # \.. -> \ - 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx - - my ($vol,$dirs,$file) = $self->splitpath($path); - my @dirs = $self->splitdir($dirs); - my (@base_dirs, @path_dirs); - my $dest = \@base_dirs; - for my $dir (@dirs){ - $dest = \@path_dirs if $dir eq $self->updir; - push @$dest, $dir; - } - # for each .. in @path_dirs pop one item from - # @base_dirs - while (my $dir = shift @path_dirs){ - unless ($dir eq $self->updir){ - unshift @path_dirs, $dir; - last; - } - pop @base_dirs; - } - $path = $self->catpath( - $vol, - $self->catdir(@base_dirs, @path_dirs), - $file - ); - return $path; + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); } =item splitpath - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Splits a path into volume, directory, and filename portions. Assumes that the last file is a path unless the path ends in '\\', '\\.', '\\..' @@ -189,21 +212,16 @@ sub splitpath { my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { $path =~ - m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) - (.*) - }xs; + m{^ ( $VOL_RX ? ) (.*) }sox; $volume = $1; $directory = $2; } else { $path =~ - m{^ ( (?: [a-zA-Z]: | - (?:\\\\|//)[^\\/]+[\\/][^\\/]+ - )? - ) - ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + m{^ ( $VOL_RX ? ) + ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) (.*) - }xs; + }sox; $volume = $1; $directory = $2; $file = $3; @@ -215,7 +233,7 @@ sub splitpath { =item splitdir -The opposite of L<catdir()|File::Spec/catdir()>. +The opposite of L<catdir()|File::Spec/catdir>. @dirs = File::Spec->splitdir( $directories ); @@ -270,8 +288,9 @@ sub catpath { # If it's UNC, make sure the glue separator is there, reusing # whatever separator is first in the $volume - $volume .= $1 - if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + my $v; + $volume .= $v + if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && $directory =~ m@^[^\\/]@s ) ; @@ -293,69 +312,47 @@ sub catpath { return $volume ; } +sub _same { + lc($_[1]) eq lc($_[2]); +} -sub abs2rel { - my($self,$path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; - - for ($path, $base) { $_ = $self->canonpath($_) } - - my ($path_volume) = $self->splitpath($path, 1); - my ($base_volume) = $self->splitpath($base, 1); - - # Can't relativize across volumes - return $path unless $path_volume eq $base_volume; - - for ($path, $base) { $_ = $self->rel2abs($_) } +sub rel2abs { + my ($self,$path,$base ) = @_; - my $path_directories = ($self->splitpath($path, 1))[1]; - my $base_directories = ($self->splitpath($base, 1))[1]; + my $is_abs = $self->file_name_is_absolute($path); - # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path_directories ); - my @basechunks = $self->splitdir( $base_directories ); + # Check for volume (should probably document the '2' thing...) + return $self->canonpath( $path ) if $is_abs == 2; - while ( @pathchunks && - @basechunks && - lc( $pathchunks[0] ) eq lc( $basechunks[0] ) - ) { - shift @pathchunks ; - shift @basechunks ; + if ($is_abs) { + # It's missing a volume, add one + my $vol = ($self->splitpath( $self->_cwd() ))[0]; + return $self->canonpath( $vol . $path ); } - my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); - - return $self->canonpath( $self->catpath('', $result_dirs, '') ); -} + if ( !defined( $base ) || $base eq '' ) { + require Cwd ; + $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; + $base = $self->_cwd() unless defined $base ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; -sub rel2abs { - my ($self,$path,$base ) = @_; + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; - if ( ! $self->file_name_is_absolute( $path ) ) { - - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd() ; - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } - else { - $base = $self->canonpath( $base ) ; - } - - my ( $path_directories, $path_file ) = - ($self->splitpath( $path, 1 ))[1,2] ; - - my ( $base_volume, $base_directories ) = - $self->splitpath( $base, 1 ) ; - - $path = $self->catpath( - $base_volume, - $self->catdir( $base_directories, $path_directories ), - $path_file - ) ; - } + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; return $self->canonpath( $path ) ; } @@ -366,6 +363,13 @@ sub rel2abs { Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. +=head1 COPYRIGHT + +Copyright (c) 2004,2007 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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the @@ -373,4 +377,70 @@ implementation of these methods, not the semantics. =cut + +sub _canon_cat # @path -> path +{ + my ($first, @rest) = @_; + + my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter + ? ucfirst( $1 ).( $2 ? "\\" : "" ) + : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) + (?: [\\/] ([^\\/]+) )? + [\\/]? }{}xs # UNC volume + ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" + : $first =~ s{ \A [\\/] }{}x # root dir + ? "\\" + : ""; + my $path = join "\\", $first, @rest; + + $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy + + # xx/././yy --> xx/yy + $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + \. + (?:\\\.)* # and more + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}gx; + + # XXX I do not know whether more dots are supported by the OS supporting + # this ... annotation (NetWare or symbian but not MSWin32). + # Then .... could easily become ../../.. etc: + # Replace \.\.\. by (\.\.\.+) and substitute with + # { $1 . ".." . "\\.." x (length($2)-2) }gex + # ... --> ../.. + $path =~ s{ (\A|\\) # at begin or after a slash + \.\.\. + (?=\\|\z) # at end or followed by slash + }{$1..\\..}gx; + # xx\yy\..\zz --> xx\zz + while ( $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + [^\\]+ # rip this 'yy' off + \\\.\. + (?<!\A\.\.\\\.\.) # do *not* replace ^..\.. + (?<!\\\.\.\\\.\.) # do *not* replace \..\.. + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}sx ) {} + + $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # <vol>\.. --> <vol>\ + $path =~ s{ \A # at begin + \.\. + (?:\\\.\.)* # and more + (?:\\|\z) # at end or followed by slash + }{}x; + + return $1 # \\HOST\SHARE\ --> \\HOST\SHARE + if $path eq "" + and $volume =~ m#\A(\\\\.*)\\\z#s; + } + return $path ne "" || $volume ? $volume.$path : "."; +} + 1; |