dslinux/user/perl/lib/File Basename.pm Basename.t CheckTree.pm CheckTree.t Compare.pm Compare.t Copy.pm Copy.t DosGlob.pm DosGlob.t Find.pm Path.pm Path.t Spec.pm Temp.pm stat.pm stat.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:38 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/File
In directory antilope:/tmp/cvs-serv17422/lib/File

Added Files:
	Basename.pm Basename.t CheckTree.pm CheckTree.t Compare.pm 
	Compare.t Copy.pm Copy.t DosGlob.pm DosGlob.t Find.pm Path.pm 
	Path.t Spec.pm Temp.pm stat.pm stat.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: Copy.t ---
#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use Test::More;

my $TB = Test::More->builder;

plan tests => 60;

# We're going to override rename() later on but Perl has to see an override
# at compile time to honor it.
BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }


use File::Copy;
use Config;


foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')",
                  "move()", "move('arg')", "move('arg', 'arg', 'arg')"
                 )
{
    eval $code;
    like $@, qr/^Usage: /;
}


for my $cross_partition_test (0..1) {
  {
    # Simulate a cross-partition copy/move by forcing rename to
    # fail.
    no warnings 'redefine';
    *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
  }

  # First we create a file
  open(F, ">file-$$") or die;
  binmode F; # for DOSISH platforms, because test 3 copies to stdout
  printf F "ok\n";
  close F;

  copy "file-$$", "copy-$$";

  open(F, "copy-$$") or die;
  $foo = <F>;
  close(F);

  is -s "file-$$", -s "copy-$$";

  is $foo, "ok\n";

  binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
  # This outputs "ok" so its a test.
  copy "copy-$$", \*STDOUT;
  $TB->current_test($TB->current_test + 1);
  unlink "copy-$$" or die "unlink: $!";

  open(F,"file-$$");
  copy(*F, "copy-$$");
  open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
  is $foo, "ok\n";
  unlink "copy-$$" or die "unlink: $!";

  open(F,"file-$$");
  copy(\*F, "copy-$$");
  close(F) or die "close: $!";
  open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
  is $foo, "ok\n";
  unlink "copy-$$" or die "unlink: $!";

  require IO::File;
  $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
  binmode $fh or die;
  copy("file-$$",$fh);
  $fh->close or die "close: $!";
  open(R, "copy-$$") or die; $foo = <R>; close(R);
  is $foo, "ok\n";
  unlink "copy-$$" or die "unlink: $!";

  require FileHandle;
  my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
  binmode $fh or die;
  copy("file-$$",$fh);
  $fh->close;
  open(R, "copy-$$") or die; $foo = <R>; close(R);
  is $foo, "ok\n";
  unlink "file-$$" or die "unlink: $!";

  ok !move("file-$$", "copy-$$"), "move on missing file";
  ok -e "copy-$$",                '  target still there';

  # Doesn't really matter what time it is as long as its not now.
  my $time = 1000000000;
  utime( $time, $time, "copy-$$" );

  # Recheck the mtime rather than rely on utime in case we're on a
  # system where utime doesn't work or there's no mtime at all.
  # The destination file will reflect the same difficulties.
  my $mtime = (stat("copy-$$"))[9];

  ok move("copy-$$", "file-$$"), 'move';
  ok -e "file-$$",              '  destination exists';
  ok !-e "copy-$$",              '  source does not';
  open(R, "file-$$") or die; $foo = <R>; close(R);
  is $foo, "ok\n";

  TODO: {
    local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS';

    my $dest_mtime = (stat("file-$$"))[9];
    is $dest_mtime, $mtime,
      "mtime preserved by copy()". 
      ($cross_partition_test ? " while testing cross-partition" : "");
  }

  copy "file-$$", "lib";
  open(R, "lib/file-$$") or die; $foo = <R>; close(R);
  is $foo, "ok\n";
  unlink "lib/file-$$" or die "unlink: $!";

  # Do it twice to ensure copying over the same file works.
  copy "file-$$", "lib";
  open(R, "lib/file-$$") or die; $foo = <R>; close(R);
  is $foo, "ok\n";
  unlink "lib/file-$$" or die "unlink: $!";

  { 
    my $warnings = '';
    local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
    ok copy("file-$$", "file-$$");

    like $warnings, qr/are identical/;
    ok -s "file-$$";
  }

  move "file-$$", "lib";
  open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
  is $foo, "ok\n";
  ok !-e "file-$$";
  unlink "lib/file-$$" or die "unlink: $!";

  SKIP: {
    skip "Testing symlinks", 3 unless $Config{d_symlink};

    open(F, ">file-$$") or die $!;
    print F "dummy content\n";
    close F;
    symlink("file-$$", "symlink-$$") or die $!;

    my $warnings = '';
    local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
    ok !copy("file-$$", "symlink-$$");

    like $warnings, qr/are identical/;
    ok !-z "file-$$", 
      'rt.perl.org 5196: copying to itself would truncate the file';

    unlink "symlink-$$";
    unlink "file-$$";
  }

  SKIP: {
    skip "Testing hard links", 3 if !$Config{d_link} or $^O eq 'MSWin32';

    open(F, ">file-$$") or die $!;
    print F "dummy content\n";
    close F;
    link("file-$$", "hardlink-$$") or die $!;

    my $warnings = '';
    local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
    ok !copy("file-$$", "hardlink-$$");

    like $warnings, qr/are identical/;
    ok ! -z "file-$$",
      'rt.perl.org 5196: copying to itself would truncate the file';

    unlink "hardlink-$$";
    unlink "file-$$";
  }
}


END {
    1 while unlink "file-$$";
    1 while unlink "lib/file-$$";
}

--- NEW FILE: stat.t ---
#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use Test::More;

BEGIN {
    our $hasst;
    eval { my @n = stat "TEST" };
    $hasst = 1 unless $@ && $@ =~ /unimplemented/;
    unless ($hasst) { plan skip_all => "no stat"; exit 0 }
    use Config;
    $hasst = 0 unless $Config{'i_sysstat'} eq 'define';
    unless ($hasst) { plan skip_all => "no sys/stat.h"; exit 0 }
    our @stat = stat "TEST"; # This is the function stat.
    unless (@stat) { plan skip_all => "1..0 # Skip: no file TEST"; exit 0 }
}

plan tests => 19;

use_ok( 'File::stat' );

my $stat = File::stat::stat( "TEST" ); # This is the OO stat.
ok( ref($stat), 'should build a stat object' );

is( $stat->dev, $stat[0], "device number in position 0" );

# On OS/2 (fake) ino is not constant, it is incremented each time
SKIP: {
	skip('inode number is not constant on OS/2', 1) if $^O eq 'os2';
	is( $stat->ino, $stat[1], "inode number in position 1" );
}

is( $stat->mode, $stat[2], "file mode in position 2" );

is( $stat->nlink, $stat[3], "number of links in position 3" );

is( $stat->uid, $stat[4], "owner uid in position 4" );

is( $stat->gid, $stat[5], "group id in position 5" );

is( $stat->rdev, $stat[6], "device identifier in position 6" );

is( $stat->size, $stat[7], "file size in position 7" );

is( $stat->atime, $stat[8], "last access time in position 8" );

is( $stat->mtime, $stat[9], "last modify time in position 9" );

is( $stat->ctime, $stat[10], "change time in position 10" );

is( $stat->blksize, $stat[11], "IO block size in position 11" );

is( $stat->blocks, $stat[12], "number of blocks in position 12" );

SKIP: {
	local *STAT;
	skip("Could not open file: $!", 2) unless open(STAT, 'TEST');
	ok( File::stat::stat('STAT'), '... should be able to find filehandle' );

	package foo;
	local *STAT = *main::STAT;
	main::ok( my $stat2 = File::stat::stat('STAT'), 
		'... and filehandle in another package' );
	close STAT;

#	VOS open() updates atime; ignore this error (posix-975).
	my $stat3 = $stat2;
	if ($^O eq 'vos') {
		$$stat3[8] = $$stat[8];
	}

	main::skip("Win32: different stat-info on filehandle", 1) if $^O eq 'MSWin32';
	main::skip("dos: inode number is fake on dos", 1) if $^O eq 'dos';

	main::skip("OS/2: inode number is not constant on os/2", 1) if $^O eq 'os2';

	main::is( "@$stat", "@$stat3", '... and must match normal stat' );
}

local $!;
$stat = stat '/notafile';
isn't( $!, '', 'should populate $!, given invalid file' );

# Testing pretty much anything else is unportable.

--- NEW FILE: stat.pm ---
package File::stat;
use 5.006;

use strict;
use warnings;

our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);

our $VERSION = '1.00';

BEGIN { 
    use Exporter   ();
    @EXPORT      = qw(stat lstat);
    @EXPORT_OK   = qw( $st_dev	   $st_ino    $st_mode 
		       $st_nlink   $st_uid    $st_gid 
		       $st_rdev    $st_size 
		       $st_atime   $st_mtime  $st_ctime 
		       $st_blksize $st_blocks
		    );
    %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
}
use vars @EXPORT_OK;

# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }

use Class::Struct qw(struct);
struct 'File::stat' => [
     map { $_ => '$' } qw{
	 dev ino mode nlink uid gid rdev size
	 atime mtime ctime blksize blocks
     }
];

sub populate (@) {
    return unless @_;
    my $stob = new();
    @$stob = (
	$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
        $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) 
	    = @_;
    return $stob;
} 

sub lstat ($)  { populate(CORE::lstat(shift)) }

sub stat ($) {
    my $arg = shift;
    my $st = populate(CORE::stat $arg);
    return $st if $st;
	my $fh;
    {
		local $!;
		no strict 'refs';
		require Symbol;
		$fh = \*{ Symbol::qualify( $arg, caller() )};
		return unless defined fileno $fh;
	}
    return populate(CORE::stat $fh);
}

1;
__END__

=head1 NAME

File::stat - by-name interface to Perl's built-in stat() functions

=head1 SYNOPSIS

 use File::stat;
 $st = stat($file) or die "No $file: $!";
 if ( ($st->mode & 0111) && $st->nlink > 1) ) {
     print "$file is executable with lotsa links\n";
 } 

 use File::stat qw(:FIELDS);
 stat($file) or die "No $file: $!";
 if ( ($st_mode & 0111) && $st_nlink > 1) ) {
     print "$file is executable with lotsa links\n";
 } 

=head1 DESCRIPTION

This module's default exports override the core stat() 
and lstat() functions, replacing them with versions that return 
"File::stat" objects.  This object has methods that
return the similarly named structure field name from the
stat(2) function; namely,
dev,
ino,
mode,
nlink,
uid,
gid,
rdev,
size,
atime,
mtime,
ctime,
blksize,
and
blocks.  

You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag.  (Note that this still
overrides your stat() and lstat() functions.)  Access these fields as
variables named with a preceding C<st_> in front their method names.
Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
the fields.

To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.

=head1 BUGS

As of Perl 5.8.0 after using this module you cannot use the implicit
C<$_> or the special filehandle C<_> with stat() or lstat(), trying
to do so leads into strange errors.  The workaround is for C<$_> to
be explicit

    my $stat_obj = stat $_;

