diff options
Diffstat (limited to 'contrib/perl5/lib/File')
| -rw-r--r-- | contrib/perl5/lib/File/Basename.pm | 263 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/CheckTree.pm | 151 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Compare.pm | 143 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Copy.pm | 342 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/DosGlob.pm | 249 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Find.pm | 230 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Path.pm | 228 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec.pm | 116 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Mac.pm | 230 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/OS2.pm | 51 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Unix.pm | 197 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/VMS.pm | 148 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Win32.pm | 104 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/stat.pm | 113 |
14 files changed, 2565 insertions, 0 deletions
diff --git a/contrib/perl5/lib/File/Basename.pm b/contrib/perl5/lib/File/Basename.pm new file mode 100644 index 0000000..69bb1fa --- /dev/null +++ b/contrib/perl5/lib/File/Basename.pm @@ -0,0 +1,263 @@ +package File::Basename; + +=head1 NAME + +fileparse - split a pathname into pieces + +basename - extract just the filename from a path + +dirname - extract just the directory from a path + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist) + fileparse_set_fstype($os_string); + $basename = basename($fullname,@suffixlist); + $dirname = dirname($fullname); + + ($name,$path,$suffix) = fileparse("lib/File/Basename.pm","\.pm"); + fileparse_set_fstype("VMS"); + $basename = basename("lib/File/Basename.pm",".pm"); + $dirname = dirname("lib/File/Basename.pm"); + +=head1 DESCRIPTION + +These routines allow you to parse file specifications into useful +pieces using the syntax of different operating systems. + +=over 4 + +=item fileparse_set_fstype + +You select the syntax via the routine fileparse_set_fstype(). + +If the argument passed to it contains one of the substrings +"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification +syntax of that operating system is used in future calls to +fileparse(), basename(), and dirname(). If it contains none of +these substrings, UNIX syntax is used. This pattern matching is +case-insensitive. 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. + +If the argument passed to it contains one of the substrings "VMS", +"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern +matching for suffix removal is performed without regard for case, +since those systems are not case-sensitive when opening existing files +(though some of them preserve case on file creation). + +If you haven't called fileparse_set_fstype(), the syntax is chosen +by examining the builtin variable C<$^O> according to these rules. + +=item fileparse + +The fileparse() routine divides a file specification into three +parts: a leading B<path>, a file B<name>, and a B<suffix>. The +B<path> contains everything up to and including the last directory +separator in the input file specification. The remainder of the input +file specification is then divided into B<name> and B<suffix> based on +the optional patterns you specify in C<@suffixlist>. Each element of +this list is interpreted as a regular expression, and is matched +against the end of B<name>. If this succeeds, the matching portion of +B<name> is removed and prepended to B<suffix>. By proper use of +C<@suffixlist>, you can remove file types or versions for examination. + +You are guaranteed that if you concatenate B<path>, B<name>, and +B<suffix> together in that order, the result will denote the same +file as the input file specification. + +=back + +=head1 EXAMPLES + +Using UNIX file syntax: + + ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', + '\.book\d+'); + +would yield + + $base eq 'draft' + $path eq '/virgil/aeneid/', + $type eq '.book7' + +Similarly, using VMS syntax: + + ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh', + '\..*'); + +would yield + + $name eq 'Rhetoric' + $dir eq 'Doc_Root:[Help]' + $type eq '.Rnh' + +=over + +=item C<basename> + +The basename() routine returns the first element of the list produced +by calling fileparse() with the same arguments, except that it always +quotes metacharacters in the given suffixes. It is provided for +programmer compatibility with the UNIX shell command basename(1). + +=item C<dirname> + +The dirname() routine returns the directory portion of the input file +specification. When using VMS or MacOS syntax, this is identical to the +second element of the list produced by calling fileparse() with the same +input file specification. (Under VMS, if there is no directory information +in the input file specification, then the current default device and +directory are returned.) When using UNIX or MSDOS syntax, the return +value conforms to the behavior of the UNIX shell command dirname(1). This +is usually the same as the behavior of fileparse(), but differs in some +cases. For example, for the input file specification F<lib/>, fileparse() +considers the directory name to be F<lib/>, while dirname() considers the +directory name to be F<.>). + +=back + +=cut + + +## use strict; +use re 'taint'; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(fileparse fileparse_set_fstype basename dirname); +use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase); +$VERSION = "2.6"; + + +# fileparse_set_fstype() - specify OS-based rules used in future +# calls to routines in this package +# +# Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS +# Any other name uses Unix-style rules and is case-sensitive + +sub fileparse_set_fstype { + my @old = ($Fileparse_fstype, $Fileparse_igncase); + if (@_) { + $Fileparse_fstype = $_[0]; + $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i); + } + wantarray ? @old : $old[0]; +} + +# fileparse() - parse file specification +# +# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu + + +sub fileparse { + my($fullname,@suffices) = @_; + my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); + my($dirpath,$tail,$suffix,$basename); + my($taint) = substr($fullname,0,0); # Is $fullname tainted? + + if ($fstype =~ /^VMS/i) { + if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation + else { + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); + $dirpath ||= ''; # should always be defined + } + } + if ($fstype =~ /^MS(DOS|Win32)/i) { + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; + } + elsif ($fstype =~ /^MacOS/i) { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); + } + elsif ($fstype =~ /^AmigaOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + $dirpath = './' unless $dirpath; + } + elsif ($fstype !~ /^VMS/i) { # default to Unix + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + ($basename,$dirpath) = ('',$fullname); + } + $dirpath = './' unless $dirpath; + } + + if (@suffices) { + $tail = ''; + foreach $suffix (@suffices) { + my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//) { + $taint .= substr($suffix,0,0); + $tail = $1 . $tail; + } + } + } + + $tail .= $taint if defined $tail; # avoid warning if $tail == undef + wantarray ? ($basename . $taint, $dirpath . $taint, $tail) + : $basename . $taint; +} + + +# basename() - returns first element of list returned by fileparse() + +sub basename { + my($name) = shift; + (fileparse($name, map("\Q$_\E",@_)))[0]; +} + + +# dirname() - returns device and directory portion of file specification +# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS +# filespecs except for names ending with a separator, e.g., "/xx/yy/". +# This differs from the second element of the list returned +# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and +# the last directory name if the filespec ends in a '/' or '\'), is lost. + +sub dirname { + my($basename,$dirname) = fileparse($_[0]); + my($fstype) = $Fileparse_fstype; + + if ($fstype =~ /VMS/i) { + if ($_[0] =~ m#/#) { $fstype = '' } + else { return $dirname || $ENV{DEFAULT} } + } + if ($fstype =~ /MacOS/i) { return $dirname } + elsif ($fstype =~ /MSDOS/i) { + $dirname =~ s/([^:])[\\\/]*$/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*$/$1/; + } + } + elsif ($fstype =~ /MSWin32/i) { + $dirname =~ s/([^:])[\\\/]*$/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*$/$1/; + } + } + elsif ($fstype =~ /AmigaOS/i) { + if ( $dirname =~ /:$/) { return $dirname } + chop $dirname; + $dirname =~ s#[^:/]+$## unless length($basename); + } + else { + $dirname =~ s:(.)/*$:$1:; + unless( length($basename) ) { + local($File::Basename::Fileparse_fstype) = $fstype; + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s:(.)/*$:$1:; + } + } + + $dirname; +} + +fileparse_set_fstype $^O; + +1; diff --git a/contrib/perl5/lib/File/CheckTree.pm b/contrib/perl5/lib/File/CheckTree.pm new file mode 100644 index 0000000..dca7f6a --- /dev/null +++ b/contrib/perl5/lib/File/CheckTree.pm @@ -0,0 +1,151 @@ +package File::CheckTree; +require 5.000; +require Exporter; + +=head1 NAME + +validate - run many filetest checks on a tree + +=head1 SYNOPSIS + + use File::CheckTree; + + $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 +lines 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. + +=cut + +@ISA = qw(Exporter); +@EXPORT = qw(validate); + +# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ + +# The validate routine takes a single multiline string consisting of +# lines 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 '|| die' to make it a fatal error if the file test fails. +# The default is '|| 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 -r, -w and -x. +# Only the first failed test of the bunch will produce a warning. + +# The routine returns the number of warnings issued. + +# Usage: +# use File::CheckTree; +# $warnings += validate(' +# /vmunix -e || die +# /boot -e || die +# /bin cd +# csh -ex +# csh !-ug +# sh -ex +# sh !-ug +# /usr -d || warn "What happened to $file?\n" +# '); + +sub validate { + local($file,$test,$warnings,$oldwarnings); + foreach $check (split(/\n/,$_[0])) { + next if $check =~ /^#/; + next if $check =~ /^$/; + ($file,$test) = split(' ',$check,2); + if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { + $testlist = $2; + @testlist = split(//,$testlist); + } + else { + @testlist = ('Z'); + } + $oldwarnings = $warnings; + foreach $one (@testlist) { + $this = $test; + $this =~ s/(-\w\b)/$1 \$file/g; + $this =~ s/-Z/-$one/; + $this .= ' || warn' unless $this =~ /\|\|/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/; + $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; + eval $this; + last if $warnings > $oldwarnings; + } + } + $warnings; +} + +sub valmess { + local($disposition,$this) = @_; + $file = $cwd . '/' . $file unless $file =~ m|^/|; + if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { + $neg = $1; + $tmp = $2; + $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); + $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); + $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); + $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); + $tmp eq 'R' && ($mess = "$file is not readable by you."); + $tmp eq 'W' && ($mess = "$file is not writable by you."); + $tmp eq 'X' && ($mess = "$file is not executable by you."); + $tmp eq 'O' && ($mess = "$file is not owned by you."); + $tmp eq 'e' && ($mess = "$file does not exist."); + $tmp eq 'z' && ($mess = "$file does not have zero size."); + $tmp eq 's' && ($mess = "$file does not have non-zero size."); + $tmp eq 'f' && ($mess = "$file is not a plain file."); + $tmp eq 'd' && ($mess = "$file is not a directory."); + $tmp eq 'l' && ($mess = "$file is not a symbolic link."); + $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); + $tmp eq 'S' && ($mess = "$file is not a socket."); + $tmp eq 'b' && ($mess = "$file is not a block special file."); + $tmp eq 'c' && ($mess = "$file is not a character special file."); + $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); + $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); + $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); + $tmp eq 'T' && ($mess = "$file is not a text file."); + $tmp eq 'B' && ($mess = "$file is not a binary file."); + if ($neg eq '!') { + $mess =~ s/ is not / should not be / || + $mess =~ s/ does not / should not / || + $mess =~ s/ not / /; + } + } + else { + $this =~ s/\$file/'$file'/g; + $mess = "Can't do $this.\n"; + } + die "$mess\n" if $disposition eq 'die'; + warn "$mess\n"; + ++$warnings; +} + +1; + diff --git a/contrib/perl5/lib/File/Compare.pm b/contrib/perl5/lib/File/Compare.pm new file mode 100644 index 0000000..2f9c45c --- /dev/null +++ b/contrib/perl5/lib/File/Compare.pm @@ -0,0 +1,143 @@ +package File::Compare; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); + +require Exporter; +use Carp; + +$VERSION = '1.1001'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp); + +$Too_Big = 1024 * 1024 * 2; + +sub VERSION { + # Version of File::Compare + return $File::Compare::VERSION; +} + +sub compare { + croak("Usage: compare( file1, file2 [, buffersize]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + my $closefrom=0; + my $closeto=0; + my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf); + local(*FROM, *TO); + local($\) = ''; + + 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; + binmode FROM; + $closefrom = 1; + $fromsize = -s FROM; + } + + 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; + $closeto = 1; + } + + if ($closefrom && $closeto) { + # If both are opened files we know they differ if their size differ + goto fail_inner if $fromsize != -s TO; + } + + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for compare: $size\n") unless ($size > 0); + } else { + $size = $fromsize; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $fbuf = ''; + $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) and $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) { + $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +*cmp = \&compare; + +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. + +=head1 RETURN + +File::Compare::compare 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 + diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm new file mode 100644 index 0000000..d0b3c89 --- /dev/null +++ b/contrib/perl5/lib/File/Copy.pm @@ -0,0 +1,342 @@ +# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@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 strict; +use Carp; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big + © &syscopy &cp &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.02'; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); + +$Too_Big = 1024 * 1024 * 2; + +sub _catname { # Will be replaced by File::Spec when it arrives + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } + if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); } + elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); } + elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); } + else { $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_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); + } + + if (defined &syscopy && \&syscopy != \© + && !$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. + ) + { + return syscopy($from, $to); + } + + my $closefrom = 0; + my $closeto = 0; + my ($size, $status, $r, $buf); + local(*FROM, *TO); + local($\) = ''; + + if ($from_a_handle) { + *FROM = *$from{FILEHANDLE}; + } else { + $from = "./$from" if $from =~ /^\s/; + open(FROM, "< $from\0") or goto fail_open1; + binmode FROM or die "($!,$^E)"; + $closefrom = 1; + } + + if ($to_a_handle) { + *TO = *$to{FILEHANDLE}; + } else { + $to = "./$to" if $to =~ /^\s/; + open(TO,"> $to\0") or goto fail_open2; + binmode TO or die "($!,$^E)"; + $closeto = 1; + } + + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for copy: $size\n") unless ($size > 0); + } else { + $size = -s FROM; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $! = 0; + for (;;) { + my ($r, $w, $t); + defined($r = sysread(FROM, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite(TO, $buf, $r - $w, $w) + or goto fail_inner; + } + } + + close(TO) || goto fail_open2 if $closeto; + close(FROM) || 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; + $! = $status unless $!; + } + fail_open2: + if ($closefrom) { + $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return 0; +} + +sub move { + my($from,$to) = @_; + my($copied,$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; + + ($sts,$ossts) = ($! + 0, $^E + 0); + # 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 + return 1 if ($copied = copy($from,$to)) && unlink($from); + + ($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 = \© +*mv = \&move; + +# &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; + }; + } else { + *syscopy = \© + } +} + +1; + +__END__ + +=head1 NAME + +File::Copy - Copy files or filehandles + +=head1 SYNOPSIS + + use File::Copy; + + copy("file1","file2"); + copy("Copy.pm",\*STDOUT);' + move("/dev1/fileA","/dev2/fileB"); + + use POSIX; + use File::Copy cp; + + $n=FileHandle->new("/dev/null","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). + +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 behavour 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. For VMS systems, this calls the C<rmscopy> +routine (see below). For OS/2 systems, this calls the C<syscopy> +XSUB directly. + +=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) + +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 AUTHOR + +File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, +and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. + +=cut + diff --git a/contrib/perl5/lib/File/DosGlob.pm b/contrib/perl5/lib/File/DosGlob.pm new file mode 100644 index 0000000..594ee2e --- /dev/null +++ b/contrib/perl5/lib/File/DosGlob.pm @@ -0,0 +1,249 @@ +#!perl -w + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +sub doglob { + my $cond = shift; + my @retval = (); + #print "doglob: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = '.'; + my $sepchr = '/'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"$/) { + $_ = $1; + if ($cond eq 'd') { push(@retval, $_) if -d $_ } + else { push(@retval, $_) if -e $_ } + next OUTER; + } + if (m|^(.*)([\\/])([^\\/]*)$|) { + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), 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]:$/; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + unless (/[*?]/) { + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + $head .= $_; + 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 + s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex + s/\*/.*/g; + s/\?/.?/g; + + #print "regex: '$_', head: '$head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }'; + 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 "$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($_,'\\.') != -1) { + push(@matched, "$head$e"), next INNER if &$matchsub("$e."); + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# 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 = shift; + my $cxix = shift; + 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; + } + + # 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) { + $entries{$cxix} = [doglob(1,@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; + } + } +} + +sub import { + my $pkg = shift; + return unless @_; + my $sym = shift; + my $callpkg = ($sym =~ s/^GLOBAL_// ? '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 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@umich.edu> + +=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 + diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm new file mode 100644 index 0000000..1305d21 --- /dev/null +++ b/contrib/perl5/lib/File/Find.pm @@ -0,0 +1,230 @@ +package File::Find; +require 5.000; +require Exporter; +require Cwd; + +=head1 NAME + +find - traverse a file tree + +finddepth - traverse a directory structure depth-first + +=head1 SYNOPSIS + + use File::Find; + find(\&wanted, '/foo','/bar'); + sub wanted { ... } + + use File::Find; + finddepth(\&wanted, '/foo','/bar'); + sub wanted { ... } + +=head1 DESCRIPTION + +The first argument to find() is either a hash reference describing the +operations to be performed for each file, or a code reference. If it +is a hash reference, then the value for the key C<wanted> should be a +code reference. This code reference is called I<the wanted() +function> below. + +Currently the only other supported key for the above hash is +C<bydepth>, in presense of which the walk over directories is +performed depth-first. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1}> in the first argument of find(). + +The wanted() function does whatever verifications you want. +$File::Find::dir contains the current directory name, and $_ the +current filename within that directory. $File::Find::name contains +C<"$File::Find::dir/$_">. You are chdir()'d to $File::Find::dir when +the function is called. The function may set $File::Find::prune to +prune the tree. + +File::Find assumes that you don't alter the $_ variable. If you do then +make sure you return it to its original value before exiting your function. + +This library is useful for the C<find2perl> tool, which when fed, + + find2perl / -name .nfs\* -mtime +7 \ + -exec rm -f {} \; -o -fstype nfs -prune + +produces something like: + + sub wanted { + /^\.nfs.*$/ && + (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + int(-M _) > 7 && + unlink($_) + || + ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + $dev < 0 && + ($File::Find::prune = 1); + } + +Set the variable $File::Find::dont_use_nlink if you're using AFS, +since AFS cheats. + +C<finddepth> is just like C<find>, except that it does a depth-first +search. + +Here's another interesting wanted function. It will find all symlinks +that don't resolve: + + sub wanted { + -l && !-e && print "bogus link: $File::Find::name\n"; + } + +=head1 BUGS + +There is no way to make find or finddepth follow symlinks. + +=cut + +@ISA = qw(Exporter); +@EXPORT = qw(find finddepth); + + +sub find_opt { + my $wanted = shift; + my $bydepth = $wanted->{bydepth}; + my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); + # Localize these rather than lexicalizing them for backwards + # compatibility. + local($topdir,$topdev,$topino,$topmode,$topnlink); + foreach $topdir (@_) { + (($topdev,$topino,$topmode,$topnlink) = + ($Is_VMS ? stat($topdir) : lstat($topdir))) + || (warn("Can't stat $topdir: $!\n"), next); + if (-d _) { + if (chdir($topdir)) { + $prune = 0; + unless ($bydepth) { + ($dir,$_) = ($topdir,'.'); + $name = $topdir; + $wanted->{wanted}->(); + } + next if $prune; + my $fixtopdir = $topdir; + $fixtopdir =~ s,/$,, ; + $fixtopdir =~ s/\.dir$// if $Is_VMS; + &finddir($wanted,$fixtopdir,$topnlink, $bydepth); + if ($bydepth) { + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; + $wanted->{wanted}->(); + } + } + else { + warn "Can't cd to $topdir: $!\n"; + } + } + else { + require File::Basename; + unless (($_,$dir) = File::Basename::fileparse($topdir)) { + ($dir,$_) = ('.', $topdir); + } + if (chdir($dir)) { + $name = $topdir; + $wanted->{wanted}->(); + } + else { + warn "Can't cd to $dir: $!\n"; + } + } + chdir $cwd; + } +} + +sub finddir { + my($wanted, $nlink, $bydepth); + local($dir, $name); + ($wanted, $dir, $nlink, $bydepth) = @_; + + my($dev, $ino, $mode, $subcount); + + # Get the list of files in the current directory. + opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); + my(@filenames) = readdir(DIR); + closedir(DIR); + + if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. + for (@filenames) { + next if $_ eq '.'; + next if $_ eq '..'; + $name = "$dir/$_"; + $nlink = 0; + $wanted->{wanted}->(); + } + } + else { # This dir has subdirectories. + $subcount = $nlink - 2; + for (@filenames) { + next if $_ eq '.'; + next if $_ eq '..'; + $nlink = 0; + $prune = 0 unless $bydepth; + $name = "$dir/$_"; + $wanted->{wanted}->() unless $bydepth; + if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? + + # Get link count and check for directoriness. + + ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); + # unless ($nlink || $dont_use_nlink); + + if (-d _) { + + # It really is a directory, so do it recursively. + + --$subcount; + next if $prune; + if (chdir $_) { + $name =~ s/\.dir$// if $Is_VMS; + &finddir($wanted,$name,$nlink, $bydepth); + chdir '..'; + } + else { + warn "Can't cd to $_: $!\n"; + } + } + } + $wanted->{wanted}->() if $bydepth; + } + } +} + +sub wrap_wanted { + my $wanted = shift; + defined &$wanted ? {wanted => $wanted} : $wanted; +} + +sub find { + my $wanted = shift; + find_opt(wrap_wanted($wanted), @_); +} + +sub finddepth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + find_opt($wanted, @_); +} + +# These are hard-coded for now, but may move to hint files. +if ($^O eq 'VMS') { + $Is_VMS = 1; + $dont_use_nlink = 1; +} + +$dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; + +# 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 ($dont_use_nlink) { + require Config; + $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +} + +1; + diff --git a/contrib/perl5/lib/File/Path.pm b/contrib/perl5/lib/File/Path.pm new file mode 100644 index 0000000..39f1ba1 --- /dev/null +++ b/contrib/perl5/lib/File/Path.pm @@ -0,0 +1,228 @@ +package File::Path; + +=head1 NAME + +File::Path - create or remove a series of directories + +=head1 SYNOPSIS + +C<use File::Path> + +C<mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);> + +C<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) + +=back + +It returns a list of all directories (including intermediates, determined +using the Unix '/' separator) created. + +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 +treated as ordinary files. + +B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure> +in the face of failure or interruption. Files and directories which +were not deleted may be left with permissions reset to allow world +read and write access. Note also that the occurrence of errors in +rmtree can be determined I<only> by trapping diagnostic messages +using C<$SIG{__WARN__}>; it is not apparent from the return value. +Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0> +in situations where security is an issue. + +=head1 AUTHORS + +Tim Bunce <F<Tim.Bunce@ig.co.uk>> and +Charles Bailey <F<bailey@genetics.upenn.edu>> + +=head1 REVISION + +Current $VERSION is 1.0401. + +=cut + +use Carp; +use File::Basename (); +use DirHandle (); +use Exporter (); +use strict; + +use vars qw( $VERSION @ISA @EXPORT ); +$VERSION = "1.0401"; +@ISA = qw( Exporter ); +@EXPORT = qw( mkpath rmtree ); + +my $Is_VMS = $^O eq 'VMS'; + +# 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'); + +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($")="/"; + $mode = 0777 unless defined($mode); + $paths = [$paths] unless ref $paths; + my(@created,$path); + foreach $path (@$paths) { + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT + next if -d $path; + # Logic wants Unix paths, so go with the flow. + $path = VMS::Filespec::unixify($path) if $Is_VMS; + my $parent = File::Basename::dirname($path); + # Allow for creation of new logical filesystems under VMS + if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { + push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + } + print "mkdir $path\n" if $verbose; + unless (mkdir($path,$mode)) { + # allow for another process to have created it meanwhile + croak "mkdir $path: $!" unless -d $path; + } + push(@created, $path); + } + @created; +} + +sub rmtree { + my($roots, $verbose, $safe) = @_; + my(@files); + my($count) = 0; + $roots = [$roots] unless ref $roots; + $verbose ||= 0; + $safe ||= 0; + + my($root); + foreach $root (@{$roots}) { + $root =~ s#/$##; + (undef, undef, my $rp) = lstat $root or next; + $rp &= 07777; # don't forget setuid, setgid, sticky bits + if ( -d _ ) { + # notabene: 0777 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(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or carp "Can't make directory $root read+writeable: $!" + unless $safe; + + my $d = DirHandle->new($root) + or carp "Can't read $root: $!"; + @files = $d->read; + $d->close; + + # 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$## if $Is_VMS; + @files = map("$root/$_", grep $_!~/^\.{1,2}$/,@files); + $count += rmtree(\@files,$verbose,$safe); + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod 0777, $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) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod 0666, $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; diff --git a/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm new file mode 100644 index 0000000..5f3dbf5 --- /dev/null +++ b/contrib/perl5/lib/File/Spec.pm @@ -0,0 +1,116 @@ +package File::Spec; + +require Exporter; + +@ISA = qw(Exporter); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + +); +@EXPORT_OK = qw($Verbose); + +use strict; +use vars qw(@ISA $VERSION $Verbose); + +$VERSION = '0.6'; + +$Verbose = 0; + +require File::Spec::Unix; + + +sub load { + my($class,$OS) = @_; + if ($OS eq 'VMS') { + require File::Spec::VMS; + require VMS::Filespec; + 'File::Spec::VMS' + } elsif ($OS eq 'os2') { + require File::Spec::OS2; + 'File::Spec::OS2' + } elsif ($OS eq 'MacOS') { + require File::Spec::Mac; + 'File::Spec::Mac' + } elsif ($OS eq 'MSWin32') { + require File::Spec::Win32; + 'File::Spec::Win32' + } else { + 'File::Spec::Unix' + } +} + +@ISA = load('File::Spec', $^O); + +1; +__END__ + +=head1 NAME + +File::Spec - portably perform operations on file names + +=head1 SYNOPSIS + +C<use File::Spec;> + +C<$x=File::Spec-E<gt>catfile('a','b','c');> + +which returns 'a/b/c' under Unix. + +=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 OS specific +facilities, it may not be possible to load all modules under all operating +systems. + +Since File::Spec is object oriented, subroutines should not called directly, +as in: + + File::Spec::catfile('a','b'); + +but rather as class methods: + + File::Spec->catfile('a','b'); + +For a reference of available functions, pleaes consult L<File::Spec::Unix>, +which contains the entire set, and inherited by the modules for other +platforms. For further information, please see L<File::Spec::Mac>, +L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. + +=head1 SEE ALSO + +File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32, +File::Spec::VMS, ExtUtils::MakeMaker + +=head1 AUTHORS + +Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty +<F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig +<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS +support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 support by +Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder +<F<schinder@pobox.com>>. + +=cut + + +1; diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm new file mode 100644 index 0000000..4968e24 --- /dev/null +++ b/contrib/perl5/lib/File/Spec/Mac.pm @@ -0,0 +1,230 @@ +package File::Spec::Mac; + +use Exporter (); +use Config; +use strict; +use File::Spec; +use vars qw(@ISA $VERSION $Is_Mac); + +$VERSION = '1.0'; + +@ISA = qw(File::Spec::Unix); +$Is_Mac = $^O eq 'MacOS'; + +Exporter::import('File::Spec', '$Verbose'); + + +=head1 NAME + +File::Spec::Mac - File::Spec for MacOS + +=head1 SYNOPSIS + +C<require File::Spec::Mac;> + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item canonpath + +On MacOS, there's nothing to be done. Returns what it's given. + +=cut + +sub canonpath { + my($self,$path) = @_; + $path; +} + +=item catdir + +Concatenate two or more directory names to form a complete path ending with +a directory. Put a trailing : on the end of the complete path if there +isn't one, because that's what's done in MacPerl's environment. + +The fundamental requirement of this routine is that + + File::Spec->catdir(split(":",$path)) eq $path + +But because of the nature of Macintosh paths, some additional +possibilities are allowed to make using this routine give resonable results +for some common situations. Here are the rules that are used. Each +argument has its trailing ":" removed. Each argument, except the first, +has its leading ":" removed. They are then joined together by a ":". + +So + + File::Spec->catdir("a","b") = "a:b:" + File::Spec->catdir("a:",":b") = "a:b:" + File::Spec->catdir("a:","b") = "a:b:" + File::Spec->catdir("a",":b") = "a:b" + File::Spec->catdir("a","","b") = "a::b" + +etc. + +To get a relative path (one beginning with :), begin the first argument with : +or put a "" as the first argument. + +If you don't want to worry about these rules, never allow a ":" on the ends +of any of the arguments except at the beginning of the first. + +Under MacPerl, there is an additional ambiguity. Does the user intend that + + File::Spec->catfile("LWP","Protocol","http.pm") + +be relative or absolute? There's no way of telling except by checking for the +existance of LWP: or :LWP, and even there he may mean a dismounted volume or +a relative path in a different directory (like in @INC). So those checks +aren't done here. This routine will treat this as absolute. + +=cut + +# '; + +sub catdir { + shift; + my @args = @_; + $args[0] =~ s/:$//; + my $result = shift @args; + for (@args) { + s/:$//; + s/^://; + $result .= ":$_"; + } + $result .= ":"; + $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename. Since this uses catdir, the +same caveats apply. Note that the leading : is removed from the filename, +so that + + File::Spec->catfile($ENV{HOME},"file"); + +and + + File::Spec->catfile($ENV{HOME},":file"); + +give the same answer, as one might expect. + +=cut + +sub catfile { + my $self = shift @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $file =~ s/^://; + return $dir.$file; +} + +=item curdir + +Returns a string representing of the current directory. + +=cut + +sub curdir { + return ":" ; +} + +=item rootdir + +Returns a string representing the root directory. Under MacPerl, +returns the name of the startup volume, since that's the closest in +concept, although other volumes aren't rooted there. On any other +platform returns '', since there's no common way to indicate "root +directory" across all Macs. + +=cut + +sub rootdir { +# +# There's no real root directory on MacOS. If you're using MacPerl, +# the name of the startup volume is returned, since that's the closest in +# concept. On other platforms, simply return '', because nothing better +# can be done. +# + if($Is_Mac) { + require Mac::Files; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*$/:/; + return $system; + } else { + return ''; + } +} + +=item updir + +Returns a string representing the parent directory. + +=cut + +sub updir { + return "::"; +} + +=item file_name_is_absolute + +Takes as argument a path and returns true, if it is an absolute path. In +the case where a name can be either relative or absolute (for example, a +folder named "HD" in the current working directory on a drive named "HD"), +relative wins. Use ":" in the appropriate place in the path if you want to +distinguish unambiguously. + +=cut + +sub file_name_is_absolute { + my($self,$file) = @_; + if ($file =~ /:/) { + return ($file !~ m/^:/); + } else { + return (! -e ":$file"); + } +} + +=item path + +Returns the null list for the MacPerl application, since the concept is +usually meaningless under MacOS. But if you're using the MacPerl tool under +MPW, it gives back $ENV{Commands} suitably split, as is done in +:lib:ExtUtils:MM_Mac.pm. + +=cut + +sub path { +# +# The concept is meaningless under the MacPerl application. +# Under MPW, it has a meaning. +# + my($self) = @_; + my @path; + if(exists $ENV{Commands}) { + @path = split /,/,$ENV{Commands}; + } else { + @path = (); + } + @path; +} + +=back + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +1; +__END__ + diff --git a/contrib/perl5/lib/File/Spec/OS2.pm b/contrib/perl5/lib/File/Spec/OS2.pm new file mode 100644 index 0000000..d602617 --- /dev/null +++ b/contrib/perl5/lib/File/Spec/OS2.pm @@ -0,0 +1,51 @@ +package File::Spec::OS2; + +#use Config; +#use Cwd; +#use File::Basename; +use strict; +require Exporter; + +use File::Spec; +use vars qw(@ISA); + +Exporter::import('File::Spec', + qw( $Verbose)); + +@ISA = qw(File::Spec::Unix); + +$ENV{EMXSHELL} = 'sh'; # to run `commands` + +sub file_name_is_absolute { + my($self,$file) = @_; + $file =~ m{^([a-z]:)?[\\/]}i ; +} + +sub path { + my($self) = @_; + my $path_sep = ";"; + my $path = $ENV{PATH}; + $path =~ s:\\:/:g; + my @path = split $path_sep, $path; + foreach(@path) { $_ = '.' if $_ eq '' } + @path; +} + +1; +__END__ + +=head1 NAME + +File::Spec::OS2 - methods for OS/2 file specs + +=head1 SYNOPSIS + + use File::Spec::OS2; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=cut diff --git a/contrib/perl5/lib/File/Spec/Unix.pm b/contrib/perl5/lib/File/Spec/Unix.pm new file mode 100644 index 0000000..77de73a --- /dev/null +++ b/contrib/perl5/lib/File/Spec/Unix.pm @@ -0,0 +1,197 @@ +package File::Spec::Unix; + +use Exporter (); +use Config; +use File::Basename qw(basename dirname fileparse); +use DirHandle; +use strict; +use vars qw(@ISA $Is_Mac $Is_OS2 $Is_VMS $Is_Win32); +use File::Spec; + +Exporter::import('File::Spec', '$Verbose'); + +$Is_OS2 = $^O eq 'os2'; +$Is_Mac = $^O eq 'MacOS'; +$Is_Win32 = $^O eq 'MSWin32'; + +if ($Is_VMS = $^O eq 'VMS') { + require VMS::Filespec; + import VMS::Filespec qw( &vmsify ); +} + +=head1 NAME + +File::Spec::Unix - methods used by File::Spec + +=head1 SYNOPSIS + +C<require File::Spec::Unix;> + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my($self,$path) = @_; + $path =~ s|/+|/|g ; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx + $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx + $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx + $path; +} + +=item catdir + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + +=cut + +# '; + +sub catdir { + shift; + my @args = @_; + for (@args) { + # append a slash to each argument unless it has one there + $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; + } + my $result = join('', @args); + # remove a trailing slash unless we are root + substr($result,-1) = "" + if length($result) > 1 && substr($result,-1) eq "/"; + $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + for ($dir) { + $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; + } + return $dir.$file; +} + +=item curdir + +Returns a string representing of the current directory. "." on UNIX. + +=cut + +sub curdir { + return "." ; +} + +=item rootdir + +Returns a string representing of the root directory. "/" on UNIX. + +=cut + +sub rootdir { + return "/"; +} + +=item updir + +Returns a string representing of the parent directory. ".." on UNIX. + +=cut + +sub updir { + return ".."; +} + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + +=cut + +sub no_upwards { + my($self) = shift; + return grep(!/^\.{1,2}$/, @_); +} + +=item file_name_is_absolute + +Takes as argument a path and returns true, if it is an absolute path. + +=cut + +sub file_name_is_absolute { + my($self,$file) = @_; + $file =~ m:^/: ; +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. + +=cut + +sub path { + my($self) = @_; + my $path_sep = ":"; + my $path = $ENV{PATH}; + my @path = split $path_sep, $path; + foreach(@path) { $_ = '.' if $_ eq '' } + @path; +} + +=item join + +join is the same as catfile. + +=cut + +sub join { + my($self) = shift @_; + $self->catfile(@_); +} + +=item nativename + +TBW. + +=cut + +sub nativename { + my($self,$name) = shift @_; + $name; +} + +=back + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +1; +__END__ diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm new file mode 100644 index 0000000..c5269fd --- /dev/null +++ b/contrib/perl5/lib/File/Spec/VMS.pm @@ -0,0 +1,148 @@ + +package File::Spec::VMS; + +use Carp qw( &carp ); +use Config; +require Exporter; +use VMS::Filespec; +use File::Basename; + +use File::Spec; +use vars qw($Revision); +$Revision = '5.3901 (6-Mar-1997)'; + +@ISA = qw(File::Spec::Unix); + +Exporter::import('File::Spec', '$Verbose'); + +=head1 NAME + +File::Spec::VMS - methods for VMS file specs + +=head1 SYNOPSIS + + use File::Spec::VMS; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=head2 Methods always loaded + +=over + +=item catdir + +Concatenates a list of file specifications, and returns the result as a +VMS-syntax directory specification. + +=cut + +sub catdir { + my($self,@dirs) = @_; + my($dir) = pop @dirs; + @dirs = grep($_,@dirs); + my($rslt); + if (@dirs) { + my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my($spath,$sdir) = ($path,$dir); + $spath =~ s/.dir$//; $sdir =~ s/.dir$//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + } + else { + if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } + else { $rslt = vmspath($dir); } + } + print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; + $rslt; +} + +=item catfile + +Concatenates a list of file specifications, and returns the result as a +VMS-syntax directory specification. + +=cut + +sub catfile { + my($self,@files) = @_; + my($file) = pop @files; + @files = grep($_,@files); + my($rslt); + if (@files) { + my($path) = (@files == 1 ? $files[0] : $self->catdir(@files)); + my($spath) = $path; + $spath =~ s/.dir$//; + if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } + } + else { $rslt = vmsify($file); } + print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; + $rslt; +} + +=item curdir (override) + +Returns a string representing of the current directory. + +=cut + +sub curdir { + return '[]'; +} + +=item rootdir (override) + +Returns a string representing of the root directory. + +=cut + +sub rootdir { + return ''; +} + +=item updir (override) + +Returns a string representing of the parent directory. + +=cut + +sub updir { + return '[-]'; +} + +=item path (override) + +Translate logical name DCL$PATH as a searchlist, rather than trying +to C<split> string value of C<$ENV{'PATH'}>. + +=cut + +sub path { + my(@dirs,$dir,$i); + while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } + @dirs; +} + +=item file_name_is_absolute (override) + +Checks for VMS directory spec as well as Unix separators. + +=cut + +sub file_name_is_absolute { + my($self,$file) = @_; + # If it's a logical name, expand it. + $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; + $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; +} + +1; +__END__ + diff --git a/contrib/perl5/lib/File/Spec/Win32.pm b/contrib/perl5/lib/File/Spec/Win32.pm new file mode 100644 index 0000000..034a0cb --- /dev/null +++ b/contrib/perl5/lib/File/Spec/Win32.pm @@ -0,0 +1,104 @@ +package File::Spec::Win32; + +=head1 NAME + +File::Spec::Win32 - methods for Win32 file specs + +=head1 SYNOPSIS + + use File::Spec::Win32; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over + +=cut + +#use Config; +#use Cwd; +use File::Basename; +require Exporter; +use strict; + +use vars qw(@ISA); + +use File::Spec; +Exporter::import('File::Spec', qw( $Verbose)); + +@ISA = qw(File::Spec::Unix); + +$ENV{EMXSHELL} = 'sh'; # to run `commands` + +sub file_name_is_absolute { + my($self,$file) = @_; + $file =~ m{^([a-z]:)?[\\/]}i ; +} + +sub catdir { + my $self = shift; + my @args = @_; + for (@args) { + # append a slash to each argument unless it has one there + $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + } + my $result = $self->canonpath(join('', @args)); + $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $dir =~ s/(\\\.)$//; + $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; + return $dir.$file; +} + +sub path { + local $^W = 1; + my($self) = @_; + my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; + my @path = split(';',$path); + foreach(@path) { $_ = '.' if $_ eq '' } + @path; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my($self,$path) = @_; + $path =~ s/^([a-z]:)/\u$1/; + $path =~ s|/|\\|g; + $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx + $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx + $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx + $path =~ s|\\$|| + unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx + $path .= '.' if $path =~ m#\\$#; + $path; +} + +1; +__END__ + +=back + +=cut + diff --git a/contrib/perl5/lib/File/stat.pm b/contrib/perl5/lib/File/stat.pm new file mode 100644 index 0000000..f5d17f7 --- /dev/null +++ b/contrib/perl5/lib/File/stat.pm @@ -0,0 +1,113 @@ +package File::stat; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @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; + no strict 'refs'; + require Symbol; + return populate(CORE::stat \*{Symbol::qualify($arg)}); +} + +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 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 |