and for C<_> to explicitly populate the object using the unexported
and undocumented populate() function with CORE::stat():

    my $stat_obj = File::stat::populate(CORE::stat(_));

=head1 NOTE

While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.

=head1 AUTHOR

Tom Christiansen

--- NEW FILE: Basename.pm ---
=head1 NAME

File::Basename - Parse file paths into directory, filename and suffix.

=head1 SYNOPSIS

    use File::Basename;

    ($name,$path,$suffix) = fileparse($fullname, at suffixlist);
    $name = fileparse($fullname, at suffixlist);

    $basename = basename($fullname, at suffixlist);
    $dirname  = dirname($fullname);


=head1 DESCRIPTION

These routines allow you to parse file paths into their directory, filename
and suffix.

B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
quirks, of the shell and C functions of the same name.  See each
function's documentation for details.  If your concern is just parsing
paths it is safer to use L<File::Spec>'s C<splitpath()> and
C<splitdir()> methods.

It is guaranteed that

    # Where $path_separator is / for Unix, \ for Windows, etc...
    dirname($path) . $path_separator . basename($path);

is equivalent to the original path for all systems but VMS.


=cut


package File::Basename;

# A bit of juggling to insure that C<use re 'taint';> always works, since
# File::Basename is used during the Perl build, when the re extension may
# not be available.
BEGIN {
  unless (eval { require re; })
    { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT
  import re 'taint';
}


use strict;
use 5.006;
use warnings;
our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
$VERSION = "2.74";

fileparse_set_fstype($^O);


=over 4

=item C<fileparse>

    my($filename, $directories, $suffix) = fileparse($path);
    my($filename, $directories, $suffix) = fileparse($path, @suffixes);
    my $filename                         = fileparse($path, @suffixes);

The C<fileparse()> routine divides a file path into its $directories, $filename
and (optionally) the filename $suffix.

$directories contains everything up to and including the last
directory separator in the $path including the volume (if applicable).
The remainder of the $path is the $filename.

     # On Unix returns ("baz", "/foo/bar/", "")
     fileparse("/foo/bar/baz");

     # On Windows returns ("baz", "C:\foo\bar\", "")
     fileparse("C:\foo\bar\baz");

     # On Unix returns ("", "/foo/bar/baz/", "")
     fileparse("/foo/bar/baz/");

If @suffixes are given each element is a pattern (either a string or a
C<qr//>) matched against the end of the $filename.  The matching
portion is removed and becomes the $suffix.

     # On Unix returns ("baz", "/foo/bar", ".txt")
     fileparse("/foo/bar/baz", qr/\.[^.]*/);

If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern
matching for suffix removal is performed case-insensitively, since
those systems are not case-sensitive when opening existing files.

You are guaranteed that C<$directories . $filename . $suffix> will
denote the same location as the original $path.

=cut


sub fileparse {
  my($fullname, at suffices) = @_;

  unless (defined $fullname) {
      require Carp;
      Carp::croak("fileparse(): need a valid pathname");
  }

  my $orig_type = '';
  my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);

  my($taint) = substr($fullname,0,0);  # Is $fullname tainted?

  if ($type eq "VMS" and $fullname =~ m{/} ) {
    # We're doing Unix emulation
    $orig_type = $type;
    $type = 'Unix';
  }

  my($dirpath, $basename);

  if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
    ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
    $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
  }
  elsif ($type eq "OS2") {
    ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
    $dirpath = './' unless $dirpath;	# Can't be 0
    $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
  }
  elsif ($type eq "MacOS") {
    ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
    $dirpath = ':' unless $dirpath;
  }
  elsif ($type eq "AmigaOS") {
    ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
    $dirpath = './' unless $dirpath;
  }
  elsif ($type eq 'VMS' ) {
    ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
    $dirpath ||= '';  # should always be defined
  }
  else { # Default to Unix semantics.
    ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
    if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
      # dev:[000000] is top of VMS tree, similar to Unix '/'
      # so strip it off and treat the rest as "normal"
      my $devspec  = $1;
      my $remainder = $3;
      ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s);
      $dirpath ||= '';  # should always be defined
      $dirpath = $devspec.$dirpath;
    }
    $dirpath = './' unless $dirpath;
  }
      

  my $tail   = '';
  my $suffix = '';
  if (@suffices) {
    foreach $suffix (@suffices) {
      my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
      if ($basename =~ s/$pat//s) {
        $taint .= substr($suffix,0,0);
        $tail = $1 . $tail;
      }
    }
  }

  # Ensure taint is propgated from the path to its pieces.
  $tail .= $taint;
  wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
            : ($basename .= $taint);
}



=item C<basename>

    my $filename = basename($path);
    my $filename = basename($path, @suffixes);

This function is provided for compatibility with the Unix shell command 
C<basename(1)>.  It does B<NOT> always return the file name portion of a
path as you might expect.  To be safe, if you want the file name portion of
a path use C<fileparse()>.

C<basename()> returns the last level of a filepath even if the last
level is clearly directory.  In effect, it is acting like C<pop()> for
paths.  This differs from C<fileparse()>'s behaviour.

    # Both return "bar"
    basename("/foo/bar");
    basename("/foo/bar/");

@suffixes work as in C<fileparse()> except all regex metacharacters are
quoted.

    # These two function calls are equivalent.
    my $filename = basename("/foo/bar/baz.txt",  ".txt");
    my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);

Also note that in order to be compatible with the shell command,
C<basename()> does not strip off a suffix if it is identical to the
remaining characters in the filename.

=cut


sub basename {
  my($path) = shift;

  # From BSD basename(1)
  # The basename utility deletes any prefix ending with the last slash `/'
  # character present in string (after first stripping trailing slashes)
  _strip_trailing_sep($path);

  my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E", at _) );

  # From BSD basename(1)
  # The suffix is not stripped if it is identical to the remaining 
  # characters in string.
  if( length $suffix and !length $basename ) {
      $basename = $suffix;
  }
  
  # Ensure that basename '/' == '/'
  if( !length $basename ) {
      $basename = $dirname;
  }

  return $basename;
}



=item C<dirname>

This function is provided for compatibility with the Unix shell
command C<dirname(1)> and has inherited some of its quirks.  In spite of
its name it does B<NOT> always return the directory name as you might
expect.  To be safe, if you want the directory name of a path use
C<fileparse()>.

Only on VMS (where there is no ambiguity between the file and directory
portions of a path) and AmigaOS (possibly due to an implementation quirk in
this module) does C<dirname()> work like C<fileparse($path)>, returning just the
$directories.

    # On VMS and AmigaOS
    my $directories = dirname($path);

When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
which is subtly different from how C<fileparse()> works.  It returns all but
the last level of a file path even if the last level is clearly a directory.
In effect, it is not returning the directory portion but simply the path one
level up acting like C<chop()> for file paths.

Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
its returned path.

    # returns /foo/bar.  fileparse() would return /foo/bar/
    dirname("/foo/bar/baz");

    # also returns /foo/bar despite the fact that baz is clearly a 
    # directory.  fileparse() would return /foo/bar/baz/
    dirname("/foo/bar/baz/");

    # returns '.'.  fileparse() would return 'foo/'
    dirname("foo/");

Under VMS, if there is no directory information in the $path, then the
current default device and directory is used.

=cut


sub dirname {
    my $path = shift;

    my($type) = $Fileparse_fstype;

    if( $type eq 'VMS' and $path =~ m{/} ) {
        # Parse as Unix
        local($File::Basename::Fileparse_fstype) = '';
        return dirname($path);
    }

    my($basename, $dirname) = fileparse($path);

    if ($type eq 'VMS') { 
        $dirname ||= $ENV{DEFAULT};
    }
    elsif ($type eq 'MacOS') {
	if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
            _strip_trailing_sep($dirname);
	    ($basename,$dirname) = fileparse $dirname;
	}
	$dirname .= ":" unless $dirname =~ /:\z/;
    }
    elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
        _strip_trailing_sep($dirname);
        unless( length($basename) ) {
	    ($basename,$dirname) = fileparse $dirname;
	    _strip_trailing_sep($dirname);
	}
    }
    elsif ($type eq 'AmigaOS') {
        if ( $dirname =~ /:\z/) { return $dirname }
        chop $dirname;
        $dirname =~ s#[^:/]+\z## unless length($basename);
    }
    else {
        _strip_trailing_sep($dirname);
        unless( length($basename) ) {
	    ($basename,$dirname) = fileparse $dirname;
	    _strip_trailing_sep($dirname);
	}
    }

    $dirname;
}


# Strip the trailing path separator.
sub _strip_trailing_sep  {
    my $type = $Fileparse_fstype;

    if ($type eq 'MacOS') {
        $_[0] =~ s/([^:]):\z/$1/s;
    }
    elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
        $_[0] =~ s/([^:])[\\\/]*\z/$1/;
    }
    else {
        $_[0] =~ s{(.)/*\z}{$1}s;
    }
}


=item C<fileparse_set_fstype>

  my $type = fileparse_set_fstype();
  my $previous_type = fileparse_set_fstype($type);

Normally File::Basename will assume a file path type native to your current
operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
With this function you can override that assumption.

Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
"Epoc" and "Unix" (all case-insensitive).  If an unrecognized $type is
given "Unix" will be assumed.

If you've selected VMS syntax, and the file specification you pass to
one of these routines contains a "/", they assume you are using Unix
emulation and apply the Unix syntax rules instead, for that function
call only.

=back

=cut


BEGIN {

my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
my @Types = (@Ignore_Case, qw(Unix));

sub fileparse_set_fstype {
    my $old = $Fileparse_fstype;

    if (@_) {
        my $new_type = shift;

        $Fileparse_fstype = 'Unix';  # default
        foreach my $type (@Types) {
            $Fileparse_fstype = $type if $new_type =~ /^$type/i;
        }

        $Fileparse_igncase = 
          (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
    }

    return $old;
}

}


1;


=head1 SEE ALSO

L<dirname(1)>, L<basename(1)>, L<File::Spec>

--- NEW FILE: Basename.t ---
#!./perl -Tw

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use Test::More tests => 64;

BEGIN { use_ok 'File::Basename' }

# import correctly?
can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );

### Testing Unix
{
    ok length fileparse_set_fstype('unix'), 'set fstype to unix';
    is( fileparse_set_fstype(), 'Unix',     'get fstype' );

    my($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
                                      qr'\.book\d+');
    is($base, 'draft');
    is($path, '/virgil/aeneid/');
    is($type, '.book7');

    is(basename('/arma/virumque.cano'), 'virumque.cano');
    is(dirname ('/arma/virumque.cano'), '/arma');
    is(dirname('arma/'), '.');
}


### Testing VMS
{
    is(fileparse_set_fstype('VMS'), 'Unix', 'set fstype to VMS');

    my($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7',
                                      qr{\.book\d+});
    is($base, 'draft');
    is($path, 'virgil:[aeneid]');
    is($type, '.book7');

    is(basename('arma:[virumque]cano.trojae'), 'cano.trojae');
    is(dirname('arma:[virumque]cano.trojae'),  'arma:[virumque]');
    is(dirname('arma:<virumque>cano.trojae'),  'arma:<virumque>');
    is(dirname('arma:virumque.cano'), 'arma:');

    {
        local $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
        is(dirname('virumque.cano'), $ENV{DEFAULT});
        is(dirname('arma/'), '.');
    }
}


### Testing DOS
{
    is(fileparse_set_fstype('DOS'), 'VMS', 'set fstype to DOS');

    my($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7',
                                      '\.book\d+');
    is($base, 'draft');
    is($path, 'C:\\virgil\\aeneid\\');
    is($type, '.book7');

    is(basename('A:virumque\\cano.trojae'),  'cano.trojae');
    is(dirname('A:\\virumque\\cano.trojae'), 'A:\\virumque');
    is(dirname('A:\\'), 'A:\\');
    is(dirname('arma\\'), '.');

    # Yes "/" is a legal path separator under DOS
    is(basename("lib/File/Basename.pm"), "Basename.pm");

    # $^O for DOS is "dos" not "MSDOS" but "MSDOS" is left in for
    # backward bug compat.
    is(fileparse_set_fstype('MSDOS'), 'DOS');
    is( dirname("\\foo\\bar\\baz"), "\\foo\\bar" );
}


### Testing MacOS
{
    is(fileparse_set_fstype('MacOS'), 'MSDOS', 'set fstype to MacOS');

    my($base,$path,$type) = fileparse('virgil:aeneid:draft.book7',
                                      '\.book\d+');
    is($base, 'draft');
    is($path, 'virgil:aeneid:');
    is($type, '.book7');

    is(basename(':arma:virumque:cano.trojae'), 'cano.trojae');
    is(dirname(':arma:virumque:cano.trojae'),  ':arma:virumque:');
    is(dirname(':arma:virumque:'), ':arma:');
    is(dirname(':arma:virumque'), ':arma:');
    is(dirname(':arma:'), ':');
    is(dirname(':arma'),  ':');
    is(dirname('arma:'), 'arma:');
    is(dirname('arma'), ':');
    is(dirname(':'), ':');


    # Check quoting of metacharacters in suffix arg by basename()
    is(basename(':arma:virumque:cano.trojae','.trojae'), 'cano');
    is(basename(':arma:virumque:cano_trojae','.trojae'), 'cano_trojae');
}


### extra tests for a few specific bugs
{
    fileparse_set_fstype 'DOS';
    # perl5.003_18 gives C:/perl/.\
    is((fileparse 'C:/perl/lib')[1], 'C:/perl/');
    # perl5.003_18 gives C:\perl\
    is(dirname('C:\\perl\\lib\\'), 'C:\\perl');

    fileparse_set_fstype 'UNIX';
    # perl5.003_18 gives '.'
    is(dirname('/perl/'), '/');
    # perl5.003_18 gives '/perl/lib'
    is(dirname('/perl/lib//'), '/perl');
}

### rt.perl.org 22236
{
    is(basename('a/'), 'a');
    is(basename('/usr/lib//'), 'lib');

    fileparse_set_fstype 'MSWin32';
    is(basename('a\\'), 'a');
    is(basename('\\usr\\lib\\\\'), 'lib');
}


### rt.cpan.org 36477
{
    fileparse_set_fstype('Unix');
    is(dirname('/'), '/');
    is(basename('/'), '/');

    fileparse_set_fstype('DOS');
    is(dirname('\\'), '\\');
    is(basename('\\'), '\\');
}


### basename(1) sez: "The suffix is not stripped if it is identical to the
### remaining characters in string"
{
    fileparse_set_fstype('Unix');
    is(basename('.foo'), '.foo');
    is(basename('.foo', '.foo'),     '.foo');
    is(basename('.foo.bar', '.foo'), '.foo.bar');
    is(basename('.foo.bar', '.bar'), '.foo');
}


### Test tainting
{
    #   The empty tainted value, for tainting strings
    my $TAINT = substr($^X, 0, 0);

    # How to identify taint when you see it
    sub any_tainted (@) {
        return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
    }

    sub tainted ($) {
        any_tainted @_;
    }

    sub all_tainted (@) {
        for (@_) { return 0 unless tainted $_ }
        1;
    }

    fileparse_set_fstype 'Unix';
    ok tainted(dirname($TAINT.'/perl/lib//'));
    ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'));
}

--- NEW FILE: Find.pm ---
package File::Find;
use 5.006;
use strict;
use warnings;
use warnings::register;
our $VERSION = '1.10';
require Exporter;
require Cwd;

#
# Modified to ensure sub-directory traversal order is not inverded by stack
# push and pops.  That is remains in the same order as in the directory file,
# or user pre-processing (EG:sorted).
#

=head1 NAME

File::Find - Traverse a directory tree.

[...1236 lines suppressed...]

# Set dont_use_nlink in your hint file if your system's stat doesn't
# report the number of links in a directory as an indication
# of the number of files.
# See, e.g. hints/machten.sh for MachTen 2.2.
unless ($File::Find::dont_use_nlink) {
    require Config;
    $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
}

# We need a function that checks if a scalar is tainted. Either use the
# Scalar::Util module's tainted() function or our (slower) pure Perl
# fallback is_tainted_pp()
{
    local $@;
    eval { require Scalar::Util };
    *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
}

1;

--- NEW FILE: CheckTree.pm ---
package File::CheckTree;

use 5.006;
use Cwd;
use Exporter;
use File::Spec;
use warnings;
use strict;

our $VERSION = '4.3';
our @ISA     = qw(Exporter);
our @EXPORT  = qw(validate);

=head1 NAME

validate - run many filetest checks on a tree

=head1 SYNOPSIS

    use File::CheckTree;

    $num_warnings = validate( q{
        /vmunix                 -e || die
        /boot                   -e || die
        /bin                    cd
            csh                 -ex
            csh                 !-ug
            sh                  -ex
            sh                  !-ug
        /usr                    -d || warn "What happened to $file?\n"
    });

=head1 DESCRIPTION

The validate() routine takes a single multiline string consisting of
directives, each containing a filename plus a file test to try on it.
(The file test may also be a "cd", causing subsequent relative filenames
to be interpreted relative to that directory.)  After the file test
you may put C<|| die> to make it a fatal error if the file test fails.
The default is C<|| warn>.  The file test may optionally have a "!' prepended
to test for the opposite condition.  If you do a cd and then list some
relative filenames, you may want to indent them slightly for readability.
If you supply your own die() or warn() message, you can use $file to
interpolate the filename.

Filetests may be bunched:  "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
Only the first failed test of the bunch will produce a warning.

The routine returns the number of warnings issued.

=head1 AUTHOR

File::CheckTree was derived from lib/validate.pl which was
written by Larry Wall.
Revised by Paul Grassie <F<grassie at perl.com>> in 2002.

=head1 HISTORY

File::CheckTree used to not display fatal error messages.
It used to count only those warnings produced by a generic C<|| warn>
(and not those in which the user supplied the message).  In addition,
the validate() routine would leave the user program in whatever
directory was last entered through the use of "cd" directives.
These bugs were fixed during the development of perl 5.8.
The first fixed version of File::CheckTree was 4.2.

=cut

my $Warnings;

sub validate {
    my ($starting_dir, $file, $test, $cwd, $oldwarnings);

    $starting_dir = cwd;

    $cwd = "";
    $Warnings = 0;

    foreach my $check (split /\n/, $_[0]) {
        my ($testlist, @testlist);

        # skip blanks/comments
        next if $check =~ /^\s*#/ || $check =~ /^\s*$/;

        # Todo:
        # should probably check for invalid directives and die
        # but earlier versions of File::CheckTree did not do this either

        # split a line like "/foo -r || die"
        # so that $file is "/foo", $test is "-rwx || die"
        ($file, $test) = split(' ', $check, 2);   # special whitespace split

        # change a $test like "!-ug || die" to "!-Z || die",
        # capturing the bundled tests (e.g. "ug") in $2
        if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
            $testlist = $2;
            # split bundled tests, e.g. "ug" to 'u', 'g'
            @testlist = split(//, $testlist);
        }
        else {
            # put in placeholder Z for stand-alone test
            @testlist = ('Z');
        }

        # will compare these two later to stop on 1st warning w/in a bundle
        $oldwarnings = $Warnings;

        foreach my $one (@testlist) {
            # examples of $test: "!-Z || die" or "-w || warn"
            my $this = $test;

            # expand relative $file to full pathname if preceded by cd directive
            $file = File::Spec->catfile($cwd, $file) 
                    if $cwd && !File::Spec->file_name_is_absolute($file);

            # put filename in after the test operator
            $this =~ s/(-\w\b)/$1 "\$file"/g;

            # change the "-Z" representing a bundle with the $one test
            $this =~ s/-Z/-$one/;

            # if it's a "cd" directive...
            if ($this =~ /^cd\b/) {
                # add "|| die ..."
                $this .= ' || die "cannot cd to $file\n"';
                # expand "cd" directive with directory name
                $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
            }
            else {
                # add "|| warn" as a default disposition
                $this .= ' || warn' unless $this =~ /\|\|/; 

                # change a generic ".. || die" or ".. || warn"
                # to call valmess instead of die/warn directly
                # valmess will look up the error message from %Val_Message
                $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
                          /$1 || valmess('$3', '$2', \$file)/x;
            }

            {
                # count warnings, either from valmess or '-r || warn "my msg"'
                # also, call any pre-existing signal handler for __WARN__
                my $orig_sigwarn = $SIG{__WARN__};
                local $SIG{__WARN__} = sub {
                    ++$Warnings;
                    if ( $orig_sigwarn ) {
                        $orig_sigwarn->(@_);
                    }
                    else {
                        warn "@_";
                    }
                };

                # do the test
                eval $this;

                # re-raise an exception caused by a "... || die" test 
                if ($@) {
                    # in case of any cd directives, return from whence we came
                    if ($starting_dir ne cwd) {
                        chdir($starting_dir) || die "$starting_dir: $!";
                    }
                    die $@ if $@;
                }
            }

            # stop on 1st warning within a bundle of tests
            last if $Warnings > $oldwarnings;
        }
    }

    # in case of any cd directives, return from whence we came
    if ($starting_dir ne cwd) {
        chdir($starting_dir) || die "chdir $starting_dir: $!";
    }

    return $Warnings;
}

my %Val_Message = (
    'r' => "is not readable by uid $>.",
    'w' => "is not writable by uid $>.",
    'x' => "is not executable by uid $>.",
    'o' => "is not owned by uid $>.",
    'R' => "is not readable by you.",
    'W' => "is not writable by you.",
    'X' => "is not executable by you.",
    'O' => "is not owned by you.",
    'e' => "does not exist.",
    'z' => "does not have zero size.",
    's' => "does not have non-zero size.",
    'f' => "is not a plain file.",
    'd' => "is not a directory.",
    'l' => "is not a symbolic link.",
    'p' => "is not a named pipe (FIFO).",
    'S' => "is not a socket.",
    'b' => "is not a block special file.",
    'c' => "is not a character special file.",
    'u' => "does not have the setuid bit set.",
    'g' => "does not have the setgid bit set.",
    'k' => "does not have the sticky bit set.",
    'T' => "is not a text file.",
    'B' => "is not a binary file."
);

sub valmess {
    my ($disposition, $test, $file) = @_;
    my $ferror;

    if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
        my ($neg, $ftype) = ($1, $2);

        $ferror = "$file $Val_Message{$ftype}";

        if ($neg eq '!') {
            $ferror =~ s/ is not / should not be / ||
            $ferror =~ s/ does not / should not / ||
            $ferror =~ s/ not / /;
        }
    }
    else {
        $ferror = "Can't do $test $file.\n";
    }

    die "$ferror\n" if $disposition eq 'die';
    warn "$ferror\n";
}

1;

--- NEW FILE: Copy.pm ---
# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs at ajs.com>. This
# source code has been placed in the public domain by the author.
# Please be kind and preserve the documentation.
#
# Additions copyright 1996 by Charles Bailey.  Permission is granted
# to distribute the revised code under the same terms as Perl itself.

package File::Copy;

use 5.006;
use strict;
use warnings;
use Carp;
use File::Spec;
use Config;
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
sub copy;
sub syscopy;
sub cp;
sub mv;

# Note that this module implements only *part* of the API defined by
# the File/Copy.pm module of the File-Tools-2.0 package.  However, that
# package has not yet been updated to work with Perl 5.004, and so it
# would be a Bad Thing for the CPAN module to grab it and replace this
# module.  Therefore, we set this module's version higher than 2.0.
$VERSION = '2.09';

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(copy move);
@EXPORT_OK = qw(cp mv);

$Too_Big = 1024 * 1024 * 2;

my $macfiles;
if ($^O eq 'MacOS') {
	$macfiles = eval { require Mac::MoreFiles };
	warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
		if $@ && $^W;
}

sub _catname {
    my($from, $to) = @_;
    if (not defined &basename) {
	require File::Basename;
	import  File::Basename 'basename';
    }

    if ($^O eq 'MacOS') {
	# a partial dir name that's valid only in the cwd (e.g. 'tmp')
	$to = ':' . $to if $to !~ /:/;
    }

    return File::Spec->catfile($to, basename($from));
}

sub copy {
    croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
      unless(@_ == 2 || @_ == 3);

    my $from = shift;
    my $to = shift;

    my $from_a_handle = (ref($from)
			 ? (ref($from) eq 'GLOB'
			    || UNIVERSAL::isa($from, 'GLOB')
                            || UNIVERSAL::isa($from, 'IO::Handle'))
			 : (ref(\$from) eq 'GLOB'));
    my $to_a_handle =   (ref($to)
			 ? (ref($to) eq 'GLOB'
			    || UNIVERSAL::isa($to, 'GLOB')
                            || UNIVERSAL::isa($to, 'IO::Handle'))
			 : (ref(\$to) eq 'GLOB'));

    if ($from eq $to) { # works for references, too
	carp("'$from' and '$to' are identical (not copied)");
        # The "copy" was a success as the source and destination contain
        # the same data.
        return 1;
    }

    if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
	!($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) {
	my @fs = stat($from);
	if (@fs) {
	    my @ts = stat($to);
	    if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
		carp("'$from' and '$to' are identical (not copied)");
                return 0;
	    }
	}
    }

    if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
	$to = _catname($from, $to);
    }

    if (defined &syscopy && !$Syscopy_is_copy
	&& !$to_a_handle
	&& !($from_a_handle && $^O eq 'os2' )	# OS/2 cannot handle handles
	&& !($from_a_handle && $^O eq 'mpeix')	# and neither can MPE/iX.
	&& !($from_a_handle && $^O eq 'MSWin32')
	&& !($from_a_handle && $^O eq 'MacOS')
	&& !($from_a_handle && $^O eq 'NetWare')
       )
    {
	return syscopy($from, $to);
    }

    my $closefrom = 0;
    my $closeto = 0;
    my ($size, $status, $r, $buf);
    local($\) = '';

    my $from_h;
    if ($from_a_handle) {
       $from_h = $from;
    } else {
	$from = _protect($from) if $from =~ /^\s/s;
       $from_h = \do { local *FH };
       open($from_h, "< $from\0") or goto fail_open1;
       binmode $from_h or die "($!,$^E)";
	$closefrom = 1;
    }

    my $to_h;
    if ($to_a_handle) {
       $to_h = $to;
    } else {
	$to = _protect($to) if $to =~ /^\s/s;
       $to_h = \do { local *FH };
       open($to_h,"> $to\0") or goto fail_open2;
       binmode $to_h or die "($!,$^E)";
	$closeto = 1;
    }

    if (@_) {
	$size = shift(@_) + 0;
	croak("Bad buffer size for copy: $size\n") unless ($size > 0);
    } else {
	$size = tied(*$from_h) ? 0 : -s $from_h || 0;
	$size = 1024 if ($size < 512);
	$size = $Too_Big if ($size > $Too_Big);
    }

    $! = 0;
    for (;;) {
	my ($r, $w, $t);
       defined($r = sysread($from_h, $buf, $size))
	    or goto fail_inner;
	last unless $r;
	for ($w = 0; $w < $r; $w += $t) {
           $t = syswrite($to_h, $buf, $r - $w, $w)
		or goto fail_inner;
	}
    }

    close($to_h) || goto fail_open2 if $closeto;
    close($from_h) || goto fail_open1 if $closefrom;

    # Use this idiom to avoid uninitialized value warning.
    return 1;

    # All of these contortions try to preserve error messages...
  fail_inner:
    if ($closeto) {
	$status = $!;
	$! = 0;
       close $to_h;
	$! = $status unless $!;
    }
  fail_open2:
    if ($closefrom) {
	$status = $!;
	$! = 0;
       close $from_h;
	$! = $status unless $!;
    }
  fail_open1:
    return 0;
}

sub move {
    croak("Usage: move(FROM, TO) ") unless @_ == 2;

    my($from,$to) = @_;

    my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);

    if (-d $to && ! -d $from) {
	$to = _catname($from, $to);
    }

    ($tosz1,$tomt1) = (stat($to))[7,9];
    $fromsz = -s $from;
    if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
      # will not rename with overwrite
      unlink $to;
    }
    return 1 if rename $from, $to;

    # Did rename return an error even though it succeeded, because $to
    # is on a remote NFS file system, and NFS lost the server's ack?
    return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
                (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
                ($tosz1 != $tosz2 or $tomt1 != $tomt2) &&  #   and changed
                $tosz2 == $fromsz;                         # it's all there

    ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something

    {
        local $@;
        eval {
            local $SIG{__DIE__};
            copy($from,$to) or die;
            my($atime, $mtime) = (stat($from))[8,9];
            utime($atime, $mtime, $to);
            unlink($from)   or die;
        };
        return 1 unless $@;
    }
    ($sts,$ossts) = ($! + 0, $^E + 0);

    ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
    unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
    ($!,$^E) = ($sts,$ossts);
    return 0;
}

*cp = \&copy;
*mv = \&move;


if ($^O eq 'MacOS') {
    *_protect = sub { MacPerl::MakeFSSpec($_[0]) };
} else {
    *_protect = sub { "./$_[0]" };
}

# &syscopy is an XSUB under OS/2
unless (defined &syscopy) {
    if ($^O eq 'VMS') {
	*syscopy = \&rmscopy;
    } elsif ($^O eq 'mpeix') {
	*syscopy = sub {
	    return 0 unless @_ == 2;
	    # Use the MPE cp program in order to
	    # preserve MPE file attributes.
	    return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
	};
    } elsif ($^O eq 'MSWin32') {
	*syscopy = sub {
	    return 0 unless @_ == 2;
	    return Win32::CopyFile(@_, 1);
	};
    } elsif ($macfiles) {
	*syscopy = sub {
	    my($from, $to) = @_;
	    my($dir, $toname);

	    return 0 unless -e $from;

	    if ($to =~ /(.*:)([^:]+):?$/) {
		($dir, $toname) = ($1, $2);
	    } else {
		($dir, $toname) = (":", $to);
	    }

	    unlink($to);
	    Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
	};
    } else {
	$Syscopy_is_copy = 1;
	*syscopy = \&copy;
    }
}

1;

__END__

=head1 NAME

File::Copy - Copy files or filehandles

=head1 SYNOPSIS

	use File::Copy;

	copy("file1","file2") or die "Copy failed: $!";
	copy("Copy.pm",\*STDOUT);
	move("/dev1/fileA","/dev2/fileB");

	use File::Copy "cp";

	$n = FileHandle->new("/a/file","r");
	cp($n,"x");

=head1 DESCRIPTION

The File::Copy module provides two basic functions, C<copy> and
C<move>, which are useful for getting the contents of a file from
one place to another.

=over 4

=item *

The C<copy> function takes two
parameters: a file to copy from and a file to copy to. Either
argument may be a string, a FileHandle reference or a FileHandle
glob. Obviously, if the first argument is a filehandle of some
sort, it will be read from, and if it is a file I<name> it will
be opened for reading. Likewise, the second argument will be
written to (and created if need be).  Trying to copy a file on top
of itself is a fatal error.

B<Note that passing in
files as handles instead of names may lead to loss of information
on some operating systems; it is recommended that you use file
names whenever possible.>  Files are opened in binary mode where
applicable.  To get a consistent behaviour when copying from a
filehandle to a file, use C<binmode> on the filehandle.

An optional third parameter can be used to specify the buffer
size used for copying. This is the number of bytes from the
first file, that wil be held in memory at any given time, before
being written to the second file. The default buffer size depends
upon the file, but will generally be the whole file (up to 2Mb), or
1k for filehandles that do not reference files (eg. sockets).

You may use the syntax C<use File::Copy "cp"> to get at the
"cp" alias for this function. The syntax is I<exactly> the same.

=item *

The C<move> function also takes two parameters: the current name
and the intended name of the file to be moved.  If the destination
already exists and is a directory, and the source is not a
directory, then the source file will be renamed into the directory
specified by the destination.

If possible, move() will simply rename the file.  Otherwise, it copies
the file to the new location and deletes the original.  If an error occurs
during this copy-and-delete process, you may be left with a (possibly partial)
copy of the file under the destination name.

You may use the "mv" alias for this function in the same way that
you may use the "cp" alias for C<copy>.

=back

File::Copy also provides the C<syscopy> routine, which copies the
file specified in the first parameter to the file specified in the
second parameter, preserving OS-specific attributes and file
structure.  For Unix systems, this is equivalent to the simple
C<copy> routine, which doesn't preserve OS-specific attributes.  For
VMS systems, this calls the C<rmscopy> routine (see below).  For OS/2
systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
this calls C<Win32::CopyFile>.

On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
if available.

=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)

If both arguments to C<copy> are not file handles,
then C<copy> will perform a "system copy" of
the input file to a new output file, in order to preserve file
attributes, indexed file structure, I<etc.>  The buffer size
parameter is ignored.  If either argument to C<copy> is a
handle to an opened file, then data is copied using Perl
operators, and no effort is made to preserve file attributes
or record structure.

The system copy routine may also be called directly under VMS and OS/2
as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
is the routine that does the actual work for syscopy).

=over 4

=item rmscopy($from,$to[,$date_flag])

The first and second arguments may be strings, typeglobs, typeglob
references, or objects inheriting from IO::Handle;
they are used in all cases to obtain the
I<filespec> of the input and output files, respectively.  The
name and type of the input file are used as defaults for the
output file, if necessary.

A new version of the output file is always created, which
inherits the structure and RMS attributes of the input file,
except for owner and protections (and possibly timestamps;
see below).  All data from the input file is copied to the
output file; if either of the first two parameters to C<rmscopy>
is a file handle, its position is unchanged.  (Note that this
means a file handle pointing to the output file will be
associated with an old version of that file after C<rmscopy>
returns, not the newly created version.)

The third parameter is an integer flag, which tells C<rmscopy>
how to handle timestamps.  If it is E<lt> 0, none of the input file's
timestamps are propagated to the output file.  If it is E<gt> 0, then
it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
timestamps other than the revision date are propagated; if bit 1
is set, the revision date is propagated.  If the third parameter
to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
if the name or type of the output file was explicitly specified,
then no timestamps are propagated, but if they were taken implicitly
from the input filespec, then all timestamps other than the
revision date are propagated.  If this parameter is not supplied,
it defaults to 0.

Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
it sets C<$!>, deletes the output file, and returns 0.

=back

=head1 RETURN

All functions return 1 on success, 0 on failure.
$! will be set if an error was encountered.

=head1 NOTES

=over 4

=item *

On Mac OS (Classic), the path separator is ':', not '/', and the 
current directory is denoted as ':', not '.'. You should be careful 
about specifying relative pathnames. While a full path always begins 
with a volume name, a relative pathname should always begin with a 
':'.  If specifying a volume name only, a trailing ':' is required.

E.g.

  copy("file1", "tmp");        # creates the file 'tmp' in the current directory
  copy("file1", ":tmp:");      # creates :tmp:file1
  copy("file1", ":tmp");       # same as above
  copy("file1", "tmp");        # same as above, if 'tmp' is a directory (but don't do   
                               # that, since it may cause confusion, see example #1)
  copy("file1", "tmp:file1");  # error, since 'tmp:' is not a volume
  copy("file1", ":tmp:file1"); # ok, partial path
  copy("file1", "DataHD:");    # creates DataHD:file1
  
  move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one 
                                             # volume to another

=back

=head1 AUTHOR

File::Copy was written by Aaron Sherman I<E<lt>ajs at ajs.comE<gt>> in 1995,
and updated by Charles Bailey I<E<lt>bailey at newman.upenn.eduE<gt>> in 1996.

=cut


--- NEW FILE: Temp.pm ---
package File::Temp;

=head1 NAME

File::Temp - return name and handle of a temporary file safely

=begin __INTERNALS

=head1 PORTABILITY

This section is at the top in order to provide easier access to
porters.  It is not expected to be rendered by a standard pod
formatting tool. Please skip straight to the SYNOPSIS section if you
are not trying to port this module to a new platform.

This module is designed to be portable across operating systems and it
currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
(Classic). When porting to a new OS there are generally three main
issues that have to be solved:
[...2205 lines suppressed...]
See L<IO::File> and L<File::MkTemp>, L<Apachae::TempFile> for
different implementations of temporary file handling.

=head1 AUTHOR

Tim Jenness E<lt>tjenness at cpan.orgE<gt>

Copyright (C) 1999-2005 Tim Jenness and the UK Particle Physics and
Astronomy Research Council. All Rights Reserved.  This program is free
software; you can redistribute it and/or modify it under the same
terms as Perl itself.

Original Perl implementation loosely based on the OpenBSD C code for
mkstemp(). Thanks to Tom Christiansen for suggesting that this module
should be written and providing ideas for code improvements and
security enhancements.

=cut

1;

--- NEW FILE: DosGlob.t ---
#!./perl

#
# test glob() in File::DosGlob
#

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

print "1..10\n";

# override it in main::
use File::DosGlob 'glob';

# test if $_ takes as the default
my $expected;
if ($^O eq 'MacOS') {
    $expected = $_ = ":op:a*.t";
} else {
    $expected = $_ = "op/a*.t";
}
my @r = glob;
print "not " if $_ ne $expected;
print "ok 1\n";
print "# |@r|\nnot " if @r < 9;
print "ok 2\n";

# check if <*/*> works
if ($^O eq 'MacOS') {
    @r = <:*:a*.t>;
} else {
    @r = <*/a*.t>;
}
# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
print "# |@r|\nnot " if @r < 9;
print "ok 3\n";
my $r = scalar @r;

# check if scalar context works
@r = ();
while (defined($_ = ($^O eq 'MacOS') ? <:*:a*.t> : <*/a*.t>)) {
    print "# $_\n";
    push @r, $_;
}
print "not " if @r != $r;
print "ok 4\n";

# check if list context works
@r = ();
if ($^O eq 'MacOS') {
    for (<:*:a*.t>) {
    	print "# $_\n";
    	push @r, $_;
    }
} else {
    for (<*/a*.t>) {
    	print "# $_\n";
    	push @r, $_;
    }
}
print "not " if @r != $r;
print "ok 5\n";

# test if implicit assign to $_ in while() works
@r = ();
if ($^O eq 'MacOS') {
    while (<:*:a*.t>) {
    	print "# $_\n";
	push @r, $_;
    }
} else {
    while (<*/a*.t>) {
    	print "# $_\n";
	push @r, $_;
    }
}
print "not " if @r != $r;
print "ok 6\n";

# test if explicit glob() gets assign magic too
my @s = ();
my $pat = ($^O eq 'MacOS') ? ':*:a*.t': '*/a*.t';
while (glob ($pat)) {
    print "# $_\n";
    push @s, $_;
}
print "not " if "@r" ne "@s";
print "ok 7\n";

# how about in a different package, like?
package Foo;
use File::DosGlob 'glob';
@s = ();
$pat = $^O eq 'MacOS' ? ':*:a*.t' : '*/a*.t';
while (glob($pat)) {
    print "# $_\n";
    push @s, $_;
}
print "not " if "@r" ne "@s";
print "ok 8\n";

# test if different glob ops maintain independent contexts
@s = ();
if ($^O eq 'MacOS') {
    while (<:*:a*.t>) {
	my $i = 0;
	print "# $_ <";
	push @s, $_;
	while (<:*:b*.t>) {
	    print " $_";
	    $i++;
	}
	print " >\n";
    }
} else {
    while (<*/a*.t>) {
	my $i = 0;
	print "# $_ <";
	push @s, $_;
	while (<*/b*.t>) {
	    print " $_";
	    $i++;
	}
	print " >\n";
    }
}
print "not " if "@r" ne "@s";
print "ok 9\n";

# how about a global override, hm?
eval <<'EOT';
use File::DosGlob 'GLOBAL_glob';
package Bar;
@s = ();
if ($^O eq 'MacOS') {
    while (<:*:a*.t>) {
	my $i = 0;
	print "# $_ <";
	push @s, $_;
	while (glob ':*:b*.t') {
	    print " $_";
	    $i++;
	}
	print " >\n";
    }
} else {
    while (<*/a*.t>) {
	my $i = 0;
	print "# $_ <";
	push @s, $_;
	while (glob '*/b*.t') {
	    print " $_";
	    $i++;
	}
	print " >\n";
    }
}
print "not " if "@r" ne "@s";
print "ok 10\n";
EOT

--- NEW FILE: Compare.pm ---
package File::Compare;

use 5.006;
use strict;
use warnings;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big);

require Exporter;
use Carp;

$VERSION = '1.1003';
@ISA = qw(Exporter);
@EXPORT = qw(compare);
@EXPORT_OK = qw(cmp compare_text);

$Too_Big = 1024 * 1024 * 2;

sub compare {
    croak("Usage: compare( file1, file2 [, buffersize]) ")
      unless(@_ == 2 || @_ == 3);

    my ($from,$to,$size) = @_;
    my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);

    my ($fromsize,$closefrom,$closeto);
    local (*FROM, *TO);

    croak("from undefined") unless (defined $from);
    croak("to undefined") unless (defined $to);

    if (ref($from) && 
        (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
	*FROM = *$from;
    } elsif (ref(\$from) eq 'GLOB') {
	*FROM = $from;
    } else {
	open(FROM,"<$from") or goto fail_open1;
	unless ($text_mode) {
	    binmode FROM;
	    $fromsize = -s FROM;
	}
	$closefrom = 1;
    }

    if (ref($to) &&
        (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
	*TO = *$to;
    } elsif (ref(\$to) eq 'GLOB') {
	*TO = $to;
    } else {
	open(TO,"<$to") or goto fail_open2;
	binmode TO unless $text_mode;
	$closeto = 1;
    }

    if (!$text_mode && $closefrom && $closeto) {
	# If both are opened files we know they differ if their size differ
	goto fail_inner if $fromsize != -s TO;
    }

    if ($text_mode) {
	local $/ = "\n";
	my ($fline,$tline);
	while (defined($fline = <FROM>)) {
	    goto fail_inner unless defined($tline = <TO>);
	    if (ref $size) {
		# $size contains ref to comparison function
		goto fail_inner if &$size($fline, $tline);
	    } else {
		goto fail_inner if $fline ne $tline;
	    }
	}
	goto fail_inner if defined($tline = <TO>);
    }
    else {
	unless (defined($size) && $size > 0) {
	    $size = $fromsize || -s TO || 0;
	    $size = 1024 if $size < 512;
	    $size = $Too_Big if $size > $Too_Big;
	}

	my ($fr,$tr,$fbuf,$tbuf);
	$fbuf = $tbuf = '';
	while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
	    unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
		goto fail_inner;
	    }
	}
	goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
    }

    close(TO) || goto fail_open2 if $closeto;
    close(FROM) || goto fail_open1 if $closefrom;

    return 0;
    
  # All of these contortions try to preserve error messages...
  fail_inner:
    close(TO) || goto fail_open2 if $closeto;
    close(FROM) || goto fail_open1 if $closefrom;

    return 1;

  fail_open2:
    if ($closefrom) {
	my $status = $!;
	$! = 0;
	close FROM;
	$! = $status unless $!;
    }
  fail_open1:
    return -1;
}

sub cmp;
*cmp = \&compare;

sub compare_text {
    my ($from,$to,$cmp) = @_;
    croak("Usage: compare_text( file1, file2 [, cmp-function])")
	unless @_ == 2 || @_ == 3;
    croak("Third arg to compare_text() function must be a code reference")
	if @_ == 3 && ref($cmp) ne 'CODE';

    # Using a negative buffer size puts compare into text_mode too
    $cmp = -1 unless defined $cmp;
    compare($from, $to, $cmp);
}

1;

__END__

=head1 NAME

File::Compare - Compare files or filehandles

=head1 SYNOPSIS

  	use File::Compare;

	if (compare("file1","file2") == 0) {
	    print "They're equal\n";
	}

=head1 DESCRIPTION

The File::Compare::compare function compares the contents of two
sources, each of which can be a file or a file handle.  It is exported
from File::Compare by default.

File::Compare::cmp is a synonym for File::Compare::compare.  It is
exported from File::Compare only by request.

File::Compare::compare_text does a line by line comparison of the two
files. It stops as soon as a difference is detected. compare_text()
accepts an optional third argument: This must be a CODE reference to
a line comparison function, which returns 0 when both lines are considered
equal. For example:

    compare_text($file1, $file2)

is basically equivalent to

    compare_text($file1, $file2, sub {$_[0] ne $_[1]} )

=head1 RETURN

File::Compare::compare and its sibling functions return 0 if the files
are equal, 1 if the files are unequal, or -1 if an error was encountered.

=head1 AUTHOR

File::Compare was written by Nick Ing-Simmons.
Its original documentation was written by Chip Salzenberg.

=cut


--- NEW FILE: Spec.pm ---
package File::Spec;

use strict;
use vars qw(@ISA $VERSION);

$VERSION = '3.12';
$VERSION = eval $VERSION;

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');


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

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

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

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

Returns a string representation of the current directory.

    $curdir = File::Spec->curdir();

=item devnull

Returns a string representation of the null device.

    $devnull = File::Spec->devnull();

=item rootdir

Returns a string representation of the root directory.

    $rootdir = File::Spec->rootdir();

=item 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

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.

    $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

Takes no argument.  Returns the environment variable C<PATH> (or the local
platform's equivalent) as a list.

    @PATH = File::Spec->path();

=item join

join is the same as catfile.

=item splitpath

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

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

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> 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>.

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>.

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()

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> 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>.

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 at cpan.org> >>.

The vast majority of the code was written by
Kenneth Albanowski C<< <kjahds at kjahds.com> >>,
Andy Dougherty C<< <doughera at lafayette.edu> >>,
Andreas KE<ouml>nig C<< <A.Koenig at franz.ww.TU-Berlin.DE> >>,
Tim Bunce C<< <Tim.Bunce at ig.co.uk> >>.
VMS support by Charles Bailey C<< <bailey at newman.upenn.edu> >>.
OS/2 support by Ilya Zakharevich C<< <ilya at math.ohio-state.edu> >>.
Mac support by Paul Schinder C<< <schinder at pobox.com> >>, and
Thomas Wegner C<< <wegner_thomas at yahoo.com> >>.
abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio at tamacom.com> >>,
modified by Barrie Slaymaker C<< <barries at slaysys.com> >>.
splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.

=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

--- NEW FILE: Path.t ---
#!./perl -wT

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use File::Path;
use File::Spec::Functions;
use strict;

my $count = 0;
use warnings;

print "1..4\n";

# first check for stupid permissions second for full, so we clean up
# behind ourselves
for my $perm (0111,0777) {
    my $path = catdir(curdir(), "mhx", "bar");
    mkpath($path);
    chmod $perm, "mhx", $path;

    print "not " unless -d "mhx" && -d $path;
    print "ok ", ++$count, "\n";

    rmtree("mhx");
    print "not " if -e "mhx";
    print "ok ", ++$count, "\n";
}

--- NEW FILE: Path.pm ---
package File::Path;

=head1 NAME

File::Path - create or remove directory trees

=head1 SYNOPSIS

    use File::Path;

    mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
    rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);

=head1 DESCRIPTION

The C<mkpath> function provides a convenient way to create directories, even
if your C<mkdir> kernel call won't create more than one level of directory at
a time.  C<mkpath> takes three arguments:

=over 4

=item *

the name of the path to create, or a reference
to a list of paths to create,

=item *

a boolean value, which if TRUE will cause C<mkpath>
to print the name of each directory as it is created
(defaults to FALSE), and

=item *

the numeric mode to use when creating the directories
(defaults to 0777), to be modified by the current umask.

=back

It returns a list of all directories (including intermediates, determined
using the Unix '/' separator) created.

If a system error prevents a directory from being created, then the
C<mkpath> function throws a fatal error with C<Carp::croak>. This error
can be trapped with an C<eval> block:

  eval { mkpath($dir) };
  if ($@) {
    print "Couldn't create $dir: $@";
  }

Similarly, the C<rmtree> function provides a convenient way to delete a
subtree from the directory structure, much like the Unix command C<rm -r>.
C<rmtree> takes three arguments:

=over 4

=item *

the root of the subtree to delete, or a reference to
a list of roots.  All of the files and directories
below each root, as well as the roots themselves,
will be deleted.

=item *

a boolean value, which if TRUE will cause C<rmtree> to
print a message each time it examines a file, giving the
name of the file, and indicating whether it's using C<rmdir>
or C<unlink> to remove it, or that it's skipping it.
(defaults to FALSE)

=item *

a boolean value, which if TRUE will cause C<rmtree> to
skip any files to which you do not have delete access
(if running under VMS) or write access (if running
under another OS).  This will change in the future when
a criterion for 'delete permission' under OSs other
than VMS is settled.  (defaults to FALSE)

=back

It returns the number of files successfully deleted.  Symlinks are
simply deleted and not followed.

B<NOTE:> There are race conditions internal to the implementation of
C<rmtree> making it unsafe to use on directory trees which may be
altered or moved while C<rmtree> is running, and in particular on any
directory trees with any path components or subdirectories potentially
writable by untrusted users.

Additionally, if the third parameter is not TRUE and C<rmtree> is
interrupted, it may leave files and directories with permissions altered
to allow deletion (and older versions of this module would even set
files and directories to world-read/writable!)

Note also that the occurrence of errors in C<rmtree> can be determined I<only>
by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
from the return value.

=head1 DIAGNOSTICS

=over 4

=item *

On Windows, if C<mkpath> gives you the warning: B<No such file or
directory>, this may mean that you've exceeded your filesystem's
maximum path length.

=back

=head1 AUTHORS

Tim Bunce <F<Tim.Bunce at ig.co.uk>> and
Charles Bailey <F<bailey at newman.upenn.edu>>

=cut

use 5.006;
use Carp;
use File::Basename ();
use Exporter ();
use strict;
use warnings;

our $VERSION = "1.08";
our @ISA = qw( Exporter );
our @EXPORT = qw( mkpath rmtree );

my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';

# These OSes complain if you want to remove a file that you have no
# write permission to:
my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
		       $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');

sub mkpath {
    my($paths, $verbose, $mode) = @_;
    # $paths   -- either a path string or ref to list of paths
    # $verbose -- optional print "mkdir $path" for each directory created
    # $mode    -- optional permissions, defaults to 0777
    local($")=$Is_MacOS ? ":" : "/";
    $mode = 0777 unless defined($mode);
    $paths = [$paths] unless ref $paths;
    my(@created,$path);
    foreach $path (@$paths) {
	$path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT 
	# Logic wants Unix paths, so go with the flow.
	if ($Is_VMS) {
	    next if $path eq '/';
	    $path = VMS::Filespec::unixify($path);
	    if ($path =~ m:^(/[^/]+)/?\z:) {
	        $path = $1.'/000000';
	    }
	}
	next if -d $path;
	my $parent = File::Basename::dirname($path);
	unless (-d $parent or $path eq $parent) {
	    push(@created,mkpath($parent, $verbose, $mode));
 	}
	print "mkdir $path\n" if $verbose;
	unless (mkdir($path,$mode)) {
	    my $e = $!;
	    # allow for another process to have created it meanwhile
	    $! = $e, croak ("mkdir $path: $e") unless -d $path;
	}
	push(@created, $path);
    }
    @created;
}

sub rmtree {
    my($roots, $verbose, $safe) = @_;
    my(@files);
    my($count) = 0;
    $verbose ||= 0;
    $safe ||= 0;

    if ( defined($roots) && length($roots) ) {
      $roots = [$roots] unless ref $roots;
    }
    else {
      carp "No root path(s) specified\n";
      return 0;
    }

    my($root);
    foreach $root (@{$roots}) {
    	if ($Is_MacOS) {
	    $root = ":$root" if $root !~ /:/;
	    $root =~ s#([^:])\z#$1:#;
	} else {
	    $root =~ s#/\z##;
	}
	(undef, undef, my $rp) = lstat $root or next;
	$rp &= 07777;	# don't forget setuid, setgid, sticky bits
	if ( -d _ ) {
	    # notabene: 0700 is for making readable in the first place,
	    # it's also intended to change it to writable in case we have
	    # to recurse in which case we are better than rm -rf for 
	    # subtrees with strange permissions
	    chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
	      or carp "Can't make directory $root read+writeable: $!"
		unless $safe;

	    if (opendir my $d, $root) {
		no strict 'refs';
		if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
		    # Blindly untaint dir names
		    @files = map { /^(.*)$/s ; $1 } readdir $d;
		} else {
		    @files = readdir $d;
		}
		closedir $d;
	    }
	    else {
	        carp "Can't read $root: $!";
		@files = ();
	    }

	    # Deleting large numbers of files from VMS Files-11 filesystems
	    # is faster if done in reverse ASCIIbetical order 
	    @files = reverse @files if $Is_VMS;
	    ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
	    if ($Is_MacOS) {
		@files = map("$root$_", @files);
	    } else {
		@files = map("$root/$_", grep $_!~/^\.{1,2}\z/s, at files);
	    }
	    $count += rmtree(\@files,$verbose,$safe);
	    if ($safe &&
		($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
		print "skipped $root\n" if $verbose;
		next;
	    }
	    chmod $rp | 0700, $root
	      or carp "Can't make directory $root writeable: $!"
		if $force_writeable;
	    print "rmdir $root\n" if $verbose;
	    if (rmdir $root) {
		++$count;
	    }
	    else {
		carp "Can't remove directory $root: $!";
		chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
		    or carp("and can't restore permissions to "
		            . sprintf("0%o",$rp) . "\n");
	    }
	}
	else { 
	    if ($safe &&
		($Is_VMS ? !&VMS::Filespec::candelete($root)
		         : !(-l $root || -w $root)))
	    {
		print "skipped $root\n" if $verbose;
		next;
	    }
	    chmod $rp | 0600, $root
	      or carp "Can't make file $root writeable: $!"
		if $force_writeable;
	    print "unlink $root\n" if $verbose;
	    # delete all versions under VMS
	    for (;;) {
		unless (unlink $root) {
		    carp "Can't unlink file $root: $!";
		    if ($force_writeable) {
			chmod $rp, $root
			    or carp("and can't restore permissions to "
			            . sprintf("0%o",$rp) . "\n");
		    }
		    last;
		}
		++$count;
		last unless $Is_VMS && lstat $root;
	    }
	}
    }

    $count;
}

1;

--- NEW FILE: DosGlob.pm ---
#!perl -w

# use strict fails
#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.

#
# Documentation at the __END__
#

package File::DosGlob;

our $VERSION = '1.00';
use strict;
use warnings;

sub doglob {
    my $cond = shift;
    my @retval = ();
    #print "doglob: ", join('|', @_), "\n";
  OUTER:
    for my $pat (@_) {
	my @matched = ();
	my @globdirs = ();
	my $head = '.';
	my $sepchr = '/';
        my $tail;
	next OUTER unless defined $pat and $pat ne '';
	# if arg is within quotes strip em and do no globbing
	if ($pat =~ /^"(.*)"\z/s) {
	    $pat = $1;
	    if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
	    else              { push(@retval, $pat) if -e $pat }
	    next OUTER;
	}
	# wildcards with a drive prefix such as h:*.pm must be changed
	# to h:./*.pm to expand correctly
	if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
	    substr($_,0,2) = $1 . "./";
	}
	if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
	    ($head, $sepchr, $tail) = ($1,$2,$3);
	    #print "div: |$head|$sepchr|$tail|\n";
	    push (@retval, $pat), next OUTER if $tail eq '';
	    if ($head =~ /[*?]/) {
		@globdirs = doglob('d', $head);
		push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
		    next OUTER if @globdirs;
	    }
	    $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
	    $pat = $tail;
	}
	#
	# If file component has no wildcards, we can avoid opendir
	unless ($pat =~ /[*?]/) {
	    $head = '' if $head eq '.';
	    $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
	    $head .= $pat;
	    if ($cond eq 'd') { push(@retval,$head) if -d $head }
	    else              { push(@retval,$head) if -e $head }
	    next OUTER;
	}
	opendir(D, $head) or next OUTER;
	my @leaves = readdir D;
	closedir D;
	$head = '' if $head eq '.';
	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;

	# escape regex metachars but not glob chars
        $pat =~ s:([].+^\-\${}[|]):\\$1:g;
	# and convert DOS-style wildcards to regex
	$pat =~ s/\*/.*/g;
	$pat =~ s/\?/.?/g;

	#print "regex: '$pat', head: '$head'\n";
	my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
      INNER:
	for my $e (@leaves) {
	    next INNER if $e eq '.' or $e eq '..';
	    next INNER if $cond eq 'd' and ! -d "$head$e";
	    push(@matched, "$head$e"), next INNER if &$matchsub($e);
	    #
	    # [DOS compatibility special case]
	    # Failed, add a trailing dot and try again, but only
	    # if name does not have a dot in it *and* pattern
	    # has a dot *and* name is shorter than 9 chars.
	    #
	    if (index($e,'.') == -1 and length($e) < 9
	        and index($pat,'\\.') != -1) {
		push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
	    }
	}
	push @retval, @matched if @matched;
    }
    return @retval;
}


#
# Do DOS-like globbing on Mac OS 
#
sub doglob_Mac {
    my $cond = shift;
    my @retval = ();

	#print "doglob_Mac: ", join('|', @_), "\n";
  OUTER:
    for my $arg (@_) {
        local $_ = $arg;
	my @matched = ();
	my @globdirs = ();
	my $head = ':';
	my $not_esc_head = $head;
	my $sepchr = ':';	
	next OUTER unless defined $_ and $_ ne '';
	# if arg is within quotes strip em and do no globbing
	if (/^"(.*)"\z/s) {
	    $_ = $1;
		# $_ may contain escaped metachars '\*', '\?' and '\'
	        my $not_esc_arg = $_;
		$not_esc_arg =~ s/\\([*?\\])/$1/g;
	    if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg }
	    else              { push(@retval, $not_esc_arg) if -e $not_esc_arg }
	    next OUTER;
	}

	if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy
	    my $tail;
	    ($head, $sepchr, $tail) = ($1,$2,$3);
	    #print "div: |$head|$sepchr|$tail|\n";
	    push (@retval, $_), next OUTER if $tail eq '';		
		#
		# $head may contain escaped metachars '\*' and '\?'
		
		my $tmp_head = $head;
		# if a '*' or '?' is preceded by an odd count of '\', temporary delete 
		# it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as 
		# wildcards
		$tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
	
		if ($tmp_head =~ /[*?]/) { # if there are wildcards ...	
		@globdirs = doglob_Mac('d', $head);
		push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)),
		    next OUTER if @globdirs;
	    }
		
		$head .= $sepchr; 
		$not_esc_head = $head;
		# unescape $head for file operations
		$not_esc_head =~ s/\\([*?\\])/$1/g;
	    $_ = $tail;
	}
	#
	# If file component has no wildcards, we can avoid opendir
	
	my $tmp_tail = $_;
	# if a '*' or '?' is preceded by an odd count of '\', temporary delete 
	# it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as 
	# wildcards
	$tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
	
	unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ...
	    $not_esc_head = $head = '' if $head eq ':';
	    my $not_esc_tail = $_;
	    # unescape $head and $tail for file operations
	    $not_esc_tail =~ s/\\([*?\\])/$1/g;
	    $head .= $_;
		$not_esc_head .= $not_esc_tail;
	    if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head }
	    else              { push(@retval,$head) if -e $not_esc_head }
	    next OUTER;
	}
	#print "opendir($not_esc_head)\n";
	opendir(D, $not_esc_head) or next OUTER;
	my @leaves = readdir D;
	closedir D;

	# escape regex metachars but not '\' and glob chars '*', '?'
	$_ =~ s:([].+^\-\${}[|]):\\$1:g;
	# and convert DOS-style wildcards to regex,
	# but only if they are not escaped
	$_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;

	#print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n";
	my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
	warn($@), next OUTER if $@;
      INNER:
	for my $e (@leaves) {
	    next INNER if $e eq '.' or $e eq '..';
	    next INNER if $cond eq 'd' and ! -d "$not_esc_head$e";
		
		if (&$matchsub($e)) {
			my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? 
		            	"$e" : "$not_esc_head$e";
			#
			# On Mac OS, the two glob metachars '*' and '?' and the escape 
			# char '\' are valid characters for file and directory names. 
			# We have to escape and treat them specially.
			$leave =~ s|([*?\\])|\\$1|g;		
			push(@matched, $leave);
			next INNER;
		}
	}
	push @retval, @matched if @matched;
    }
    return @retval;
}

#
# _expand_volume() will only be used on Mac OS (Classic): 
# Takes an array of original patterns as argument and returns an array of  
# possibly modified patterns. Each original pattern is processed like 
# that:
# + If there's a volume name in the pattern, we push a separate pattern 
#   for each mounted volume that matches (with '*', '?' and '\' escaped).  
# + If there's no volume name in the original pattern, it is pushed 
#   unchanged. 
# Note that the returned array of patterns may be empty.
#  
sub _expand_volume {
	
	require MacPerl; # to be verbose
	
	my @pat = @_;
	my @new_pat = ();
	my @FSSpec_Vols = MacPerl::Volumes();
	my @mounted_volumes = ();

	foreach my $spec_vol (@FSSpec_Vols) {		
		# push all mounted volumes into array
     	push @mounted_volumes, MacPerl::MakePath($spec_vol);
	}
	#print "mounted volumes: |@mounted_volumes|\n";
	
	while (@pat) {
		my $pat = shift @pat;	
		if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name?
			my $vol_pat = $1;
			my $tail = $2;
			#
			# escape regex metachars but not '\' and glob chars '*', '?'
			$vol_pat =~ s:([].+^\-\${}[|]):\\$1:g;
			# and convert DOS-style wildcards to regex,
			# but only if they are not escaped
			$vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
			#print "volume regex: '$vol_pat' \n";
				
			foreach my $volume (@mounted_volumes) {
				if ($volume =~ m|^$vol_pat\z|ios) {
					#
					# On Mac OS, the two glob metachars '*' and '?' and the  
					# escape char '\' are valid characters for volume names. 
					# We have to escape and treat them specially.
					$volume =~ s|([*?\\])|\\$1|g;
					push @new_pat, $volume . $tail;
				}
			}			
		} else { # no volume name in pattern, push original pattern
			push @new_pat, $pat;
		}
	}
	return @new_pat;
}


#
# _preprocess_pattern() will only be used on Mac OS (Classic): 
# Resolves any updirs in the pattern. Removes a single trailing colon 
# from the pattern, unless it's a volume name pattern like "*HD:"
#
sub _preprocess_pattern {
	my @pat = @_;
	
	foreach my $p (@pat) {
		my $proceed;
		# resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
		do {
			$proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);  
		} while ($proceed);
		# remove a single trailing colon, e.g. ":*:" -> ":*"
		$p =~ s/:([^:]+):\z/:$1/;
	}
	return @pat;
}
		
		
#
# _un_escape() will only be used on Mac OS (Classic):
# Unescapes a list of arguments which may contain escaped 
# metachars '*', '?' and '\'.
#
sub _un_escape {
	foreach (@_) {
		s/\\([*?\\])/$1/g;
	}
	return @_;
}

#
# this can be used to override CORE::glob in a specific
# package by saying C<use File::DosGlob 'glob';> in that
# namespace.
#

# context (keyed by second cxix arg provided by core)
my %iter;
my %entries;

sub glob {
    my($pat,$cxix) = @_;
    my @pat;

    # glob without args defaults to $_
    $pat = $_ unless defined $pat;

    # extract patterns
    if ($pat =~ /\s/) {
	require Text::ParseWords;
	@pat = Text::ParseWords::parse_line('\s+',0,$pat);
    }
    else {
	push @pat, $pat;
    }

    # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
    #   abc3 will be the original {3} (and drop the {}).
    #   abc1 abc2 will be put in @appendpat.
    # This was just the esiest way, not nearly the best.
    REHASH: {
	my @appendpat = ();
	for (@pat) {
	    # There must be a "," I.E. abc{efg} is not what we want.
	    while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
		my ($start, $match, $end) = ($1, $2, $3);
		#print "Got: \n\t$start\n\t$match\n\t$end\n";
		my $tmp = "$start$match$end";
		while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
		    #print "Striped: $tmp\n";
		    #  these expanshions will be preformed by the original,
		    #  when we call REHASH.
		}
		push @appendpat, ("$tmp");
		s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
		if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
		    $match = $1;
		    #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
		    $_ = "$start$match$end";
		}
	    }
	    #print "Sould have "GOT" vs "Got"!\n";
		#FIXME: There should be checking for this.
		#  How or what should be done about failure is beond me.
	}
	if ( $#appendpat != -1
		) {
	    #print "LOOP\n";
	    #FIXME: Max loop, no way! :")
	    for ( @appendpat ) {
	        push @pat, $_;
	    }
	    goto REHASH;
	}
    }
    for ( @pat ) {
	s/\\{/{/g;
	s/\\}/}/g;
	s/\\,/,/g;
    }
    #print join ("\n", @pat). "\n";
 
    # assume global context if not provided one
    $cxix = '_G_' unless defined $cxix;
    $iter{$cxix} = 0 unless exists $iter{$cxix};

    # if we're just beginning, do it all first
    if ($iter{$cxix} == 0) {
	if ($^O eq 'MacOS') {
		# first, take care of updirs and trailing colons
		@pat = _preprocess_pattern(@pat);
		# expand volume names
		@pat = _expand_volume(@pat);
		$entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1, at pat) )] : [()];
	} else {
		$entries{$cxix} = [doglob(1, at pat)];
    }
	}

    # chuck it all out, quick or slow
    if (wantarray) {
	delete $iter{$cxix};
	return @{delete $entries{$cxix}};
    }
    else {
	if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
	    return shift @{$entries{$cxix}};
	}
	else {
	    # return undef for EOL
	    delete $iter{$cxix};
	    delete $entries{$cxix};
	    return undef;
	}
    }
}

{
    no strict 'refs';

    sub import {
    my $pkg = shift;
    return unless @_;
    my $sym = shift;
    my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
    *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
    }
}
1;

__END__

=head1 NAME

File::DosGlob - DOS like globbing and then some

=head1 SYNOPSIS

    require 5.004;

    # override CORE::glob in current package
    use File::DosGlob 'glob';

    # override CORE::glob in ALL packages (use with extreme caution!)
    use File::DosGlob 'GLOBAL_glob';

    @perlfiles = glob  "..\\pe?l/*.p?";
    print <..\\pe?l/*.p?>;

    # from the command line (overrides only in main::)
    > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"

=head1 DESCRIPTION

A module that implements DOS-like globbing with a few enhancements.
It is largely compatible with perlglob.exe (the M$ setargv.obj
version) in all but one respect--it understands wildcards in
directory components.

For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
that it will find something like '..\lib\File/DosGlob.pm' alright).
Note that all path components are case-insensitive, and that
backslashes and forward slashes are both accepted, and preserved.
You may have to double the backslashes if you are putting them in
literally, due to double-quotish parsing of the pattern by perl.

Spaces in the argument delimit distinct patterns, so
C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
or C<.dll>.  If you want to put in literal spaces in the glob
pattern, you can escape them with either double quotes, or backslashes.
e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
of the quoting rules used.

Extending it to csh patterns is left as an exercise to the reader.

=head1 NOTES

=over 4

=item *

Mac OS (Classic) users should note a few differences. The specification 
of pathnames in glob patterns adheres to the usual Mac OS conventions: 
The path separator is a colon ':', not a slash '/' or backslash '\'. A 
full path always begins with a volume name. A relative pathname on Mac 
OS must always begin with a ':', except when specifying a file or 
directory name in the current working directory, where the leading colon 
is optional. If specifying a volume name only, a trailing ':' is 
required. Due to these rules, a glob like E<lt>*:E<gt> will find all 
mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find 
all files and directories in the current directory.

Note that updirs in the glob pattern are resolved before the matching begins,
i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
that a single trailing ':' in the pattern is ignored (unless it's a volume
name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories 
I<and> files (and not, as one might expect, only directories). 

The metachars '*', '?' and the escape char '\' are valid characters in 
volume, directory and file names on Mac OS. Hence, if you want to match
a '*', '?' or '\' literally, you have to escape these characters. Due to 
perl's quoting rules, things may get a bit complicated, when you want to 
match a string like '\*' literally, or when you want to match '\' literally, 
but treat the immediately following character '*' as metachar. So, here's a 
rule of thumb (applies to both single- and double-quoted strings): escape 
each '*' or '?' or '\' with a backslash, if you want to treat them literally, 
and then double each backslash and your are done. E.g. 

- Match '\*' literally

   escape both '\' and '*'  : '\\\*'
   double the backslashes   : '\\\\\\*'

(Internally, the glob routine sees a '\\\*', which means that both '\' and 
'*' are escaped.)


- Match '\' literally, treat '*' as metachar

   escape '\' but not '*'   : '\\*'
   double the backslashes   : '\\\\*'

(Internally, the glob routine sees a '\\*', which means that '\' is escaped and 
'*' is not.)

Note that you also have to quote literal spaces in the glob pattern, as described
above.

=back

=head1 EXPORTS (by request only)

glob()

=head1 BUGS

Should probably be built into the core, and needs to stop
pandering to DOS habits.  Needs a dose of optimizium too.

=head1 AUTHOR

Gurusamy Sarathy <gsar at activestate.com>

=head1 HISTORY

=over 4

=item *

Support for globally overriding glob() (GSAR 3-JUN-98)

=item *

Scalar context, independent iterator context fixes (GSAR 15-SEP-97)

=item *

A few dir-vs-file optimizations result in glob importation being
10 times faster than using perlglob.exe, and using perlglob.bat is
only twice as slow as perlglob.exe (GSAR 28-MAY-97)

=item *

Several cleanups prompted by lack of compatible perlglob.exe
under Borland (GSAR 27-MAY-97)

=item *

Initial version (GSAR 20-FEB-97)

=back

=head1 SEE ALSO

perl

perlglob.bat

Text::ParseWords

=cut


--- NEW FILE: Compare.t ---
#!./perl

BEGIN {
  chdir 't' if -d 't';
  @INC = '../lib';
}

BEGIN {
  our @TEST = stat "TEST";
  our @README = stat "README";
  unless (@TEST && @README) {
    print "1..0 # Skip: no file TEST or README\n";
    exit 0;
  }
}

print "1..12\n";

use File::Compare qw(compare compare_text);

print "ok 1\n";

# named files, same, existing but different, cause an error
print "not " unless compare("README","README") == 0;
print "ok 2\n";

print "not " unless compare("TEST","README") == 1;
print "ok 3\n";

print "not " unless compare("README","HLAGHLAG") == -1;
                               # a file which doesn't exist
print "ok 4\n";

# compare_text, the same file, different but existing files
# cause error, test sub form.
print "not " unless compare_text("README","README") == 0;
print "ok 5\n";

print "not " unless compare_text("TEST","README") == 1;
print "ok 6\n";

print "not " unless compare_text("TEST","HLAGHLAG") == -1;
print "ok 7\n";

print "not " unless
  compare_text("README","README",sub {$_[0] ne $_[1]}) == 0;
print "ok 8\n";

# filehandle and same file
{
  my $fh;
  open ($fh, "<README") or print "not ";
  binmode($fh);
  print "not " unless compare($fh,"README") == 0;
  print "ok 9\n";
  close $fh;
}

# filehandle and different (but existing) file.
{
  my $fh;
  open ($fh, "<README") or print "not ";
  binmode($fh);
  print "not " unless compare_text($fh,"TEST") == 1;
  print "ok 10\n";
  close $fh;
}

# Different file with contents of known file,
# will use File::Temp to do this, skip rest of
# tests if this doesn't seem to work

my @donetests;
eval {
  require File::Spec; import File::Spec;
  require File::Path; import File::Path;
  require File::Temp; import File::Temp qw/ :mktemp unlink0 /;

  my $template = File::Spec->catfile(File::Spec->tmpdir, 'fcmpXXXX');
  my($tfh,$filename) = mkstemp($template);
  {
    local $/; #slurp
    my $fh;
    open($fh,'README');
    binmode($fh);
    my $data = <$fh>;
    print $tfh $data;
    close($fh);
  }
  seek($tfh,0,0);
  $donetests[0] = compare($tfh, 'README');
  $donetests[1] = compare($filename, 'README');
  unlink0($tfh,$filename);
};
print "# problems when testing with a tempory file\n" if $@;

if (@donetests == 2) {
  print "not " unless $donetests[0] == 0;
  print "ok 11\n";
  if ($^O eq 'VMS') {
    # The open attempt on FROM in File::Compare::compare should fail
    # on this OS since files are not shared by default.
    print "not " unless $donetests[1] == -1;
    print "ok 12\n";
  }
  else {
    print "not " unless $donetests[1] == 0;
    print "ok 12\n";
  }
}
else {
  print "ok 11# Skip\nok 12 # Skip Likely due to File::Temp\n";
}


--- NEW FILE: CheckTree.t ---
#!./perl -w

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use Test;

BEGIN { plan tests => 6 }

use strict;

use File::CheckTree;
use File::Spec;          # used to get absolute paths

# We assume that we start from the perl "t" directory.
# Will move up one level to make it easier to generate
# reliable pathnames for testing File::CheckTree

chdir(File::Spec->updir) or die "cannot change to parent of t/ directory: $!";


#### TEST 1 -- No warnings ####
# usings both relative and full paths, indented comments

{
    my ($num_warnings, $path_to_README);
    $path_to_README = File::Spec->rel2abs('README');

    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings, "@_" };

    eval {
        $num_warnings = validate qq{
            lib  -d
# comment, followed "blank" line (w/ whitespace):
           
            # indented comment, followed blank line (w/o whitespace):

            README -f
            $path_to_README -e || warn
        };
    };

    if ( !$@ && !@warnings && defined($num_warnings) && $num_warnings == 0 ) {
        ok(1);
    }
    else {
        ok(0);
    }
}


#### TEST 2 -- One warning ####

{
    my ($num_warnings, @warnings);

    local $SIG{__WARN__} = sub { push @warnings, "@_" };

    eval {
        $num_warnings = validate qq{
            lib    -f
            README -f
        };
    };

    if ( !$@ && @warnings == 1
             && $warnings[0] =~ /lib is not a plain file/
             && defined($num_warnings)
             && $num_warnings == 1 )
    {
        ok(1);
    }
    else {
        ok(0);
    }
}


#### TEST 3 -- Multiple warnings ####
# including first warning only from a bundle of tests,
# generic "|| warn", default "|| warn" and "|| warn '...' "

{
    my ($num_warnings, @warnings);

    local $SIG{__WARN__} = sub { push @warnings, "@_" };

    eval {
        $num_warnings = validate q{
            lib     -effd
            README -f || die
            README -d || warn
            lib    -f || warn "my warning: $file\n"
        };
    };

    if ( !$@ && @warnings == 3
             && $warnings[0] =~ /lib is not a plain file/
             && $warnings[1] =~ /README is not a directory/
             && $warnings[2] =~ /my warning: lib/
             && defined($num_warnings)
             && $num_warnings == 3 )
    {
        ok(1);
    }
    else {
        ok(0);
    }
}


#### TEST 4 -- cd directive ####
# cd directive followed by relative paths, followed by full paths
{
    my ($num_warnings, @warnings, $path_to_libFile, $path_to_dist);
    $path_to_libFile = File::Spec->rel2abs(File::Spec->catdir('lib','File'));
    $path_to_dist    = File::Spec->rel2abs(File::Spec->curdir);

    local $SIG{__WARN__} = sub { push @warnings, "@_" };

    eval {
        $num_warnings = validate qq{
            lib                -d || die
            $path_to_libFile   cd
            Spec               -e
            Spec               -f
            $path_to_dist      cd
            README             -ef
            INSTALL            -d || warn
            $path_to_libFile   -d || die
        };
    };

    if ( !$@ && @warnings == 2
             && $warnings[0] =~ /Spec is not a plain file/
             && $warnings[1] =~ /INSTALL is not a directory/
             && defined($num_warnings)
             && $num_warnings == 2 )
    {
        ok(1);
    }
    else {
        ok(0);
    }
}


#### TEST 5 -- Exception ####
# test with generic "|| die"
{
    my $num_warnings;

    eval {
        $num_warnings = validate q{
            lib       -ef || die
            README    -d
        };
    };

    if ( $@ && $@ =~ /lib is not a plain file/
            && not defined $num_warnings )
    {
        ok(1);
    }
    else {
        ok(0);
    }
}


#### TEST 6 -- Exception ####
# test with "|| die 'my error message'"
{
    my $num_warnings;

    eval {
        $num_warnings = validate q{
            lib       -ef || die "yadda $file yadda...\n"
            README    -d
        };
    };

    if ( $@ && $@ =~ /yadda lib yadda/
            && not defined $num_warnings )
    {
        ok(1);
    }
    else {
        ok(0);
    }
}




More information about the dslinux-commit mailing list