diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File')
38 files changed, 17943 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Basename.pm b/Master/tlpkg/tlperl/lib/File/Basename.pm new file mode 100755 index 00000000000..b3fe0ac6e59 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Basename.pm @@ -0,0 +1,402 @@ +=head1 NAME + +File::Basename - Parse file paths into directory, filename and suffix. + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist); + $name = fileparse($fullname,@suffixlist); + + $basename = basename($fullname,@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.77"; + +fileparse_set_fstype($^O); + + +=over 4 + +=item C<fileparse> +X<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.txt", 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,@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> +X<basename> X<filename> + + 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",@_) ); + + # 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> +X<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> +X<filesystem> + + 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> diff --git a/Master/tlpkg/tlperl/lib/File/CheckTree.pm b/Master/tlpkg/tlperl/lib/File/CheckTree.pm new file mode 100755 index 00000000000..d7948f2385f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/CheckTree.pm @@ -0,0 +1,238 @@ +package File::CheckTree; + +use 5.006; +use Cwd; +use Exporter; +use File::Spec; +use warnings; +use strict; + +our $VERSION = '4.4'; +our @ISA = qw(Exporter); +our @EXPORT = qw(validate); + +=head1 NAME + +File::CheckTree - 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@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 "-r || die" + # (making special allowance for quoted filenames). + if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or + $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or + $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/) + { + ($file, $test) = ($1,$2); + } + else { + die "Malformed line: '$check'"; + }; + + # 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 (my $err = $@) { + # in case of any cd directives, return from whence we came + if ($starting_dir ne cwd) { + chdir($starting_dir) || die "$starting_dir: $!"; + } + die $err; + } + } + + # 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; diff --git a/Master/tlpkg/tlperl/lib/File/Compare.pm b/Master/tlpkg/tlperl/lib/File/Compare.pm new file mode 100755 index 00000000000..05e1c41d211 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Compare.pm @@ -0,0 +1,182 @@ +package File::Compare; + +use 5.006; +use strict; +use warnings; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); + +require Exporter; + +$VERSION = '1.1006'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp compare_text); + +$Too_Big = 1024 * 1024 * 2; + +sub croak { + require Carp; + goto &Carp::croak; +} + +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 + diff --git a/Master/tlpkg/tlperl/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm new file mode 100755 index 00000000000..e1d77244b9b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Copy.pm @@ -0,0 +1,533 @@ +# 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 5.006; +use strict; +use warnings; +use File::Spec; +use Config; +# During perl build, we need File::Copy but Fcntl might not be built yet +# *** not needed for 2.14, only 2.15 +# *** my $Fcntl_loaded = eval q{ use Fcntl qw [O_CREAT O_WRONLY O_TRUNC]; 1 }; +# Similarly Scalar::Util +# And then we need these games to avoid loading overload, as that will +# confuse miniperl during the bootstrap of perl. +my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; +our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); +sub copy; +sub syscopy; +sub cp; +sub mv; + +$VERSION = '2.14'; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); + +$Too_Big = 1024 * 1024 * 2; + +sub croak { + require Carp; + goto &Carp::croak; +} + +sub carp { + require Carp; + goto &Carp::carp; +} + +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)); +} + +# _eq($from, $to) tells whether $from and $to are identical +sub _eq { + my ($from, $to) = map { + $Scalar_Util_loaded && Scalar::Util::blessed($_) + && overload::Method($_, q{""}) + ? "$_" + : $_ + } (@_); + return '' if ( (ref $from) xor (ref $to) ); + return $from == $to if ref $from; + return $from eq $to; +} + +sub copy { + croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + + my $size; + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for copy: $size\n") unless ($size > 0); + } + + 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 (_eq($from, $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')) { + 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') + ) + { + my $copy_to = $to; + + if ($^O eq 'VMS' && -e $from) { + + if (! -d $to && ! -d $from) { + + # VMS has sticky defaults on extensions, which means that + # if there is a null extension on the destination file, it + # will inherit the extension of the source file + # So add a '.' for a null extension. + + $copy_to = VMS::Filespec::vmsify($to); + my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to); + $file = $file . '.' unless ($file =~ /(?<!\^)\./); + $copy_to = File::Spec->catpath($vol, $dirs, $file); + + # Get rid of the old versions to be like UNIX + 1 while unlink $copy_to; + } + } + + return syscopy($from, $copy_to); + } + + my $closefrom = 0; + my $closeto = 0; + my ($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 or goto fail_open1; + binmode $from_h or die "($!,$^E)"; + $closefrom = 1; + } + + # Seems most logical to do this here, in case future changes would want to + # make this croak for some reason. + unless (defined $size) { + $size = tied(*$from_h) ? 0 : -s $from_h || 0; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + 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 or goto fail_open2; + binmode $to_h or die "($!,$^E)"; + $closeto = 1; + } + + $! = 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; + } + + my $rename_to = $to; + if (-$^O eq 'VMS' && -e $from) { + + if (! -d $to && ! -d $from) { + # VMS has sticky defaults on extensions, which means that + # if there is a null extension on the destination file, it + # will inherit the extension of the source file + # So add a '.' for a null extension. + + $rename_to = VMS::Filespec::vmsify($to); + my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to); + $file = $file . '.' unless ($file =~ /(?<!\^)\./); + $rename_to = File::Spec->catpath($vol, $dirs, $file); + + # Get rid of the old versions to be like UNIX + 1 while unlink $rename_to; + } + } + + return 1 if rename $from, $rename_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 + ((!defined $tosz1) || # not before or + ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was 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 = \© +*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' && defined &DynaLoader::boot_DynaLoader) { + # Win32::CopyFile() fill only work if we can load Win32.xs + *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 = \© + } +} + +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 copy +X<copy> X<cp> + +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 will 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 move +X<move> X<mv> X<rename> + +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>. + +=item syscopy +X<syscopy> + +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. + +B<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). + +=item rmscopy($from,$to[,$date_flag]) +X<rmscopy> + +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 (doesn't copy) files from one + # volume to another + +=back + +=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@newman.upenn.eduE<gt>> in 1996. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm new file mode 100755 index 00000000000..496a14c1379 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/DosGlob.pm @@ -0,0 +1,571 @@ +#!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.01'; +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($pat,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,@pat) )] : [()]; + } else { + $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; + } + } +} + +{ + 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@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 + diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm new file mode 100755 index 00000000000..4aabc29be55 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Fetch.pm @@ -0,0 +1,1466 @@ +package File::Fetch; + +use strict; +use FileHandle; +use File::Temp; +use File::Copy; +use File::Spec; +use File::Spec::Unix; +use File::Basename qw[dirname]; + +use Cwd qw[cwd]; +use Carp qw[carp]; +use IPC::Cmd qw[can_run run QUOTE]; +use File::Path qw[mkpath]; +use File::Temp qw[tempdir]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Style => 'gettext'; + +use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT + $BLACKLIST $METHOD_FAIL $VERSION $METHODS + $FTP_PASSIVE $TIMEOUT $DEBUG $WARN + ]; + +$VERSION = '0.24'; +$VERSION = eval $VERSION; # avoid warnings with development releases +$PREFER_BIN = 0; # XXX TODO implement +$FROM_EMAIL = 'File-Fetch@example.com'; +$USER_AGENT = "File::Fetch/$VERSION"; +$BLACKLIST = [qw|ftp|]; +$METHOD_FAIL = { }; +$FTP_PASSIVE = 1; +$TIMEOUT = 0; +$DEBUG = 0; +$WARN = 1; + +### methods available to fetch the file depending on the scheme +$METHODS = { + http => [ qw|lwp wget curl lftp lynx iosock| ], + ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ], + file => [ qw|lwp lftp file| ], + rsync => [ qw|rsync| ] +}; + +### silly warnings ### +local $Params::Check::VERBOSE = 1; +local $Params::Check::VERBOSE = 1; +local $Module::Load::Conditional::VERBOSE = 0; +local $Module::Load::Conditional::VERBOSE = 0; + +### see what OS we are on, important for file:// uris ### +use constant ON_WIN => ($^O eq 'MSWin32'); +use constant ON_VMS => ($^O eq 'VMS'); +use constant ON_UNIX => (!ON_WIN); +use constant HAS_VOL => (ON_WIN); +use constant HAS_SHARE => (ON_WIN); + + +=pod + +=head1 NAME + +File::Fetch - A generic file fetching mechanism + +=head1 SYNOPSIS + + use File::Fetch; + + ### build a File::Fetch object ### + my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt'); + + ### fetch the uri to cwd() ### + my $where = $ff->fetch() or die $ff->error; + + ### fetch the uri to /tmp ### + my $where = $ff->fetch( to => '/tmp' ); + + ### parsed bits from the uri ### + $ff->uri; + $ff->scheme; + $ff->host; + $ff->path; + $ff->file; + +=head1 DESCRIPTION + +File::Fetch is a generic file fetching mechanism. + +It allows you to fetch any file pointed to by a C<ftp>, C<http>, +C<file>, or C<rsync> uri by a number of different means. + +See the C<HOW IT WORKS> section further down for details. + +=head1 ACCESSORS + +A C<File::Fetch> object has the following accessors + +=over 4 + +=item $ff->uri + +The uri you passed to the constructor + +=item $ff->scheme + +The scheme from the uri (like 'file', 'http', etc) + +=item $ff->host + +The hostname in the uri. Will be empty if host was originally +'localhost' for a 'file://' url. + +=item $ff->vol + +On operating systems with the concept of a volume the second element +of a file:// is considered to the be volume specification for the file. +Thus on Win32 this routine returns the volume, on other operating +systems this returns nothing. + +On Windows this value may be empty if the uri is to a network share, in +which case the 'share' property will be defined. Additionally, volume +specifications that use '|' as ':' will be converted on read to use ':'. + +On VMS, which has a volume concept, this field will be empty because VMS +file specifications are converted to absolute UNIX format and the volume +information is transparently included. + +=item $ff->share + +On systems with the concept of a network share (currently only Windows) returns +the sharename from a file://// url. On other operating systems returns empty. + +=item $ff->path + +The path from the uri, will be at least a single '/'. + +=item $ff->file + +The name of the remote file. For the local file name, the +result of $ff->output_file will be used. + +=cut + + +########################## +### Object & Accessors ### +########################## + +{ + ### template for autogenerated accessors ### + my $Tmpl = { + scheme => { default => 'http' }, + host => { default => 'localhost' }, + path => { default => '/' }, + file => { required => 1 }, + uri => { required => 1 }, + vol => { default => '' }, # windows for file:// uris + share => { default => '' }, # windows for file:// uris + _error_msg => { no_override => 1 }, + _error_msg_long => { no_override => 1 }, + }; + + for my $method ( keys %$Tmpl ) { + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method} = $_[0] if @_; + return $self->{$method}; + } + } + + sub _create { + my $class = shift; + my %hash = @_; + + my $args = check( $Tmpl, \%hash ) or return; + + bless $args, $class; + + if( lc($args->scheme) ne 'file' and not $args->host ) { + return $class->_error(loc( + "Hostname required when fetching from '%1'",$args->scheme)); + } + + for (qw[path file]) { + unless( $args->$_() ) { # 5.5.x needs the () + return $class->_error(loc("No '%1' specified",$_)); + } + } + + return $args; + } +} + +=item $ff->output_file + +The name of the output file. This is the same as $ff->file, +but any query parameters are stripped off. For example: + + http://example.com/index.html?x=y + +would make the output file be C<index.html> rather than +C<index.html?x=y>. + +=back + +=cut + +sub output_file { + my $self = shift; + my $file = $self->file; + + $file =~ s/\?.*$//g; + + return $file; +} + +### XXX do this or just point to URI::Escape? +# =head2 $esc_uri = $ff->escaped_uri +# +# =cut +# +# ### most of this is stolen straight from URI::escape +# { ### Build a char->hex map +# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; +# +# sub escaped_uri { +# my $self = shift; +# my $uri = $self->uri; +# +# ### Default unsafe characters. RFC 2732 ^(uric - reserved) +# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/ +# $escapes{$1} || $self->_fail_hi($1)/ge; +# +# return $uri; +# } +# +# sub _fail_hi { +# my $self = shift; +# my $char = shift; +# +# $self->_error(loc( +# "Can't escape '%1', try using the '%2' module instead", +# sprintf("\\x{%04X}", ord($char)), 'URI::Escape' +# )); +# } +# +# sub output_file { +# +# } +# +# +# } + +=head1 METHODS + +=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' ); + +Parses the uri and creates a corresponding File::Fetch::Item object, +that is ready to be C<fetch>ed and returns it. + +Returns false on failure. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + my ($uri); + my $tmpl = { + uri => { required => 1, store => \$uri }, + }; + + check( $tmpl, \%hash ) or return; + + ### parse the uri to usable parts ### + my $href = $class->_parse_uri( $uri ) or return; + + ### make it into a FFI object ### + my $ff = $class->_create( %$href ) or return; + + + ### return the object ### + return $ff; +} + +### parses an uri to a hash structure: +### +### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' ) +### +### becomes: +### +### $href = { +### scheme => 'ftp', +### host => 'ftp.cpan.org', +### path => '/pub/mirror', +### file => 'index.html' +### }; +### +### In the case of file:// urls there maybe be additional fields +### +### For systems with volume specifications such as Win32 there will be +### a volume specifier provided in the 'vol' field. +### +### 'vol' => 'volumename' +### +### For windows file shares there may be a 'share' key specified +### +### 'share' => 'sharename' +### +### Note that the rules of what a file:// url means vary by the operating system +### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious +### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and +### not '/foo/bar.txt' +### +### Similarly if the host interpreting the url is VMS then +### file:///disk$user/my/notes/note12345.txt' means +### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as +### if it is unix where it means /disk$user/my/notes/note12345.txt'. +### Except for some cases in the File::Spec methods, Perl on VMS will generally +### handle UNIX format file specifications. +### +### This means it is impossible to serve certain file:// urls on certain systems. +### +### Thus are the problems with a protocol-less specification. :-( +### + +sub _parse_uri { + my $self = shift; + my $uri = shift or return; + + my $href = { uri => $uri }; + + ### find the scheme ### + $uri =~ s|^(\w+)://||; + $href->{scheme} = $1; + + ### See rfc 1738 section 3.10 + ### http://www.faqs.org/rfcs/rfc1738.html + ### And wikipedia for more on windows file:// urls + ### http://en.wikipedia.org/wiki/File:// + if( $href->{scheme} eq 'file' ) { + + my @parts = split '/',$uri; + + ### file://hostname/... + ### file://hostname/... + ### normalize file://localhost with file:/// + $href->{host} = $parts[0] || ''; + + ### index in @parts where the path components begin; + my $index = 1; + + ### file:////hostname/sharename/blah.txt + if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) { + + $href->{host} = $parts[2] || ''; # avoid warnings + $href->{share} = $parts[3] || ''; # avoid warnings + + $index = 4 # index after the share + + ### file:///D|/blah.txt + ### file:///D:/blah.txt + } elsif (HAS_VOL) { + + ### this code comes from dmq's patch, but: + ### XXX if volume is empty, wouldn't that be an error? --kane + ### if so, our file://localhost test needs to be fixed as wel + $href->{vol} = $parts[1] || ''; + + ### correct D| style colume descriptors + $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN; + + $index = 2; # index after the volume + } + + ### rebuild the path from the leftover parts; + $href->{path} = join '/', '', splice( @parts, $index, $#parts ); + + } else { + ### using anything but qw() in hash slices may produce warnings + ### in older perls :-( + @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s; + } + + ### split the path into file + dir ### + { my @parts = File::Spec::Unix->splitpath( delete $href->{path} ); + $href->{path} = $parts[1]; + $href->{file} = $parts[2]; + } + + ### host will be empty if the target was 'localhost' and the + ### scheme was 'file' + $href->{host} = '' if ($href->{host} eq 'localhost') and + ($href->{scheme} eq 'file'); + + return $href; +} + +=head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] ) + +Fetches the file you requested and returns the full path to the file. + +By default it writes to C<cwd()>, but you can override that by specifying +the C<to> argument: + + ### file fetch to /tmp, full path to the file in $where + $where = $ff->fetch( to => '/tmp' ); + + ### file slurped into $scalar, full path to the file in $where + ### file is downloaded to a temp directory and cleaned up at exit time + $where = $ff->fetch( to => \$scalar ); + +Returns the full path to the downloaded file on success, and false +on failure. + +=cut + +sub fetch { + my $self = shift or return; + my %hash = @_; + + my $target; + my $tmpl = { + to => { default => cwd(), store => \$target }, + }; + + check( $tmpl, \%hash ) or return; + + my ($to, $fh); + ### you want us to slurp the contents + if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { + $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 ); + + ### plain old fetch + } else { + $to = $target; + + ### On VMS force to VMS format so File::Spec will work. + $to = VMS::Filespec::vmspath($to) if ON_VMS; + + ### create the path if it doesn't exist yet ### + unless( -d $to ) { + eval { mkpath( $to ) }; + + return $self->_error(loc("Could not create path '%1'",$to)) if $@; + } + } + + ### set passive ftp if required ### + local $ENV{FTP_PASSIVE} = $FTP_PASSIVE; + + ### we dont use catfile on win32 because if we are using a cygwin tool + ### under cmd.exe they wont understand windows style separators. + my $out_to = ON_WIN ? $to.'/'.$self->output_file + : File::Spec->catfile( $to, $self->output_file ); + + for my $method ( @{ $METHODS->{$self->scheme} } ) { + my $sub = '_'.$method.'_fetch'; + + unless( __PACKAGE__->can($sub) ) { + $self->_error(loc("Cannot call method for '%1' -- WEIRD!", + $method)); + next; + } + + ### method is blacklisted ### + next if grep { lc $_ eq $method } @$BLACKLIST; + + ### method is known to fail ### + next if $METHOD_FAIL->{$method}; + + ### there's serious issues with IPC::Run and quoting of command + ### line arguments. using quotes in the wrong place breaks things, + ### and in the case of say, + ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document + ### "index.html" "http://www.cpan.org/index.html?q=1&y=2" + ### it doesn't matter how you quote, it always fails. + local $IPC::Cmd::USE_IPC_RUN = 0; + + if( my $file = $self->$sub( + to => $out_to + )){ + + unless( -e $file && -s _ ) { + $self->_error(loc("'%1' said it fetched '%2', ". + "but it was not created",$method,$file)); + + ### mark the failure ### + $METHOD_FAIL->{$method} = 1; + + next; + + } else { + + ### slurp mode? + if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { + + ### open the file + open my $fh, $file or do { + $self->_error( + loc("Could not open '%1': %2", $file, $!)); + return; + }; + + ### slurp + $$target = do { local $/; <$fh> }; + + } + + my $abs = File::Spec->rel2abs( $file ); + return $abs; + + } + } + } + + + ### if we got here, we looped over all methods, but we weren't able + ### to fetch it. + return; +} + +######################## +### _*_fetch methods ### +######################## + +### LWP fetching ### +sub _lwp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### modules required to download with lwp ### + my $use_list = { + LWP => '0.0', + 'LWP::UserAgent' => '0.0', + 'HTTP::Request' => '0.0', + 'HTTP::Status' => '0.0', + URI => '0.0', + + }; + + if( can_load(modules => $use_list) ) { + + ### setup the uri object + my $uri = URI->new( File::Spec::Unix->catfile( + $self->path, $self->file + ) ); + + ### special rules apply for file:// uris ### + $uri->scheme( $self->scheme ); + $uri->host( $self->scheme eq 'file' ? '' : $self->host ); + $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file'; + + ### set up the useragent object + my $ua = LWP::UserAgent->new(); + $ua->timeout( $TIMEOUT ) if $TIMEOUT; + $ua->agent( $USER_AGENT ); + $ua->from( $FROM_EMAIL ); + $ua->env_proxy; + + my $res = $ua->mirror($uri, $to) or return; + + ### uptodate or fetched ok ### + if ( $res->code == 304 or $res->code == 200 ) { + return $to; + + } else { + return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]", + $res->code, HTTP::Status::status_message($res->code), + $res->status_line)); + } + + } else { + $METHOD_FAIL->{'lwp'} = 1; + return; + } +} + +### Simple IO::Socket::INET fetching ### +sub _iosock_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + my $use_list = { + 'IO::Socket::INET' => '0.0', + 'IO::Select' => '0.0', + }; + + if( can_load(modules => $use_list) ) { + my $sock = IO::Socket::INET->new( + PeerHost => $self->host, + ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), + ); + + unless ( $sock ) { + return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); + } + + my $fh = FileHandle->new; + + # Check open() + + unless ( $fh->open($to,'>') ) { + return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + } + + my $path = File::Spec::Unix->catfile( $self->path, $self->file ); + my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a"; + $sock->send( $req ); + + my $select = IO::Select->new( $sock ); + + my $resp = ''; + my $normal = 0; + while ( $select->can_read( $TIMEOUT || 60 ) ) { + my $ret = $sock->sysread( $resp, 4096, length($resp) ); + if ( !defined $ret or $ret == 0 ) { + $select->remove( $sock ); + $normal++; + } + } + close $sock; + + unless ( $normal ) { + return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); + } + + # Check the "response" + # Strip preceeding blank lines apparently they are allowed (RFC 2616 4.1) + $resp =~ s/^(\x0d?\x0a)+//; + # Check it is an HTTP response + unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) { + return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host)); + } + + # Check for OK + my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i; + unless ( $code eq '200' ) { + return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host)); + } + + print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; + close $fh; + return $to; + + } else { + $METHOD_FAIL->{'iosock'} = 1; + return; + } +} + +### Net::FTP fetching +sub _netftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### required modules ### + my $use_list = { 'Net::FTP' => 0 }; + + if( can_load( modules => $use_list ) ) { + + ### make connection ### + my $ftp; + my @options = ($self->host); + push(@options, Timeout => $TIMEOUT) if $TIMEOUT; + unless( $ftp = Net::FTP->new( @options ) ) { + return $self->_error(loc("Ftp creation failed: %1",$@)); + } + + ### login ### + unless( $ftp->login( anonymous => $FROM_EMAIL ) ) { + return $self->_error(loc("Could not login to '%1'",$self->host)); + } + + ### set binary mode, just in case ### + $ftp->binary; + + ### create the remote path + ### remember remote paths are unix paths! [#11483] + my $remote = File::Spec::Unix->catfile( $self->path, $self->file ); + + ### fetch the file ### + my $target; + unless( $target = $ftp->get( $remote, $to ) ) { + return $self->_error(loc("Could not fetch '%1' from '%2'", + $remote, $self->host)); + } + + ### log out ### + $ftp->quit; + + return $target; + + } else { + $METHOD_FAIL->{'netftp'} = 1; + return; + } +} + +### /bin/wget fetch ### +sub _wget_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a wget binary ### + if( my $wget = can_run('wget') ) { + + ### no verboseness, thanks ### + my $cmd = [ $wget, '--quiet' ]; + + ### if a timeout is set, add it ### + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + + ### run passive if specified ### + push @$cmd, '--passive-ftp' if $FTP_PASSIVE; + + ### set the output document, add the uri ### + push @$cmd, '--output-document', $to, $self->uri; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? ($to, $self->uri) + # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG + )) { + ### wget creates the output document always, even if the fetch + ### fails.. so unlink it in that case + 1 while unlink $to; + + return $self->_error(loc( "Command failed: %1", $captured || '' )); + } + + return $to; + + } else { + $METHOD_FAIL->{'wget'} = 1; + return; + } +} + +### /bin/lftp fetch ### +sub _lftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a wget binary ### + if( my $lftp = can_run('lftp') ) { + + ### no verboseness, thanks ### + my $cmd = [ $lftp, '-f' ]; + + my $fh = File::Temp->new; + + my $str; + + ### if a timeout is set, add it ### + $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT; + + ### run passive if specified ### + $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE; + + ### set the output document, add the uri ### + ### quote the URI, because lftp supports certain shell + ### expansions, most notably & for backgrounding. + ### ' quote does nto work, must be " + $str .= q[get ']. $self->uri .q[' -o ]. $to . $/; + + if( $DEBUG ) { + my $pp_str = join ' ', split $/, $str; + print "# lftp command: $pp_str\n"; + } + + ### write straight to the file. + $fh->autoflush(1); + print $fh $str; + + ### the command needs to be 1 string to be executed + push @$cmd, $fh->filename; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? ($to, $self->uri) + # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG + )) { + ### wget creates the output document always, even if the fetch + ### fails.. so unlink it in that case + 1 while unlink $to; + + return $self->_error(loc( "Command failed: %1", $captured || '' )); + } + + return $to; + + } else { + $METHOD_FAIL->{'lftp'} = 1; + return; + } +} + + + +### /bin/ftp fetch ### +sub _ftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a ftp binary ### + if( my $ftp = can_run('ftp') ) { + + my $fh = FileHandle->new; + + local $SIG{CHLD} = 'IGNORE'; + + unless ($fh->open("|$ftp -n")) { + return $self->_error(loc("%1 creation failed: %2", $ftp, $!)); + } + + my @dialog = ( + "lcd " . dirname($to), + "open " . $self->host, + "user anonymous $FROM_EMAIL", + "cd /", + "cd " . $self->path, + "binary", + "get " . $self->file . " " . $self->output_file, + "quit", + ); + + foreach (@dialog) { $fh->print($_, "\n") } + $fh->close or return; + + return $to; + } +} + +### lynx is stupid - it decompresses any .gz file it finds to be text +### use /bin/lynx to fetch files +sub _lynx_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a lynx binary ### + if( my $lynx = can_run('lynx') ) { + + unless( IPC::Cmd->can_capture_buffer ) { + $METHOD_FAIL->{'lynx'} = 1; + + return $self->_error(loc( + "Can not capture buffers. Can not use '%1' to fetch files", + 'lynx' )); + } + + ### check if the HTTP resource exists ### + if ($self->uri =~ /^https?:\/\//i) { + my $cmd = [ + $lynx, + '-head', + '-source', + "-auth=anonymous:$FROM_EMAIL", + ]; + + push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; + + push @$cmd, $self->uri; + + ### shell out ### + my $head; + unless(run( command => $cmd, + buffer => \$head, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $head || '')); + } + + unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) { + return $self->_error(loc("Command failed: %1", $head || '')); + } + } + + ### write to the output file ourselves, since lynx ass_u_mes to much + my $local = FileHandle->new(">$to") + or return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + + ### dump to stdout ### + my $cmd = [ + $lynx, + '-source', + "-auth=anonymous:$FROM_EMAIL", + ]; + + push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $self->uri; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? $self->uri + # : QUOTE. $self->uri .QUOTE; + + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + ### print to local file ### + ### XXX on a 404 with a special error page, $captured will actually + ### hold the contents of that page, and make it *appear* like the + ### request was a success, when really it wasn't :( + ### there doesn't seem to be an option for lynx to change the exit + ### code based on a 4XX status or so. + ### the closest we can come is using --error_file and parsing that, + ### which is very unreliable ;( + $local->print( $captured ); + $local->close or return; + + return $to; + + } else { + $METHOD_FAIL->{'lynx'} = 1; + return; + } +} + +### use /bin/ncftp to fetch files +sub _ncftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### we can only set passive mode in interactive sesssions, so bail out + ### if $FTP_PASSIVE is set + return if $FTP_PASSIVE; + + ### see if we have a ncftp binary ### + if( my $ncftp = can_run('ncftp') ) { + + my $cmd = [ + $ncftp, + '-V', # do not be verbose + '-p', $FROM_EMAIL, # email as password + $self->host, # hostname + dirname($to), # local dir for the file + # remote path to the file + ### DO NOT quote things for IPC::Run, it breaks stuff. + $IPC::Cmd::USE_IPC_RUN + ? File::Spec::Unix->catdir( $self->path, $self->file ) + : QUOTE. File::Spec::Unix->catdir( + $self->path, $self->file ) .QUOTE + + ]; + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + return $to; + + } else { + $METHOD_FAIL->{'ncftp'} = 1; + return; + } +} + +### use /bin/curl to fetch files +sub _curl_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + if (my $curl = can_run('curl')) { + + ### these long opts are self explanatory - I like that -jmb + my $cmd = [ $curl, '-q' ]; + + push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; + + push(@$cmd, '--silent') unless $DEBUG; + + ### curl does the right thing with passive, regardless ### + if ($self->scheme eq 'ftp') { + push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); + } + + ### curl doesn't follow 302 (temporarily moved) etc automatically + ### so we add --location to enable that. + push @$cmd, '--fail', '--location', '--output', $to, $self->uri; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? ($to, $self->uri) + # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + return $to; + + } else { + $METHOD_FAIL->{'curl'} = 1; + return; + } +} + + +### use File::Copy for fetching file:// urls ### +### +### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html) +### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://) +### + +sub _file_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + + + ### prefix a / on unix systems with a file uri, since it would + ### look somewhat like this: + ### file:///home/kane/file + ### wheras windows file uris for 'c:\some\dir\file' might look like: + ### file:///C:/some/dir/file + ### file:///C|/some/dir/file + ### or for a network share '\\host\share\some\dir\file': + ### file:////host/share/some/dir/file + ### + ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like: + ### file://vms.host.edu/disk$user/my/notes/note12345.txt + ### + + my $path = $self->path; + my $vol = $self->vol; + my $share = $self->share; + + my $remote; + if (!$share and $self->host) { + return $self->_error(loc( + "Currently %1 cannot handle hosts in %2 urls", + 'File::Fetch', 'file://' + )); + } + + if( $vol ) { + $path = File::Spec->catdir( split /\//, $path ); + $remote = File::Spec->catpath( $vol, $path, $self->file); + + } elsif( $share ) { + ### win32 specific, and a share name, so we wont bother with File::Spec + $path =~ s|/+|\\|g; + $remote = "\\\\".$self->host."\\$share\\$path"; + + } else { + ### File::Spec on VMS can not currently handle UNIX syntax. + my $file_class = ON_VMS + ? 'File::Spec::Unix' + : 'File::Spec'; + + $remote = $file_class->catfile( $path, $self->file ); + } + + ### File::Copy is littered with 'die' statements :( ### + my $rv = eval { File::Copy::copy( $remote, $to ) }; + + ### something went wrong ### + if( !$rv or $@ ) { + return $self->_error(loc("Could not copy '%1' to '%2': %3 %4", + $remote, $to, $!, $@)); + } + + return $to; +} + +### use /usr/bin/rsync to fetch files +sub _rsync_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + if (my $rsync = can_run('rsync')) { + + my $cmd = [ $rsync ]; + + ### XXX: rsync has no I/O timeouts at all, by default + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + + push(@$cmd, '--quiet') unless $DEBUG; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $self->uri, $to; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? ($to, $self->uri) + # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); + } + + return $to; + + } else { + $METHOD_FAIL->{'rsync'} = 1; + return; + } +} + +################################# +# +# Error code +# +################################# + +=pod + +=head2 $ff->error([BOOL]) + +Returns the last encountered error as string. +Pass it a true value to get the C<Carp::longmess()> output instead. + +=cut + +### error handling the way Archive::Extract does it +sub _error { + my $self = shift; + my $error = shift; + + $self->_error_msg( $error ); + $self->_error_msg_long( Carp::longmess($error) ); + + if( $WARN ) { + carp $DEBUG ? $self->_error_msg_long : $self->_error_msg; + } + + return; +} + +sub error { + my $self = shift; + return shift() ? $self->_error_msg_long : $self->_error_msg; +} + + +1; + +=pod + +=head1 HOW IT WORKS + +File::Fetch is able to fetch a variety of uris, by using several +external programs and modules. + +Below is a mapping of what utilities will be used in what order +for what schemes, if available: + + file => LWP, lftp, file + http => LWP, wget, curl, lftp, lynx, iosock + ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp + rsync => rsync + +If you'd like to disable the use of one or more of these utilities +and/or modules, see the C<$BLACKLIST> variable further down. + +If a utility or module isn't available, it will be marked in a cache +(see the C<$METHOD_FAIL> variable further down), so it will not be +tried again. The C<fetch> method will only fail when all options are +exhausted, and it was not able to retrieve the file. + +C<iosock> is a very limited L<IO::Socket::INET> based mechanism for +retrieving C<http> schemed urls. It doesn't follow redirects for instance. + +A special note about fetching files from an ftp uri: + +By default, all ftp connections are done in passive mode. To change +that, see the C<$FTP_PASSIVE> variable further down. + +Furthermore, ftp uris only support anonymous connections, so no +named user/password pair can be passed along. + +C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable +further down. + +=head1 GLOBAL VARIABLES + +The behaviour of File::Fetch can be altered by changing the following +global variables: + +=head2 $File::Fetch::FROM_EMAIL + +This is the email address that will be sent as your anonymous ftp +password. + +Default is C<File-Fetch@example.com>. + +=head2 $File::Fetch::USER_AGENT + +This is the useragent as C<LWP> will report it. + +Default is C<File::Fetch/$VERSION>. + +=head2 $File::Fetch::FTP_PASSIVE + +This variable controls whether the environment variable C<FTP_PASSIVE> +and any passive switches to commandline tools will be set to true. + +Default value is 1. + +Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch +files, since passive mode can only be set interactively for this binary + +=head2 $File::Fetch::TIMEOUT + +When set, controls the network timeout (counted in seconds). + +Default value is 0. + +=head2 $File::Fetch::WARN + +This variable controls whether errors encountered internally by +C<File::Fetch> should be C<carp>'d or not. + +Set to false to silence warnings. Inspect the output of the C<error()> +method manually to see what went wrong. + +Defaults to C<true>. + +=head2 $File::Fetch::DEBUG + +This enables debugging output when calling commandline utilities to +fetch files. +This also enables C<Carp::longmess> errors, instead of the regular +C<carp> errors. + +Good for tracking down why things don't work with your particular +setup. + +Default is 0. + +=head2 $File::Fetch::BLACKLIST + +This is an array ref holding blacklisted modules/utilities for fetching +files with. + +To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could +set $File::Fetch::BLACKLIST to: + + $File::Fetch::BLACKLIST = [qw|lwp netftp|] + +The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable. + +See the note on C<MAPPING> below. + +=head2 $File::Fetch::METHOD_FAIL + +This is a hashref registering what modules/utilities were known to fail +for fetching files (mostly because they weren't installed). + +You can reset this cache by assigning an empty hashref to it, or +individually remove keys. + +See the note on C<MAPPING> below. + +=head1 MAPPING + + +Here's a quick mapping for the utilities/modules, and their names for +the $BLACKLIST, $METHOD_FAIL and other internal functions. + + LWP => lwp + Net::FTP => netftp + wget => wget + lynx => lynx + ncftp => ncftp + ftp => ftp + curl => curl + rsync => rsync + lftp => lftp + IO::Socket => iosock + +=head1 FREQUENTLY ASKED QUESTIONS + +=head2 So how do I use a proxy with File::Fetch? + +C<File::Fetch> currently only supports proxies with LWP::UserAgent. +You will need to set your environment variables accordingly. For +example, to use an ftp proxy: + + $ENV{ftp_proxy} = 'foo.com'; + +Refer to the LWP::UserAgent manpage for more details. + +=head2 I used 'lynx' to fetch a file, but its contents is all wrong! + +C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>, +which we in turn capture. If that content is a 'custom' error file +(like, say, a C<404 handler>), you will get that contents instead. + +Sadly, C<lynx> doesn't support any options to return a different exit +code on non-C<200 OK> status, giving us no way to tell the difference +between a 'successfull' fetch and a custom error page. + +Therefor, we recommend to only use C<lynx> as a last resort. This is +why it is at the back of our list of methods to try as well. + +=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do? + +C<File::Fetch> is relatively smart about things. When trying to write +a file to disk, it removes the C<query parameters> (see the +C<output_file> method for details) from the file name before creating +it. In most cases this suffices. + +If you have any other characters you need to escape, please install +the C<URI::Escape> module from CPAN, and pre-encode your URI before +passing it to C<File::Fetch>. You can read about the details of URIs +and URI encoding here: + + http://www.faqs.org/rfcs/rfc2396.html + +=head1 TODO + +=over 4 + +=item Implement $PREFER_BIN + +To indicate to rather use commandline tools than modules + +=back + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + + + + diff --git a/Master/tlpkg/tlperl/lib/File/Find.pm b/Master/tlpkg/tlperl/lib/File/Find.pm new file mode 100755 index 00000000000..eddedbd354a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Find.pm @@ -0,0 +1,1349 @@ +package File::Find; +use 5.006; +use strict; +use warnings; +use warnings::register; +our $VERSION = '1.14'; +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. + +=head1 SYNOPSIS + + use File::Find; + find(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + finddepth(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); + +=head1 DESCRIPTION + +These are functions for searching through directory trees doing work +on each file found similar to the Unix I<find> command. File::Find +exports two functions, C<find> and C<finddepth>. They work similarly +but have subtle differences. + +=over 4 + +=item B<find> + + find(\&wanted, @directories); + find(\%options, @directories); + +C<find()> does a depth-first search over the given C<@directories> in +the order they are given. For each file or directory found, it calls +the C<&wanted> subroutine. (See below for details on how to use the +C<&wanted> function). Additionally, for each directory found, it will +C<chdir()> into that directory and continue the search, invoking the +C<&wanted> function on each file or subdirectory in the directory. + +=item B<finddepth> + + finddepth(\&wanted, @directories); + finddepth(\%options, @directories); + +C<finddepth()> works just like C<find()> except that it invokes the +C<&wanted> function for a directory I<after> invoking it for the +directory's contents. It does a postorder traversal instead of a +preorder traversal, working from the bottom of the directory tree up +where C<find()> works from the top of the tree down. + +=back + +=head2 %options + +The first argument to C<find()> is either a code reference to your +C<&wanted> function, or a hash reference describing the operations +to be performed for each file. The +code reference is described in L<The wanted function> below. + +Here are the possible keys for the hash: + +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is +described in L<The wanted function> below. The C<&wanted> subroutine is +mandatory. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point C<finddepth()> is a shortcut for +specifying C<< { bydepth => 1 } >> in the first argument of C<find()>. + +=item C<preprocess> + +The value should be a code reference. This code reference is used to +preprocess the current directory. The name of the currently processed +directory is in C<$File::Find::dir>. Your preprocessing function is +called after C<readdir()>, but before the loop that calls the C<wanted()> +function. It is called with a list of strings (actually file/directory +names) and is expected to return a list of strings. The code can be +used to sort the file/directory names alphabetically, numerically, +or to filter out directory entries based on their name alone. When +I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. + +=item C<postprocess> + +The value should be a code reference. It is invoked just before leaving +the currently processed directory. It is called in void context with no +arguments. The name of the current directory is in C<$File::Find::dir>. This +hook is handy for summarizing a directory, such as calculating its disk +usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a +no-op. + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See I<follow_fast> and I<follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item * + +It is guaranteed that an I<lstat> has been called before the user's +C<wanted()> function is called. This enables fast file checks involving S<_>. +Note that this guarantee no longer holds if I<follow> or I<follow_fast> +are not set. + +=item * + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved. If the link is +a dangling symbolic link, then fullname will be set to C<undef>. + +=back + +This is a no-op on Win32. + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files more +than once. It does detect cycles, however. Since only symbolic links +have to be hashed, this is much cheaper both in space and time. If +processing a file more than once (by the user's C<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +This is also a no-op on Win32. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. + +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. + +C<follow_skip==2> causes File::Find to ignore any duplicate files and +directories but to proceed normally otherwise. + +=item C<dangling_symlinks> + +If true and a code reference, will be called with the symbolic link +name and the directory it lives in as arguments. Otherwise, if true +and warnings are on, warning "symbolic_link_name is a dangling +symbolic link\n" will be issued. If false, the dangling symbolic link +will be silently ignored. + +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The C<wanted()> +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in taint-mode (-T command line switch or if EUID != UID +or if EGID != GID) then internally directory names have to be untainted +before they can be chdir'ed to. Therefore they are checked against a regular +expression I<untaint_pattern>. Note that all names passed to the user's +I<wanted()> function are still tainted. If this option is used while +not in taint-mode, C<untaint> is a no-op. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the parentheses are vital. + +=item C<untaint_skip> + +If set, a directory which fails the I<untaint_pattern> is skipped, +including all its sub-directories. The default is to 'die' in such a case. + +=back + +=head2 The wanted function + +The C<wanted()> function does whatever verifications you want on +each file and directory. Note that despite its name, the C<wanted()> +function is a generic callback function, and does B<not> tell +File::Find if a file is "wanted" or not. In fact, its return value +is ignored. + +The wanted function takes no arguments but rather does its work +through a collection of variables. + +=over 4 + +=item C<$File::Find::dir> is the current directory name, + +=item C<$_> is the current filename within that directory + +=item C<$File::Find::name> is the complete pathname to the file. + +=back + +The above variables have all been localized and may be changed without +effecting data outside of the wanted function. + +For example, when examining the file F</some/path/foo.ext> you will have: + + $File::Find::dir = /some/path/ + $_ = foo.ext + $File::Find::name = /some/path/foo.ext + +You are chdir()'d to C<$File::Find::dir> when the function is called, +unless C<no_chdir> was specified. Note that when changing to +directories is in effect the root directory (F</>) is a somewhat +special case inasmuch as the concatenation of C<$File::Find::dir>, +C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The +table below summarizes all variants: + + $File::Find::name $File::Find::dir $_ + default / / . + no_chdir=>0 /etc / etc + /etc/x /etc x + + no_chdir=>1 / / / + /etc / /etc + /etc/x /etc /etc/x + + +When C<follow> or C<follow_fast> are in effect, there is +also a C<$File::Find::fullname>. The function may set +C<$File::Find::prune> to prune the tree unless C<bydepth> was +specified. Unless C<follow> or C<follow_fast> is specified, for +compatibility reasons (find.pl, find2perl) there are in addition the +following globals available: C<$File::Find::topdir>, +C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. + +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.*\z/s && + (($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); + } + +Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical +filehandle that caches the information from the preceding +C<stat()>, C<lstat()>, or filetest. + +Here's another interesting wanted function. It will find all symbolic +links that don't resolve: + + sub wanted { + -l && !-e && print "bogus link: $File::Find::name\n"; + } + +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 WARNINGS + +If you run your program with the C<-w> switch, or if you use the +C<warnings> pragma, File::Find will report warnings for several weird +situations. You can disable these warnings by putting the statement + + no warnings 'File::Find'; + +in the appropriate scope. See L<perllexwarn> for more info about lexical +warnings. + +=head1 CAVEAT + +=over 2 + +=item $dont_use_nlink + +You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to +force File::Find to always stat directories. This was used for file systems +that do not have an C<nlink> count matching the number of sub-directories. +Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file +system) and a couple of others. + +You shouldn't need to set this variable, since File::Find should now detect +such file systems on-the-fly and switch itself to using stat. This works even +for parts of your file system, like a mounted CD-ROM. + +If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs. + +=item symlinks + +Be aware that the option to follow symbolic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. + +=back + +=head1 NOTES + +=over 4 + +=item * + +Mac OS (Classic) users should note a few differences: + +=over 4 + +=item * + +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. + +=item * + +C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_> +contains the name of a directory, that name may or may not end with a +':'. Likewise, C<$File::Find::name>, which contains the complete +pathname to that directory, and C<$File::Find::fullname>, which holds +the absolute pathname of that directory with all symbolic links resolved, +may or may not end with a ':'. + +=item * + +The default C<untaint_pattern> (see above) on Mac OS is set to +C<qr|^(.+)$|>. Note that the parentheses are vital. + +=item * + +The invisible system file "Icon\015" is ignored. While this file may +appear in every directory, there are some more invisible system files +on every volume, which are all located at the volume root level (i.e. +"MacintoshHD:"). These system files are B<not> excluded automatically. +Your filter may use the following code to recognize invisible files or +directories (requires Mac::Files): + + use Mac::Files; + + # invisible() -- returns 1 if file/directory is invisible, + # 0 if it's visible or undef if an error occurred + + sub invisible($) { + my $file = shift; + my ($fileCat, $fileInfo); + my $invisible_flag = 1 << 14; + + if ( $fileCat = FSpGetCatInfo($file) ) { + if ($fileInfo = $fileCat->ioFlFndrInfo() ) { + return (($fileInfo->fdFlags & $invisible_flag) && 1); + } + } + return undef; + } + +Generally, invisible files are system files, unless an odd application +decides to use invisible files for its own purposes. To distinguish +such files from system files, you have to look at the B<type> and B<creator> +file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and +C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes +(see MacPerl.pm for details). + +Files that appear on the desktop actually reside in an (hidden) directory +named "Desktop Folder" on the particular disk volume. Note that, although +all desktop files appear to be on the same "virtual" desktop, each disk +volume actually maintains its own "Desktop Folder" directory. + +=back + +=back + +=head1 BUGS AND CAVEATS + +Despite the name of the C<finddepth()> function, both C<find()> and +C<finddepth()> perform a depth-first search of the directory +hierarchy. + +=head1 HISTORY + +File::Find used to produce incorrect results if called recursively. +During the development of perl 5.8 this bug was fixed. +The first fixed version of File::Find was 1.01. + +=head1 SEE ALSO + +find, find2perl. + +=cut + +our @ISA = qw(Exporter); +our @EXPORT = qw(find finddepth); + + +use strict; +my $Is_VMS; +my $Is_MacOS; + +require File::Basename; +require File::Spec; + +# Should ideally be my() not our() but local() currently +# refuses to operate on lexicals + +our %SLnkSeen; +our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process, $dangling_symlinks); + +sub contract_name { + my ($cdir,$fn) = @_; + + return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir; + + $cdir = substr($cdir,0,rindex($cdir,'/')+1); + + $fn =~ s|^\./||; + + my $abs_name= $cdir . $fn; + + if (substr($fn,0,3) eq '../') { + 1 while $abs_name =~ s!/[^/]*/\.\./!/!; + } + + return $abs_name; +} + +# return the absolute name of a directory or file +sub contract_name_Mac { + my ($cdir,$fn) = @_; + my $abs_name; + + if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':' + + my $colon_count = length ($1); + if ($colon_count == 1) { + $abs_name = $cdir . $2; + return $abs_name; + } + else { + # need to move up the tree, but + # only if it's not a volume name + for (my $i=1; $i<$colon_count; $i++) { + unless ($cdir =~ /^[^:]+:$/) { # volume name + $cdir =~ s/[^:]+:$//; + } + else { + return undef; + } + } + $abs_name = $cdir . $2; + return $abs_name; + } + + } + else { + + # $fn may be a valid path to a directory or file or (dangling) + # symlink, without a leading ':' + if ( (-e $fn) || (-l $fn) ) { + if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:* + return $fn; # $fn is already an absolute path + } + else { + $abs_name = $cdir . $fn; + return $abs_name; + } + } + else { # argh!, $fn is not a valid directory/file + return undef; + } + } +} + +sub PathCombine($$) { + my ($Base,$Name) = @_; + my $AbsName; + + if ($Is_MacOS) { + # $Name is the resolved symlink (always a full path on MacOS), + # i.e. there's no need to call contract_name_Mac() + $AbsName = $Name; + + # (simple) check for recursion + if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion + return undef; + } + } + else { + if (substr($Name,0,1) eq '/') { + $AbsName= $Name; + } + else { + $AbsName= contract_name($Base,$Name); + } + + # (simple) check for recursion + my $newlen= length($AbsName); + if ($newlen <= length($Base)) { + if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') + && $AbsName eq substr($Base,0,$newlen)) + { + return undef; + } + } + } + return $AbsName; +} + +sub Follow_SymLink($) { + my ($AbsName) = @_; + + my ($NewName,$DEV, $INO); + ($DEV, $INO)= lstat $AbsName; + + while (-l _) { + if ($SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 2) { + die "$AbsName is encountered a second time"; + } + else { + return undef; + } + } + $NewName= PathCombine($AbsName, readlink($AbsName)); + unless(defined $NewName) { + if ($follow_skip < 2) { + die "$AbsName is a recursive symbolic link"; + } + else { + return undef; + } + } + else { + $AbsName= $NewName; + } + ($DEV, $INO) = lstat($AbsName); + return undef unless defined $DEV; # dangling symbolic link + } + + if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) { + if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) { + die "$AbsName encountered a second time"; + } + else { + return undef; + } + } + + return $AbsName; +} + +our($dir, $name, $fullname, $prune); +sub _find_dir_symlnk($$$); +sub _find_dir($$$); + +# check whether or not a scalar variable is tainted +# (code straight from the Camel, 3rd ed., page 561) +sub is_tainted_pp { + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length + local $@; + eval { eval "# $nada" }; + return length($@) != 0; +} + +sub _find_opt { + my $wanted = shift; + die "invalid top directory" unless defined $_[0]; + + # This function must local()ize everything because callbacks may + # call find() or finddepth() + + local %SLnkSeen; + local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process, $dangling_symlinks); + local($dir, $name, $fullname, $prune); + local *_ = \my $a; + + my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd(); + if ($Is_VMS) { + # VMS returns this by default in VMS format which just doesn't + # work for the rest of this module. + $cwd = VMS::Filespec::unixpath($cwd); + + # Apparently this is not expected to have a trailing space. + # To attempt to make VMS/UNIX conversions mostly reversable, + # a trailing slash is needed. The run-time functions ignore the + # resulting double slash, but it causes the perl tests to fail. + $cwd =~ s#/\z##; + + # This comes up in upper case now, but should be lower. + # In the future this could be exact case, no need to change. + } + my $cwd_untainted = $cwd; + my $check_t_cwd = 1; + $wanted_callback = $wanted->{wanted}; + $bydepth = $wanted->{bydepth}; + $pre_process = $wanted->{preprocess}; + $post_process = $wanted->{postprocess}; + $no_chdir = $wanted->{no_chdir}; + $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow}; + $follow = $^O eq 'MSWin32' ? 0 : + $full_check || $wanted->{follow_fast}; + $follow_skip = $wanted->{follow_skip}; + $untaint = $wanted->{untaint}; + $untaint_pat = $wanted->{untaint_pattern}; + $untaint_skip = $wanted->{untaint_skip}; + $dangling_symlinks = $wanted->{dangling_symlinks}; + + # for compatibility reasons (find.pl, find2perl) + local our ($topdir, $topdev, $topino, $topmode, $topnlink); + + # a symbolic link to a directory doesn't increase the link count + $avoid_nlink = $follow || $File::Find::dont_use_nlink; + + my ($abs_dir, $Is_Dir); + + Proc_Top_Item: + foreach my $TOP (@_) { + my $top_item = $TOP; + + ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; + + if ($Is_MacOS) { + $top_item = ":$top_item" + if ( (-d _) && ( $top_item !~ /:/ ) ); + } elsif ($^O eq 'MSWin32') { + $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|; + } + else { + $top_item =~ s|/\z|| unless $top_item eq '/'; + } + + $Is_Dir= 0; + + if ($follow) { + + if ($Is_MacOS) { + $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety + + if ($top_item eq $File::Find::current_dir) { + $abs_dir = $cwd; + } + else { + $abs_dir = contract_name_Mac($cwd, $top_item); + unless (defined $abs_dir) { + warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n"; + next Proc_Top_Item; + } + } + + } + else { + if (substr($top_item,0,1) eq '/') { + $abs_dir = $top_item; + } + elsif ($top_item eq $File::Find::current_dir) { + $abs_dir = $cwd; + } + else { # care about any ../ + $top_item =~ s/\.dir\z//i if $Is_VMS; + $abs_dir = contract_name("$cwd/",$top_item); + } + } + $abs_dir= Follow_SymLink($abs_dir); + unless (defined $abs_dir) { + if ($dangling_symlinks) { + if (ref $dangling_symlinks eq 'CODE') { + $dangling_symlinks->($top_item, $cwd); + } else { + warnings::warnif "$top_item is a dangling symbolic link\n"; + } + } + next Proc_Top_Item; + } + + if (-d _) { + $top_item =~ s/\.dir\z//i if $Is_VMS; + _find_dir_symlnk($wanted, $abs_dir, $top_item); + $Is_Dir= 1; + } + } + else { # no follow + $topdir = $top_item; + unless (defined $topnlink) { + warnings::warnif "Can't stat $top_item: $!\n"; + next Proc_Top_Item; + } + if (-d _) { + $top_item =~ s/\.dir\z//i if $Is_VMS; + _find_dir($wanted, $top_item, $topnlink); + $Is_Dir= 1; + } + else { + $abs_dir= $top_item; + } + } + + unless ($Is_Dir) { + unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { + if ($Is_MacOS) { + ($dir,$_) = (':', $top_item); # $File::Find::dir, $_ + } + else { + ($dir,$_) = ('./', $top_item); + } + } + + $abs_dir = $dir; + if (( $untaint ) && (is_tainted($dir) )) { + ( $abs_dir ) = $dir =~ m|$untaint_pat|; + unless (defined $abs_dir) { + if ($untaint_skip == 0) { + die "directory $dir is still tainted"; + } + else { + next Proc_Top_Item; + } + } + } + + unless ($no_chdir || chdir $abs_dir) { + warnings::warnif "Couldn't chdir $abs_dir: $!\n"; + next Proc_Top_Item; + } + + $name = $abs_dir . $_; # $File::Find::name + $_ = $name if $no_chdir; + + { $wanted_callback->() }; # protect against wild "next" + + } + + unless ( $no_chdir ) { + if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) { + ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|; + unless (defined $cwd_untainted) { + die "insecure cwd in find(depth)"; + } + $check_t_cwd = 0; + } + unless (chdir $cwd_untainted) { + die "Can't cd to $cwd: $!\n"; + } + } + } +} + +# API: +# $wanted +# $p_dir : "parent directory" +# $nlink : what came back from the stat +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir($$$) { + my ($wanted, $p_dir, $nlink) = @_; + my ($CdLvl,$Level) = (0,0); + my @Stack; + my @filenames; + my ($subcount,$sub_nlink); + my $SE= []; + my $dir_name= $p_dir; + my $dir_pref; + my $dir_rel = $File::Find::current_dir; + my $tainted = 0; + my $no_nlink; + + if ($Is_MacOS) { + $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface + } elsif ($^O eq 'MSWin32') { + $dir_pref = ($p_dir =~ m|\w:/?$| ? $p_dir : "$p_dir/" ); + } elsif ($^O eq 'VMS') { + + # VMS is returning trailing .dir on directories + # and trailing . on files and symbolic links + # in UNIX syntax. + # + + $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.'; + + $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" ); + } + else { + $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); + } + + local ($dir, $name, $prune, *DIR); + + unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) { + my $udir = $p_dir; + if (( $untaint ) && (is_tainted($p_dir) )) { + ( $udir ) = $p_dir =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $p_dir is still tainted"; + } + else { + return; + } + } + } + unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { + warnings::warnif "Can't cd to $udir: $!\n"; + return; + } + } + + # push the starting directory + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + + if ($Is_MacOS) { + $p_dir = $dir_pref; # ensure trailing ':' + } + + while (defined $SE) { + unless ($bydepth) { + $dir= $p_dir; # $File::Find::dir + $name= $dir_name; # $File::Find::name + $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ + # prune may happen here + $prune= 0; + { $wanted_callback->() }; # protect against wild "next" + next if $prune; + } + + # change to that directory + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + my $udir= $dir_rel; + if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) { + ( $udir ) = $dir_rel =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + if ($Is_MacOS) { + die "directory ($p_dir) $dir_rel is still tainted"; + } + else { + die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted"; + } + } else { # $untaint_skip == 1 + next; + } + } + } + unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { + if ($Is_MacOS) { + warnings::warnif "Can't cd to ($p_dir) $udir: $!\n"; + } + else { + warnings::warnif "Can't cd to (" . + ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n"; + } + next; + } + $CdLvl++; + } + + if ($Is_MacOS) { + $dir_name = "$dir_name:" unless ($dir_name =~ /:$/); + } + + $dir= $dir_name; # $File::Find::dir + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) { + warnings::warnif "Can't opendir($dir_name): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + @filenames = $pre_process->(@filenames) if $pre_process; + push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; + + # default: use whatever was specifid + # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back) + $no_nlink = $avoid_nlink; + # if dir has wrong nlink count, force switch to slower stat method + $no_nlink = 1 if ($nlink < 2); + + if ($nlink == 2 && !$no_nlink) { + # This dir has no subdirectories. + for my $FN (@filenames) { + if ($Is_VMS) { + # Big hammer here - Compensate for VMS trailing . and .dir + # No win situation until this is changed, but this + # will handle the majority of the cases with breaking the fewest + + $FN =~ s/\.dir\z//i; + $FN =~ s#\.$## if ($FN ne '.'); + } + next if $FN =~ $File::Find::skip_pattern; + + $name = $dir_pref . $FN; # $File::Find::name + $_ = ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + + } + else { + # This dir has subdirectories. + $subcount = $nlink - 2; + + # HACK: insert directories at this position. so as to preserve + # the user pre-processed ordering of files. + # EG: directory traversal is in user sorted order, not at random. + my $stack_top = @Stack; + + for my $FN (@filenames) { + next if $FN =~ $File::Find::skip_pattern; + if ($subcount > 0 || $no_nlink) { + # Seen all the subdirs? + # check for directoriness. + # stat is faster for a file in the current directory + $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; + + if (-d _) { + --$subcount; + $FN =~ s/\.dir\z//i if $Is_VMS; + # HACK: replace push to preserve dir traversal order + #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; + splice @Stack, $stack_top, 0, + [$CdLvl,$dir_name,$FN,$sub_nlink]; + } + else { + $name = $dir_pref . $FN; # $File::Find::name + $_= ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + else { + $name = $dir_pref . $FN; # $File::Find::name + $_= ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + } + } + continue { + while ( defined ($SE = pop @Stack) ) { + ($Level, $p_dir, $dir_rel, $nlink) = @$SE; + if ($CdLvl > $Level && !$no_chdir) { + my $tmp; + if ($Is_MacOS) { + $tmp = (':' x ($CdLvl-$Level)) . ':'; + } + elsif ($Is_VMS) { + $tmp = '[' . ('-' x ($CdLvl-$Level)) . ']'; + } + else { + $tmp = join('/',('..') x ($CdLvl-$Level)); + } + die "Can't cd to $tmp from $dir_name" + unless chdir ($tmp); + $CdLvl = $Level; + } + + if ($Is_MacOS) { + # $pdir always has a trailing ':', except for the starting dir, + # where $dir_rel eq ':' + $dir_name = "$p_dir$dir_rel"; + $dir_pref = "$dir_name:"; + } + elsif ($^O eq 'MSWin32') { + $dir_name = ($p_dir =~ m|\w:/?$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } + elsif ($^O eq 'VMS') { + if ($p_dir =~ m/[\]>]+$/) { + $dir_name = $p_dir; + $dir_name =~ s/([\]>]+)$/.$dir_rel$1/; + $dir_pref = $dir_name; + } + else { + $dir_name = "$p_dir/$dir_rel"; + $dir_pref = "$dir_name/"; + } + } + else { + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } + + if ( $nlink == -2 ) { + $name = $dir = $p_dir; # $File::Find::name / dir + $_ = $File::Find::current_dir; + $post_process->(); # End-of-directory processing + } + elsif ( $nlink < 0 ) { # must be finddepth, report dirname now + $name = $dir_name; + if ($Is_MacOS) { + if ($dir_rel eq ':') { # must be the top dir, where we started + $name =~ s|:$||; # $File::Find::name + $p_dir = "$p_dir:" unless ($p_dir =~ /:$/); + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $name : $dir_rel); # $_ + } + else { + if ( substr($name,-2) eq '/.' ) { + substr($name, length($name) == 2 ? -1 : -2) = ''; + } + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel ); + if ( substr($_,-2) eq '/.' ) { + substr($_, length($_) == 2 ? -1 : -2) = ''; + } + } + { $wanted_callback->() }; # protect against wild "next" + } + else { + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + last; + } + } + } +} + + +# API: +# $wanted +# $dir_loc : absolute location of a dir +# $p_dir : "parent directory" +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir_symlnk($$$) { + my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory + my @Stack; + my @filenames; + my $new_loc; + my $updir_loc = $dir_loc; # untainted parent directory + my $SE = []; + my $dir_name = $p_dir; + my $dir_pref; + my $loc_pref; + my $dir_rel = $File::Find::current_dir; + my $byd_flag; # flag for pending stack entry if $bydepth + my $tainted = 0; + my $ok = 1; + + if ($Is_MacOS) { + $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:"; + $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:"; + } else { + $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); + $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); + } + + local ($dir, $name, $fullname, $prune, *DIR); + + unless ($no_chdir) { + # untaint the topdir + if (( $untaint ) && (is_tainted($dir_loc) )) { + ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted + # once untainted, $updir_loc is pushed on the stack (as parent directory); + # hence, we don't need to untaint the parent directory every time we chdir + # to it later + unless (defined $updir_loc) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + return; + } + } + } + $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir); + unless ($ok) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + return; + } + } + + push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth; + + if ($Is_MacOS) { + $p_dir = $dir_pref; # ensure trailing ':' + } + + while (defined $SE) { + + unless ($bydepth) { + # change (back) to parent directory (always untainted) + unless ($no_chdir) { + unless (chdir $updir_loc) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + $dir= $p_dir; # $File::Find::dir + $name= $dir_name; # $File::Find::name + $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ + $fullname= $dir_loc; # $File::Find::fullname + # prune may happen here + $prune= 0; + lstat($_); # make sure file tests with '_' work + { $wanted_callback->() }; # protect against wild "next" + next if $prune; + } + + # change to that directory + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + $updir_loc = $dir_loc; + if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) { + # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir + ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; + unless (defined $updir_loc) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + next; + } + } + } + unless (chdir $updir_loc) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + + if ($Is_MacOS) { + $dir_name = "$dir_name:" unless ($dir_name =~ /:$/); + } + + $dir = $dir_name; # $File::Find::dir + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) { + warnings::warnif "Can't opendir($dir_loc): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + for my $FN (@filenames) { + if ($Is_VMS) { + # Big hammer here - Compensate for VMS trailing . and .dir + # No win situation until this is changed, but this + # will handle the majority of the cases with breaking the fewest. + + $FN =~ s/\.dir\z//i; + $FN =~ s#\.$## if ($FN ne '.'); + } + next if $FN =~ $File::Find::skip_pattern; + + # follow symbolic links / do an lstat + $new_loc = Follow_SymLink($loc_pref.$FN); + + # ignore if invalid symlink + unless (defined $new_loc) { + if (!defined -l _ && $dangling_symlinks) { + if (ref $dangling_symlinks eq 'CODE') { + $dangling_symlinks->($FN, $dir_pref); + } else { + warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; + } + } + + $fullname = undef; + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + { $wanted_callback->() }; + next; + } + + if (-d _) { + if ($Is_VMS) { + $FN =~ s/\.dir\z//i; + $FN =~ s#\.$## if ($FN ne '.'); + $new_loc =~ s/\.dir\z//i; + $new_loc =~ s#\.$## if ($new_loc ne '.'); + } + push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1]; + } + else { + $fullname = $new_loc; # $File::Find::fullname + $name = $dir_pref . $FN; # $File::Find::name + $_ = ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + + } + continue { + while (defined($SE = pop @Stack)) { + ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE; + if ($Is_MacOS) { + # $p_dir always has a trailing ':', except for the starting dir, + # where $dir_rel eq ':' + $dir_name = "$p_dir$dir_rel"; + $dir_pref = "$dir_name:"; + $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:"; + } + else { + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + $loc_pref = "$dir_loc/"; + } + if ( $byd_flag < 0 ) { # must be finddepth, report dirname now + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + $fullname = $dir_loc; # $File::Find::fullname + $name = $dir_name; # $File::Find::name + if ($Is_MacOS) { + if ($dir_rel eq ':') { # must be the top dir, where we started + $name =~ s|:$||; # $File::Find::name + $p_dir = "$p_dir:" unless ($p_dir =~ /:$/); + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $name : $dir_rel); # $_ + } + else { + if ( substr($name,-2) eq '/.' ) { + substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $dir_name : $dir_rel); # $_ + if ( substr($_,-2) eq '/.' ) { + substr($_, length($_) == 2 ? -1 : -2) = ''; + } + } + + lstat($_); # make sure file tests with '_' work + { $wanted_callback->() }; # protect against wild "next" + } + else { + push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth; + last; + } + } + } +} + + +sub wrap_wanted { + my $wanted = shift; + if ( ref($wanted) eq 'HASH' ) { + unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) { + die 'no &wanted subroutine given'; + } + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = $File::Find::untaint_pattern + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; + } + elsif( ref( $wanted ) eq 'CODE' ) { + return { wanted => $wanted }; + } + else { + die 'no &wanted subroutine given'; + } +} + +sub find { + my $wanted = shift; + _find_opt(wrap_wanted($wanted), @_); +} + +sub finddepth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + _find_opt($wanted, @_); +} + +# default +$File::Find::skip_pattern = qr/^\.{1,2}\z/; +$File::Find::untaint_pattern = qr|^([-+@\w./]+)$|; + +# These are hard-coded for now, but may move to hint files. +if ($^O eq 'VMS') { + $Is_VMS = 1; + $File::Find::dont_use_nlink = 1; +} +elsif ($^O eq 'MacOS') { + $Is_MacOS = 1; + $File::Find::dont_use_nlink = 1; + $File::Find::skip_pattern = qr/^Icon\015\z/; + $File::Find::untaint_pattern = qr|^(.+)$|; +} + +# this _should_ work properly on all platforms +# where File::Find can be expected to work +$File::Find::current_dir = File::Spec->curdir || '.'; + +$File::Find::dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' || + $^O eq 'nto'; + +# 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; diff --git a/Master/tlpkg/tlperl/lib/File/Find/Rule.pm b/Master/tlpkg/tlperl/lib/File/Find/Rule.pm new file mode 100755 index 00000000000..8f6e254f704 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Find/Rule.pm @@ -0,0 +1,797 @@ +# $Id$ + +package File::Find::Rule; +use strict; +use File::Spec; +use Text::Glob 'glob_to_regex'; +use Number::Compare; +use Carp qw/croak/; +use File::Find (); # we're only wrapping for now + +our $VERSION = '0.32'; + +# we'd just inherit from Exporter, but I want the colon +sub import { + my $pkg = shift; + my $to = caller; + for my $sym ( qw( find rule ) ) { + no strict 'refs'; + *{"$to\::$sym"} = \&{$sym}; + } + for (grep /^:/, @_) { + my ($extension) = /^:(.*)/; + eval "require File::Find::Rule::$extension"; + croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@; + } +} + +=head1 NAME + +File::Find::Rule - Alternative interface to File::Find + +=head1 SYNOPSIS + + use File::Find::Rule; + # find all the subdirectories of a given directory + my @subdirs = File::Find::Rule->directory->in( $directory ); + + # find all the .pm files in @INC + my @files = File::Find::Rule->file() + ->name( '*.pm' ) + ->in( @INC ); + + # as above, but without method chaining + my $rule = File::Find::Rule->new; + $rule->file; + $rule->name( '*.pm' ); + my @files = $rule->in( @INC ); + +=head1 DESCRIPTION + +File::Find::Rule is a friendlier interface to File::Find. It allows +you to build rules which specify the desired files and directories. + +=cut + +# the procedural shim + +*rule = \&find; +sub find { + my $object = __PACKAGE__->new(); + my $not = 0; + + while (@_) { + my $method = shift; + my @args; + + if ($method =~ s/^\!//) { + # jinkies, we're really negating this + unshift @_, $method; + $not = 1; + next; + } + unless (defined prototype $method) { + my $args = shift; + @args = ref $args eq 'ARRAY' ? @$args : $args; + } + if ($not) { + $not = 0; + @args = $object->new->$method(@args); + $method = "not"; + } + + my @return = $object->$method(@args); + return @return if $method eq 'in'; + } + $object; +} + + +=head1 METHODS + +=over + +=item C<new> + +A constructor. You need not invoke C<new> manually unless you wish +to, as each of the rule-making methods will auto-create a suitable +object if called as class methods. + +=cut + +sub new { + my $referent = shift; + my $class = ref $referent || $referent; + bless { + rules => [], + subs => {}, + iterator => [], + extras => {}, + maxdepth => undef, + mindepth => undef, + }, $class; +} + +sub _force_object { + my $object = shift; + $object = $object->new() + unless ref $object; + $object; +} + +=back + +=head2 Matching Rules + +=over + +=item C<name( @patterns )> + +Specifies names that should match. May be globs or regular +expressions. + + $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs + $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex + $set->name( 'foo.bar' ); # just things named foo.bar + +=cut + +sub _flatten { + my @flat; + while (@_) { + my $item = shift; + ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; + } + return @flat; +} + +sub name { + my $self = _force_object shift; + my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); + + push @{ $self->{rules} }, { + rule => 'name', + code => join( ' || ', map { "m($_)" } @names ), + args => \@_, + }; + + $self; +} + +=item -X tests + +Synonyms are provided for each of the -X tests. See L<perlfunc/-X> for +details. None of these methods take arguments. + + Test | Method Test | Method + ------|------------- ------|---------------- + -r | readable -R | r_readable + -w | writeable -W | r_writeable + -w | writable -W | r_writable + -x | executable -X | r_executable + -o | owned -O | r_owned + | | + -e | exists -f | file + -z | empty -d | directory + -s | nonempty -l | symlink + | -p | fifo + -u | setuid -S | socket + -g | setgid -b | block + -k | sticky -c | character + | -t | tty + -M | modified | + -A | accessed -T | ascii + -C | changed -B | binary + +Though some tests are fairly meaningless as binary flags (C<modified>, +C<accessed>, C<changed>), they have been included for completeness. + + # find nonempty files + $rule->file, + ->nonempty; + +=cut + +use vars qw( %X_tests ); +%X_tests = ( + -r => readable => -R => r_readable => + -w => writeable => -W => r_writeable => + -w => writable => -W => r_writable => + -x => executable => -X => r_executable => + -o => owned => -O => r_owned => + + -e => exists => -f => file => + -z => empty => -d => directory => + -s => nonempty => -l => symlink => + => -p => fifo => + -u => setuid => -S => socket => + -g => setgid => -b => block => + -k => sticky => -c => character => + => -t => tty => + -M => modified => + -A => accessed => -T => ascii => + -C => changed => -B => binary => + ); + +for my $test (keys %X_tests) { + my $sub = eval 'sub () { + my $self = _force_object shift; + push @{ $self->{rules} }, { + code => "' . $test . ' \$_", + rule => "'.$X_tests{$test}.'", + }; + $self; + } '; + no strict 'refs'; + *{ $X_tests{$test} } = $sub; +} + + +=item stat tests + +The following C<stat> based methods are provided: C<dev>, C<ino>, +C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>, +C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat> +for details. + +Each of these can take a number of targets, which will follow +L<Number::Compare> semantics. + + $rule->size( 7 ); # exactly 7 + $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes + $rule->size( ">=7" ) + ->size( "<=90" ); # between 7 and 90, inclusive + $rule->size( 7, 9, 42 ); # 7, 9 or 42 + +=cut + +use vars qw( @stat_tests ); +@stat_tests = qw( dev ino mode nlink uid gid rdev + size atime mtime ctime blksize blocks ); +{ + my $i = 0; + for my $test (@stat_tests) { + my $index = $i++; # to close over + my $sub = sub { + my $self = _force_object shift; + + my @tests = map { Number::Compare->parse_to_perl($_) } @_; + + push @{ $self->{rules} }, { + rule => $test, + args => \@_, + code => 'do { my $val = (stat $_)['.$index.'] || 0;'. + join ('||', map { "(\$val $_)" } @tests ).' }', + }; + $self; + }; + no strict 'refs'; + *$test = $sub; + } +} + +=item C<any( @rules )> + +=item C<or( @rules )> + +Allows shortcircuiting boolean evaluation as an alternative to the +default and-like nature of combined rules. C<any> and C<or> are +interchangeable. + + # find avis, movs, things over 200M and empty files + $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ), + File::Find::Rule->size( '>200M' ), + File::Find::Rule->file->empty, + ); + +=cut + +sub any { + my $self = _force_object shift; + # compile all the subrules to code fragments + push @{ $self->{rules} }, { + rule => "any", + code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')', + args => \@_, + }; + + # merge all the subs hashes of the kids into ourself + %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; + $self; +} + +*or = \&any; + +=item C<none( @rules )> + +=item C<not( @rules )> + +Negates a rule. (The inverse of C<any>.) C<none> and C<not> are +interchangeable. + + # files that aren't 8.3 safe + $rule->file + ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); + +=cut + +sub not { + my $self = _force_object shift; + + push @{ $self->{rules} }, { + rule => 'not', + args => \@_, + code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")", + }; + + # merge all the subs hashes into us + %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; + $self; +} + +*none = \¬ + +=item C<prune> + +Traverse no further. This rule always matches. + +=cut + +sub prune () { + my $self = _force_object shift; + + push @{ $self->{rules} }, + { + rule => 'prune', + code => '$File::Find::prune = 1' + }; + $self; +} + +=item C<discard> + +Don't keep this file. This rule always matches. + +=cut + +sub discard () { + my $self = _force_object shift; + + push @{ $self->{rules} }, { + rule => 'discard', + code => '$discarded = 1', + }; + $self; +} + +=item C<exec( \&subroutine( $shortname, $path, $fullname ) )> + +Allows user-defined rules. Your subroutine will be invoked with C<$_> +set to the current short name, and with parameters of the name, the +path you're in, and the full relative filename. + +Return a true value if your rule matched. + + # get things with long names + $rules->exec( sub { length > 20 } ); + +=cut + +sub exec { + my $self = _force_object shift; + my $code = shift; + + push @{ $self->{rules} }, { + rule => 'exec', + code => $code, + }; + $self; +} + +=item C<grep( @specifiers )> + +Opens a file and tests it each line at a time. + +For each line it evaluates each of the specifiers, stopping at the +first successful match. A specifier may be a regular expression or a +subroutine. The subroutine will be invoked with the same parameters +as an ->exec subroutine. + +It is possible to provide a set of negative specifiers by enclosing +them in anonymous arrays. Should a negative specifier match the +iteration is aborted and the clause is failed. For example: + + $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); + +Is a passing clause if the first line of a file looks like a perl +shebang line. + +=cut + +sub grep { + my $self = _force_object shift; + my @pattern = map { + ref $_ + ? ref $_ eq 'ARRAY' + ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ + : [ $_ => 1 ] + : [ qr/$_/ => 1 ] + } @_; + + $self->exec( sub { + local *FILE; + open FILE, $_ or return; + local ($_, $.); + while (<FILE>) { + for my $p (@pattern) { + my ($rule, $ret) = @$p; + return $ret + if ref $rule eq 'Regexp' + ? /$rule/ + : $rule->(@_); + } + } + return; + } ); +} + +=item C<maxdepth( $level )> + +Descend at most C<$level> (a non-negative integer) levels of directories +below the starting point. + +May be invoked many times per rule, but only the most recent value is +used. + +=item C<mindepth( $level )> + +Do not apply any tests at levels less than C<$level> (a non-negative +integer). + +=item C<extras( \%extras )> + +Specifies extra values to pass through to C<File::File::find> as part +of the options hash. + +For example this allows you to specify following of symlinks like so: + + my $rule = File::Find::Rule->extras({ follow => 1 }); + +May be invoked many times per rule, but only the most recent value is +used. + +=cut + +for my $setter (qw( maxdepth mindepth extras )) { + my $sub = sub { + my $self = _force_object shift; + $self->{$setter} = shift; + $self; + }; + no strict 'refs'; + *$setter = $sub; +} + + +=item C<relative> + +Trim the leading portion of any path found + +=cut + +sub relative () { + my $self = _force_object shift; + $self->{relative} = 1; + $self; +} + +=item C<not_*> + +Negated version of the rule. An effective shortand related to ! in +the procedural interface. + + $foo->not_name('*.pl'); + + $foo->not( $foo->new->name('*.pl' ) ); + +=cut + +sub DESTROY {} +sub AUTOLOAD { + our $AUTOLOAD; + $AUTOLOAD =~ /::not_([^:]*)$/ + or croak "Can't locate method $AUTOLOAD"; + my $method = $1; + + my $sub = sub { + my $self = _force_object shift; + $self->not( $self->new->$method(@_) ); + }; + { + no strict 'refs'; + *$AUTOLOAD = $sub; + } + &$sub; +} + +=back + +=head2 Query Methods + +=over + +=item C<in( @directories )> + +Evaluates the rule, returns a list of paths to matching files and +directories. + +=cut + +sub in { + my $self = _force_object shift; + + my @found; + my $fragment = $self->_compile; + my %subs = %{ $self->{subs} }; + + warn "relative mode handed multiple paths - that's a bit silly\n" + if $self->{relative} && @_ > 1; + + my $topdir; + my $code = 'sub { + (my $path = $File::Find::name) =~ s#^(?:\./+)+##; + my @args = ($_, $File::Find::dir, $path); + my $maxdepth = $self->{maxdepth}; + my $mindepth = $self->{mindepth}; + my $relative = $self->{relative}; + + # figure out the relative path and depth + my $relpath = $File::Find::name; + $relpath =~ s{^\Q$topdir\E/?}{}; + my $depth = scalar File::Spec->splitdir($relpath); + #print "name: \'$File::Find::name\' "; + #print "relpath: \'$relpath\' depth: $depth relative: $relative\n"; + + defined $maxdepth && $depth >= $maxdepth + and $File::Find::prune = 1; + + defined $mindepth && $depth < $mindepth + and return; + + #print "Testing \'$_\'\n"; + + my $discarded; + return unless ' . $fragment . '; + return if $discarded; + if ($relative) { + push @found, $relpath if $relpath ne ""; + } + else { + push @found, $path; + } + }'; + + #use Data::Dumper; + #print Dumper \%subs; + #warn "Compiled sub: '$code'\n"; + + my $sub = eval "$code" or die "compile error '$code' $@"; + for my $path (@_) { + # $topdir is used for relative and maxdepth + $topdir = $path; + # slice off the trailing slash if there is one (the + # maxdepth/mindepth code is fussy) + $topdir =~ s{/?$}{} + unless $topdir eq '/'; + $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path ); + } + + return @found; +} + +sub _call_find { + my $self = shift; + File::Find::find( @_ ); +} + +sub _compile { + my $self = shift; + + return '1' unless @{ $self->{rules} }; + my $code = join " && ", map { + if (ref $_->{code}) { + my $key = "$_->{code}"; + $self->{subs}{$key} = $_->{code}; + "\$subs{'$key'}->(\@args) # $_->{rule}\n"; + } + else { + "( $_->{code} ) # $_->{rule}\n"; + } + } @{ $self->{rules} }; + + #warn $code; + return $code; +} + +=item C<start( @directories )> + +Starts a find across the specified directories. Matching items may +then be queried using L</match>. This allows you to use a rule as an +iterator. + + my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" ); + while ( defined ( my $image = $rule->match ) ) { + ... + } + +=cut + +sub start { + my $self = _force_object shift; + + $self->{iterator} = [ $self->in( @_ ) ]; + $self; +} + +=item C<match> + +Returns the next file which matches, false if there are no more. + +=cut + +sub match { + my $self = _force_object shift; + + return shift @{ $self->{iterator} }; +} + +1; + +__END__ + +=back + +=head2 Extensions + +Extension modules are available from CPAN in the File::Find::Rule +namespace. In order to use these extensions either use them directly: + + use File::Find::Rule::ImageSize; + use File::Find::Rule::MMagic; + + # now your rules can use the clauses supplied by the ImageSize and + # MMagic extension + +or, specify that File::Find::Rule should load them for you: + + use File::Find::Rule qw( :ImageSize :MMagic ); + +For notes on implementing your own extensions, consult +L<File::Find::Rule::Extending> + +=head2 Further examples + +=over + +=item Finding perl scripts + + my $finder = File::Find::Rule->or + ( + File::Find::Rule->name( '*.pl' ), + File::Find::Rule->exec( + sub { + if (open my $fh, $_) { + my $shebang = <$fh>; + close $fh; + return $shebang =~ /^#!.*\bperl/; + } + return 0; + } ), + ); + +Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 + +=item ignore CVS directories + + my $rule = File::Find::Rule->new; + $rule->or($rule->new + ->directory + ->name('CVS') + ->prune + ->discard, + $rule->new); + +Note here the use of a null rule. Null rules match anything they see, +so the effect is to match (and discard) directories called 'CVS' or to +match anything. + +=back + +=head1 TWO FOR THE PRICE OF ONE + +File::Find::Rule also gives you a procedural interface. This is +documented in L<File::Find::Rule::Procedural> + +=head1 EXPORTS + +L</find>, L</rule> + +=head1 TAINT MODE INTERACTION + +As of 0.32 File::Find::Rule doesn't capture the current working directory in +a taint-unsafe manner. File::Find itself still does operations that the taint +system will flag as insecure but you can use the L</extras> feature to ask +L<File::Find> to internally C<untaint> file paths with a regex like so: + + my $rule = File::Find::Rule->extras({ untaint => 1 }); + +Please consult L<File::Find>'s documentation for C<untaint>, +C<untaint_pattern>, and C<untaint_skip> for more information. + +=head1 BUGS + +The code makes use of the C<our> keyword and as such requires perl version +5.6.0 or newer. + +Currently it isn't possible to remove a clause from a rule object. If +this becomes a significant issue it will be addressed. + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> with input gained from this +use.perl discussion: http://use.perl.org/~richardc/journal/6467 + +Additional proofreading and input provided by Kake, Greg McCarroll, +and Andy Lester andy@petdance.com. + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2004, 2006, 2009 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find>, L<Text::Glob>, L<Number::Compare>, find(1) + +If you want to know about the procedural interface, see +L<File::Find::Rule::Procedural>, and if you have an idea for a neat +extension L<File::Find::Rule::Extending> + +=cut + +Implementation notes: + +$self->rules is an array of hashrefs. it may be a code fragment or a call +to a subroutine. + +Anonymous subroutines are stored in the $self->subs hashref keyed on the +stringfied version of the coderef. + +When one File::Find::Rule object is combined with another, such as in the any +and not operations, this entire hash is merged. + +The _compile method walks the rules element and simply glues the code +fragments together so they can be compiled into an anyonymous File::Find +match sub for speed + + +[*] There's probably a win to be made with the current model in making +stat calls use C<_>. For + + find( file => size => "> 20M" => size => "< 400M" ); + +up to 3 stats will happen for each candidate. Adding a priming _ +would be a bit blind if the first operation was C< name => 'foo' >, +since that can be tested by a single regex. Simply checking what the +next type of operation doesn't work since any arbritary exec sub may +or may not stat. Potentially worse, they could stat something else +like so: + + # extract from the worlds stupidest make(1) + find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } ); + +Maybe the best way is to treat C<_> as invalid after calling an exec, +and doc that C<_> will only be meaningful after stat and -X tests if +they're wanted in exec blocks. diff --git a/Master/tlpkg/tlperl/lib/File/Find/Rule/Extending.pod b/Master/tlpkg/tlperl/lib/File/Find/Rule/Extending.pod new file mode 100755 index 00000000000..71378593b0d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Find/Rule/Extending.pod @@ -0,0 +1,91 @@ +=head1 NAME + +File::Find::Rule::Extending - the mini-guide to extending File::Find::Rule + +=head1 SYNOPSIS + + package File::Find::Rule::Random; + use strict; + + # take useful things from File::Find::Rule + use base 'File::Find::Rule'; + + # and force our crack into the main namespace + sub File::Find::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + 1; + +=head1 DESCRIPTION + +File::Find::Rule went down so well with the buying public that +everyone wanted to add extra features. With the 0.07 release this +became a possibility, using the following conventions. + +=head2 Declare your package + + package File::Find::Rule::Random; + use strict; + +=head2 Inherit methods from File::Find::Rule + + # take useful things from File::Find::Rule + use base 'File::Find::Rule'; + +=head3 Force your madness into the main package + + # and force our crack into the main namespace + sub File::Find::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + +Yes, we're being very cavalier here and defining things into the main +File::Find::Rule namespace. This is due to lack of imaginiation on my +part - I simply can't find a way for the functional and oo interface +to work without doing this or some kind of inheritance, and +inheritance stops you using two File::Find::Rule::Foo modules +together. + +For this reason try and pick distinct names for your extensions. If +this becomes a problem then I may institute a semi-official registry +of taken names. + +=head2 Taking no arguments. + +Note the null prototype on random. This is a cheat for the procedural +interface to know that your sub takes no arguments, and so allows this +to happen: + + find( random => in => '.' ); + +If you hadn't declared C<random> with a null prototype it would have +consumed C<in> as a parameter to it, then got all confused as it +doesn't know about a C<'.'> rule. + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find::Rule> + +L<File::Find::Rule::MMagic> was the first extension module, so maybe +check that out. + +=cut + + + + diff --git a/Master/tlpkg/tlperl/lib/File/Find/Rule/Procedural.pod b/Master/tlpkg/tlperl/lib/File/Find/Rule/Procedural.pod new file mode 100755 index 00000000000..09eeadd01b2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Find/Rule/Procedural.pod @@ -0,0 +1,72 @@ +=head1 NAME + +File::Find::Rule::Procedural - File::Find::Rule's procedural interface + +=head1 SYNOPSIS + + use File::Find::Rule; + + # find all .pm files, procedurally + my @files = find(file => name => '*.pm', in => \@INC); + +=head1 DESCRIPTION + +In addition to the regular object-oriented interface, +L<File::Find::Rule> provides two subroutines for you to use. + +=over + +=item C<find( @clauses )> + +=item C<rule( @clauses )> + +C<find> and C<rule> can be used to invoke any methods available to the +OO version. C<rule> is a synonym for C<find> + +=back + +Passing more than one value to a clause is done with an anonymous +array: + + my $finder = find( name => [ '*.mp3', '*.ogg' ] ); + +C<find> and C<rule> both return a File::Find::Rule instance, unless +one of the arguments is C<in>, in which case it returns a list of +things that match the rule. + + my @files = find( name => [ '*.mp3', '*.ogg' ], in => $ENV{HOME} ); + +Please note that C<in> will be the last clause evaluated, and so this +code will search for mp3s regardless of size. + + my @files = find( name => '*.mp3', in => $ENV{HOME}, size => '<2k' ); + ^ + | + Clause processing stopped here ------/ + +It is also possible to invert a single rule by prefixing it with C<!> +like so: + + # large files that aren't videos + my @files = find( file => + '!name' => [ '*.avi', '*.mov' ], + size => '>20M', + in => $ENV{HOME} ); + + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> + +=head1 COPYRIGHT + +Copyright (C) 2003 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Find::Rule> + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/Glob.pm b/Master/tlpkg/tlperl/lib/File/Glob.pm new file mode 100755 index 00000000000..15d4adb6bbe --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Glob.pm @@ -0,0 +1,496 @@ +package File::Glob; + +use strict; +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, + $AUTOLOAD, $DEFAULT_FLAGS); + +use XSLoader (); + +@ISA = qw(Exporter); + +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + +@EXPORT_OK = qw( + csh_glob + bsd_glob + glob + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE +); + +%EXPORT_TAGS = ( + 'glob' => [ qw( + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE + glob + bsd_glob + ) ], +); + +$VERSION = '1.06'; + +sub import { + require Exporter; + my $i = 1; + while ($i < @_) { + if ($_[$i] =~ /^:(case|nocase|globally)$/) { + splice(@_, $i, 1); + $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; + $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; + if ($1 eq 'globally') { + local $^W; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; + } + next; + } + ++$i; + } + goto &Exporter::import; +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my ($error, $val) = constant($constname); + if ($error) { + require Carp; + Carp::croak($error); + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +XSLoader::load 'File::Glob', $VERSION; + +# Preloaded methods go here. + +sub GLOB_ERROR { + return (constant('GLOB_ERROR'))[1]; +} + +sub GLOB_CSH () { + GLOB_BRACE() + | GLOB_NOMAGIC() + | GLOB_QUOTE() + | GLOB_TILDE() + | GLOB_ALPHASORT() +} + +$DEFAULT_FLAGS = GLOB_CSH(); +if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { + $DEFAULT_FLAGS |= GLOB_NOCASE(); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +sub bsd_glob { + my ($pat,$flags) = @_; + $flags = $DEFAULT_FLAGS if @_ < 2; + return doglob($pat,$flags); +} + +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + splice @_, 1; # don't pass PL_glob_index as flags! + goto &bsd_glob; +} + +## borrowed heavily from gsar's File::DosGlob +my %iter; +my %entries; + +sub csh_glob { + my $pat = shift; + my $cxix = shift; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + $pat =~ s/^\s+//; # Protect against empty elements in + $pat =~ s/\s+$//; # things like < *.c> and <*.c >. + # These alone shouldn't trigger ParseWords. + if ($pat =~ /\s/) { + # XXX this is needed for compatibility with the csh + # implementation in Perl. Need to support a flag + # to disable this behavior. + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$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) { + if (@pat) { + $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; + } + else { + $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; + } + } + + # 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; + } + } +} + +1; +__END__ + +=head1 NAME + +File::Glob - Perl extension for BSD glob routine + +=head1 SYNOPSIS + + use File::Glob ':glob'; + + @list = bsd_glob('*.[ch]'); + $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); + + if (GLOB_ERROR) { + # an error occurred reading $homedir + } + + ## override the core glob (CORE::glob() does this automatically + ## by default anyway, since v5.6.0) + use File::Glob ':globally'; + my @sources = <*.{c,h,y}>; + + ## override the core glob, forcing case sensitivity + use File::Glob qw(:globally :case); + my @sources = <*.{c,h,y}>; + + ## override the core glob forcing case insensitivity + use File::Glob qw(:globally :nocase); + my @sources = <*.{c,h,y}>; + + ## glob on all files in home directory + use File::Glob ':globally'; + my @sources = <~gnat/*>; + +=head1 DESCRIPTION + +The glob angle-bracket operator C<< <> >> is a pathname generator that +implements the rules for file name pattern matching used by Unix-like shells +such as the Bourne shell or C shell. + +File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is +a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). +bsd_glob() takes a mandatory C<pattern> argument, and an optional +C<flags> argument, and returns a list of filenames matching the +pattern, with interpretation of the pattern modified by the C<flags> +variable. + +Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). +Note that they don't share the same prototype--CORE::glob() only accepts +a single argument. Due to historical reasons, CORE::glob() will also +split its argument on whitespace, treating it as multiple patterns, +whereas bsd_glob() considers them as one pattern. + +=head2 META CHARACTERS + + \ Quote the next metacharacter + [] Character class + {} Multiple pattern + * Match any string of characters + ? Match any single character + ~ User name home directory + +The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to +right order is preserved, with results of matches being sorted separately +at a low level to preserve this order. As a special case C<{>, C<}>, and +C<{}> are passed undisturbed. + +=head2 POSIX FLAGS + +The POSIX defined flags for bsd_glob() are: + +=over 4 + +=item C<GLOB_ERR> + +Force bsd_glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily bsd_glob() continues to find matches. + +=item C<GLOB_LIMIT> + +Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands +to a size bigger than the system constant C<ARG_MAX> (usually found in +limits.h). If your system does not define this constant, bsd_glob() uses +C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that +order). You can inspect these values using the standard C<POSIX> +extension. + +=item C<GLOB_MARK> + +Each pathname that is a directory that matches the pattern has a slash +appended. + +=item C<GLOB_NOCASE> + +By default, file names are assumed to be case sensitive; this flag +makes bsd_glob() treat case differences as not significant. + +=item C<GLOB_NOCHECK> + +If the pattern does not match any pathname, then bsd_glob() returns a list +consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect +is present in the pattern returned. + +=item C<GLOB_NOSORT> + +By default, the pathnames are sorted in ascending ASCII order; this +flag prevents that sorting (speeding up bsd_glob()). + +=back + +The FreeBSD extensions to the POSIX standard are the following flags: + +=over 4 + +=item C<GLOB_BRACE> + +Pre-process the string to expand C<{pat,pat,...}> strings like csh(1). +The pattern '{}' is left unexpanded for historical reasons (and csh(1) +does the same thing to ease typing of find(1) patterns). + +=item C<GLOB_NOMAGIC> + +Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not +contain any of the special characters "*", "?" or "[". C<NOMAGIC> is +provided to simplify implementing the historic csh(1) globbing +behaviour and should probably not be used anywhere else. + +=item C<GLOB_QUOTE> + +Use the backslash ('\') character for quoting: every occurrence of a +backslash followed by a character in the pattern is replaced by that +character, avoiding any special interpretation of the character. +(But see below for exceptions on DOSISH systems). + +=item C<GLOB_TILDE> + +Expand patterns that start with '~' to user name home directories. + +=item C<GLOB_CSH> + +For convenience, C<GLOB_CSH> is a synonym for +C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>. + +=back + +The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD +extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been +implemented in the Perl version because they involve more complex +interaction with the underlying C structures. + +The following flag has been added in the Perl implementation for +csh compatibility: + +=over 4 + +=item C<GLOB_ALPHASORT> + +If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical +order (case does not matter) rather than in ASCII order. + +=back + +=head1 DIAGNOSTICS + +bsd_glob() returns a list of matching paths, possibly zero length. If an +error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be +set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, +or one of the following values otherwise: + +=over 4 + +=item C<GLOB_NOSPACE> + +An attempt to allocate memory failed. + +=item C<GLOB_ABEND> + +The glob was stopped because an error was encountered. + +=back + +In the case where bsd_glob() has found some matching paths, but is +interrupted by an error, it will return a list of filenames B<and> +set &File::Glob::ERROR. + +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will +continue processing despite those errors, unless the C<GLOB_ERR> flag is +set. + +Be aware that all filenames returned from File::Glob are tainted. + +=head1 NOTES + +=over 4 + +=item * + +If you want to use multiple patterns, e.g. C<bsd_glob("a* b*")>, you should +probably throw them in a set as in C<bsd_glob("{a*,b*}")>. This is because +the argument to bsd_glob() isn't subjected to parsing by the C shell. +Remember that you can use a backslash to escape things. + +=item * + +On DOSISH systems, backslash is a valid directory separator character. +In this case, use of backslash as a quoting character (via GLOB_QUOTE) +interferes with the use of backslash as a directory separator. The +best (simplest, most portable) solution is to use forward slashes for +directory separators, and backslashes for quoting. However, this does +not match "normal practice" on these systems. As a concession to user +expectation, therefore, backslashes (under GLOB_QUOTE) only quote the +glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. +All other backslashes are passed through unchanged. + +=item * + +Win32 users should use the real slash. If you really want to use +backslashes, consider using Sarathy's File::DosGlob, which comes with +the standard Perl distribution. + +=item * + +Mac OS (Classic) users should note a few differences. Since +Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. +~user) and the C<GLOB_TILDE> flag is used, it simply returns that +pattern without doing any expansion. + +Glob on Mac OS is case-insensitive by default (if you don't use any +flags). If you specify any flags at all and still want glob +to be case-insensitive, you must include C<GLOB_NOCASE> in the flags. + +The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users +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. + +The specification of pathnames in glob patterns adheres to the usual Mac +OS conventions: The path separator is a colon ':', not a slash '/'. 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 E<lt>:*:E<gt> will find both +directories I<and> files (and not, as one might expect, only directories). +You can, however, use the C<GLOB_MARK> flag to distinguish (without a file +test) directory names from file names. + +If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended. +Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS, +both a leading and a trailing colon will be added, when the directory name in +question doesn't contain any colons (e.g. 'lib' becomes ':lib:'). + +=back + +=head1 SEE ALSO + +L<perlfunc/glob>, glob(3) + +=head1 AUTHOR + +The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>, +and is released under the artistic license. Further modifications were +made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>, and Thomas Wegner +E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the +following copyright: + + Copyright (c) 1989, 1993 The Regents of the University of California. + All rights reserved. + + This code is derived from software contributed to Berkeley by + Guido van Rossum. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/GlobMapper.pm b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm new file mode 100755 index 00000000000..40a606309e0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm @@ -0,0 +1,679 @@ +package File::GlobMapper; + +use strict; +use warnings; +use Carp; + +our ($CSH_GLOB); + +BEGIN +{ + if ($] < 5.006) + { + require File::BSDGlob; import File::BSDGlob qw(:glob) ; + $CSH_GLOB = File::BSDGlob::GLOB_CSH() ; + *globber = \&File::BSDGlob::csh_glob; + } + else + { + require File::Glob; import File::Glob qw(:glob) ; + $CSH_GLOB = File::Glob::GLOB_CSH() ; + #*globber = \&File::Glob::bsd_glob; + *globber = \&File::Glob::csh_glob; + } +} + +our ($Error); + +our ($VERSION, @EXPORT_OK); +$VERSION = '1.000'; +@EXPORT_OK = qw( globmap ); + + +our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); +$noPreBS = '(?<!\\\)' ; # no preceeding backslash +$metachars = '.*?[](){}'; +$matchMetaRE = '[' . quotemeta($metachars) . ']'; + +%mapping = ( + '*' => '([^/]*)', + '?' => '([^/])', + '.' => '\.', + '[' => '([', + '(' => '(', + ')' => ')', + ); + +%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; + +sub globmap ($$;) +{ + my $inputGlob = shift ; + my $outputGlob = shift ; + + my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) + or croak "globmap: $Error" ; + return $obj->getFileMap(); +} + +sub new +{ + my $class = shift ; + my $inputGlob = shift ; + my $outputGlob = shift ; + # TODO -- flags needs to default to whatever File::Glob does + my $flags = shift || $CSH_GLOB ; + #my $flags = shift ; + + $inputGlob =~ s/^\s*\<\s*//; + $inputGlob =~ s/\s*\>\s*$//; + + $outputGlob =~ s/^\s*\<\s*//; + $outputGlob =~ s/\s*\>\s*$//; + + my %object = + ( InputGlob => $inputGlob, + OutputGlob => $outputGlob, + GlobFlags => $flags, + Braces => 0, + WildCount => 0, + Pairs => [], + Sigil => '#', + ); + + my $self = bless \%object, ref($class) || $class ; + + $self->_parseInputGlob() + or return undef ; + + $self->_parseOutputGlob() + or return undef ; + + my @inputFiles = globber($self->{InputGlob}, $flags) ; + + if (GLOB_ERROR) + { + $Error = $!; + return undef ; + } + + #if (whatever) + { + my $missing = grep { ! -e $_ } @inputFiles ; + + if ($missing) + { + $Error = "$missing input files do not exist"; + return undef ; + } + } + + $self->{InputFiles} = \@inputFiles ; + + $self->_getFiles() + or return undef ; + + return $self; +} + +sub _retError +{ + my $string = shift ; + $Error = "$string in input fileglob" ; + return undef ; +} + +sub _unmatched +{ + my $delimeter = shift ; + + _retError("Unmatched $delimeter"); + return undef ; +} + +sub _parseBit +{ + my $self = shift ; + + my $string = shift ; + + my $out = ''; + my $depth = 0 ; + + while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//) + { + $out .= quotemeta($1) ; + $out .= $mapping{$2} if defined $mapping{$2}; + + ++ $self->{WildCount} if $wildCount{$2} ; + + if ($2 eq ',') + { + return _unmatched "(" + if $depth ; + + $out .= '|'; + } + elsif ($2 eq '(') + { + ++ $depth ; + } + elsif ($2 eq ')') + { + return _unmatched ")" + if ! $depth ; + + -- $depth ; + } + elsif ($2 eq '[') + { + # TODO -- quotemeta & check no '/' + # TODO -- check for \] & other \ within the [] + $string =~ s#(.*?\])## + or return _unmatched "[" ; + $out .= "$1)" ; + } + elsif ($2 eq ']') + { + return _unmatched "]" ; + } + elsif ($2 eq '{' || $2 eq '}') + { + return _retError "Nested {} not allowed" ; + } + } + + $out .= quotemeta $string; + + return _unmatched "(" + if $depth ; + + return $out ; +} + +sub _parseInputGlob +{ + my $self = shift ; + + my $string = $self->{InputGlob} ; + my $inGlob = ''; + + # Multiple concatenated *'s don't make sense + #$string =~ s#\*\*+#*# ; + + # TODO -- Allow space to delimit patterns? + #my @strings = split /\s+/, $string ; + #for my $str (@strings) + my $out = ''; + my $depth = 0 ; + + while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//) + { + $out .= quotemeta($1) ; + $out .= $mapping{$2} if defined $mapping{$2}; + ++ $self->{WildCount} if $wildCount{$2} ; + + if ($2 eq '(') + { + ++ $depth ; + } + elsif ($2 eq ')') + { + return _unmatched ")" + if ! $depth ; + + -- $depth ; + } + elsif ($2 eq '[') + { + # TODO -- quotemeta & check no '/' or '(' or ')' + # TODO -- check for \] & other \ within the [] + $string =~ s#(.*?\])## + or return _unmatched "["; + $out .= "$1)" ; + } + elsif ($2 eq ']') + { + return _unmatched "]" ; + } + elsif ($2 eq '}') + { + return _unmatched "}" ; + } + elsif ($2 eq '{') + { + # TODO -- check no '/' within the {} + # TODO -- check for \} & other \ within the {} + + my $tmp ; + unless ( $string =~ s/(.*?)$noPreBS\}//) + { + return _unmatched "{"; + } + #$string =~ s#(.*?)\}##; + + #my $alt = join '|', + # map { quotemeta $_ } + # split "$noPreBS,", $1 ; + my $alt = $self->_parseBit($1); + defined $alt or return 0 ; + $out .= "($alt)" ; + + ++ $self->{Braces} ; + } + } + + return _unmatched "(" + if $depth ; + + $out .= quotemeta $string ; + + + $self->{InputGlob} =~ s/$noPreBS[\(\)]//g; + $self->{InputPattern} = $out ; + + #print "# INPUT '$self->{InputGlob}' => '$out'\n"; + + return 1 ; + +} + +sub _parseOutputGlob +{ + my $self = shift ; + + my $string = $self->{OutputGlob} ; + my $maxwild = $self->{WildCount}; + + if ($self->{GlobFlags} & GLOB_TILDE) + #if (1) + { + $string =~ s{ + ^ ~ # find a leading tilde + ( # save this in $1 + [^/] # a non-slash character + * # repeated 0 or more times (0 means me) + ) + }{ + $1 + ? (getpwnam($1))[7] + : ( $ENV{HOME} || $ENV{LOGDIR} ) + }ex; + + } + + # max #1 must be == to max no of '*' in input + while ( $string =~ m/#(\d)/g ) + { + croak "Max wild is #$maxwild, you tried #$1" + if $1 > $maxwild ; + } + + my $noPreBS = '(?<!\\\)' ; # no preceeding backslash + #warn "noPreBS = '$noPreBS'\n"; + + #$string =~ s/${noPreBS}\$(\d)/\${$1}/g; + $string =~ s/${noPreBS}#(\d)/\${$1}/g; + $string =~ s#${noPreBS}\*#\${inFile}#g; + $string = '"' . $string . '"'; + + #print "OUTPUT '$self->{OutputGlob}' => '$string'\n"; + $self->{OutputPattern} = $string ; + + return 1 ; +} + +sub _getFiles +{ + my $self = shift ; + + my %outInMapping = (); + my %inFiles = () ; + + foreach my $inFile (@{ $self->{InputFiles} }) + { + next if $inFiles{$inFile} ++ ; + + my $outFile = $inFile ; + + if ( $inFile =~ m/$self->{InputPattern}/ ) + { + no warnings 'uninitialized'; + eval "\$outFile = $self->{OutputPattern};" ; + + if (defined $outInMapping{$outFile}) + { + $Error = "multiple input files map to one output file"; + return undef ; + } + $outInMapping{$outFile} = $inFile; + push @{ $self->{Pairs} }, [$inFile, $outFile]; + } + } + + return 1 ; +} + +sub getFileMap +{ + my $self = shift ; + + return $self->{Pairs} ; +} + +sub getHash +{ + my $self = shift ; + + return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; +} + +1; + +__END__ + +=head1 NAME + +File::GlobMapper - Extend File Glob to Allow Input and Output Files + +=head1 SYNOPSIS + + use File::GlobMapper qw( globmap ); + + my $aref = globmap $input => $output + or die $File::GlobMapper::Error ; + + my $gm = new File::GlobMapper $input => $output + or die $File::GlobMapper::Error ; + + +=head1 DESCRIPTION + +This module needs Perl5.005 or better. + +This module takes the existing C<File::Glob> module as a starting point and +extends it to allow new filenames to be derived from the files matched by +C<File::Glob>. + +This can be useful when carrying out batch operations on multiple files that +have both an input filename and output filename and the output file can be +derived from the input filename. Examples of operations where this can be +useful include, file renaming, file copying and file compression. + + +=head2 Behind The Scenes + +To help explain what C<File::GlobMapper> does, consider what code you +would write if you wanted to rename all files in the current directory +that ended in C<.tar.gz> to C<.tgz>. So say these files are in the +current directory + + alpha.tar.gz + beta.tar.gz + gamma.tar.gz + +and they need renamed to this + + alpha.tgz + beta.tgz + gamma.tgz + +Below is a possible implementation of a script to carry out the rename +(error cases have been omitted) + + foreach my $old ( glob "*.tar.gz" ) + { + my $new = $old; + $new =~ s#(.*)\.tar\.gz$#$1.tgz# ; + + rename $old => $new + or die "Cannot rename '$old' to '$new': $!\n; + } + +Notice that a file glob pattern C<*.tar.gz> was used to match the +C<.tar.gz> files, then a fairly similar regular expression was used in +the substitute to allow the new filename to be created. + +Given that the file glob is just a cut-down regular expression and that it +has already done a lot of the hard work in pattern matching the filenames, +wouldn't it be handy to be able to use the patterns in the fileglob to +drive the new filename? + +Well, that's I<exactly> what C<File::GlobMapper> does. + +Here is same snippet of code rewritten using C<globmap> + + for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' ) + { + my ($from, $to) = @$pair; + rename $from => $to + or die "Cannot rename '$old' to '$new': $!\n; + } + +So how does it work? + +Behind the scenes the C<globmap> function does a combination of a +file glob to match existing filenames followed by a substitute +to create the new filenames. + +Notice how both parameters to C<globmap> are strings that are delimited by <>. +This is done to make them look more like file globs - it is just syntactic +sugar, but it can be handy when you want the strings to be visually +distinctive. The enclosing <> are optional, so you don't have to use them - in +fact the first thing globmap will do is remove these delimiters if they are +present. + +The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>. +Once the enclosing "< ... >" is removed, this is passed (more or +less) unchanged to C<File::Glob> to carry out a file match. + +Next the fileglob C<*.tar.gz> is transformed behind the scenes into a +full Perl regular expression, with the additional step of wrapping each +transformed wildcard metacharacter sequence in parenthesis. + +In this case the input fileglob C<*.tar.gz> will be transformed into +this Perl regular expression + + ([^/]*)\.tar\.gz + +Wrapping with parenthesis allows the wildcard parts of the Input File +Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>, +the I<Output File Glob>. This parameter operates just like the replacement +part of a substitute command. The difference is that the C<#1> syntax +is used to reference sub-patterns matched in the input fileglob, rather +than the C<$1> syntax that is used with perl regular expressions. In +this case C<#1> is used to refer to the text matched by the C<*> in the +Input File Glob. This makes it easier to use this module where the +parameters to C<globmap> are typed at the command line. + +The final step involves passing each filename matched by the C<*.tar.gz> +file glob through the derived Perl regular expression in turn and +expanding the output fileglob using it. + +The end result of all this is a list of pairs of filenames. By default +that is what is returned by C<globmap>. In this example the data structure +returned will look like this + + ( ['alpha.tar.gz' => 'alpha.tgz'], + ['beta.tar.gz' => 'beta.tgz' ], + ['gamma.tar.gz' => 'gamma.tgz'] + ) + + +Each pair is an array reference with two elements - namely the I<from> +filename, that C<File::Glob> has matched, and a I<to> filename that is +derived from the I<from> filename. + + + +=head2 Limitations + +C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to +solve all filename mapping operations. Under the hood C<File::Glob> (or for +older versions of Perl, C<File::BSDGlob>) is used to match the files, so you +will never have the flexibility of full Perl regular expression. + +=head2 Input File Glob + +The syntax for an Input FileGlob is identical to C<File::Glob>, except +for the following + +=over 5 + +=item 1. + +No nested {} + +=item 2. + +Whitespace does not delimit fileglobs. + +=item 3. + +The use of parenthesis can be used to capture parts of the input filename. + +=item 4. + +If an Input glob matches the same file more than once, only the first +will be used. + +=back + +The syntax + +=over 5 + +=item B<~> + +=item B<~user> + + +=item B<.> + +Matches a literal '.'. +Equivalent to the Perl regular expression + + \. + +=item B<*> + +Matches zero or more characters, except '/'. Equivalent to the Perl +regular expression + + [^/]* + +=item B<?> + +Matches zero or one character, except '/'. Equivalent to the Perl +regular expression + + [^/]? + +=item B<\> + +Backslash is used, as usual, to escape the next character. + +=item B<[]> + +Character class. + +=item B<{,}> + +Alternation + +=item B<()> + +Capturing parenthesis that work just like perl + +=back + +Any other character it taken literally. + +=head2 Output File Glob + +The Output File Glob is a normal string, with 2 glob-like features. + +The first is the '*' metacharacter. This will be replaced by the complete +filename matched by the input file glob. So + + *.c *.Z + +The second is + +Output FileGlobs take the + +=over 5 + +=item "*" + +The "*" character will be replaced with the complete input filename. + +=item #1 + +Patterns of the form /#\d/ will be replaced with the + +=back + +=head2 Returned Data + + +=head1 EXAMPLES + +=head2 A Rename script + +Below is a simple "rename" script that uses C<globmap> to determine the +source and destination filenames. + + use File::GlobMapper qw(globmap) ; + use File::Copy; + + die "rename: Usage rename 'from' 'to'\n" + unless @ARGV == 2 ; + + my $fromGlob = shift @ARGV; + my $toGlob = shift @ARGV; + + my $pairs = globmap($fromGlob, $toGlob) + or die $File::GlobMapper::Error; + + for my $pair (@$pairs) + { + my ($from, $to) = @$pair; + move $from => $to ; + } + + + +Here is an example that renames all c files to cpp. + + $ rename '*.c' '#1.cpp' + +=head2 A few example globmaps + +Below are a few examples of globmaps + +To copy all your .c file to a backup directory + + '</my/home/*.c>' '</my/backup/#1.c>' + +If you want to compress all + + '</my/home/*.[ch]>' '<*.gz>' + +To uncompress + + '</my/home/*.[ch].gz>' '</my/home/#1.#2>' + +=head1 SEE ALSO + +L<File::Glob|File::Glob> + +=head1 AUTHOR + +The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005 Paul Marquess. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir.pm b/Master/tlpkg/tlperl/lib/File/HomeDir.pm new file mode 100755 index 00000000000..d63618d2308 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir.pm @@ -0,0 +1,633 @@ +package File::HomeDir; + +# See POD at end for documentation + +use 5.00503; +use strict; +use Carp (); +use Config (); +use File::Spec (); + +# Globals +use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK $IMPLEMENTED_BY}; +BEGIN { + $VERSION = '0.89'; + + # Inherit manually + require Exporter; + @ISA = qw{ Exporter }; + @EXPORT = qw{ home }; + @EXPORT_OK = qw{ + home + my_home + my_desktop + my_documents + my_music + my_pictures + my_videos + my_data + users_home + users_desktop + users_documents + users_music + users_pictures + users_videos + users_data + }; + + # %~ doesn't need (and won't take) exporting, as it's a magic + # symbol name that's always looked for in package 'main'. +} + +# Inlined Params::Util functions +sub _CLASS ($) { + (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef; +} +sub _DRIVER ($$) { + (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; +} + +# Platform detection +if ( $IMPLEMENTED_BY ) { + # Allow for custom HomeDir classes + # Leave it as the existing value +} elsif ( $^O eq 'MSWin32' ) { + # All versions of Windows + $IMPLEMENTED_BY = 'File::HomeDir::Windows'; +} elsif ( $^O eq 'darwin') { + TRY: { + if ( $Config::Config{ptrsize} == 8 ) { + # 64bit: try Mac::SystemDirectory by chansen + if ( eval { require Mac::SystemDirectory; 1 } ) { + $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Cocoa'; + last TRY; + } + + } elsif (eval { require Mac::Files; 1 }) { + # 32bit and has Mac::Files: Carbon + $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Carbon'; + last TRY; + } + + # fallback: pure perl + $IMPLEMENTED_BY = 'File::HomeDir::Darwin'; + } +} elsif ( $^O eq 'MacOS' ) { + # Legacy Mac OS + $IMPLEMENTED_BY = 'File::HomeDir::MacOS9'; +} else { + # Default to Unix semantics + $IMPLEMENTED_BY = 'File::HomeDir::Unix'; +} +unless ( _DRIVER($IMPLEMENTED_BY, 'File::HomeDir::Driver') ) { + Carp::croak("Missing or invalid File::HomeDir driver $IMPLEMENTED_BY"); +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + $IMPLEMENTED_BY->my_home; +} + +sub my_desktop { + $IMPLEMENTED_BY->can('my_desktop') + ? $IMPLEMENTED_BY->my_desktop + : Carp::croak("The my_desktop method is not implemented on this platform"); +} + +sub my_documents { + $IMPLEMENTED_BY->can('my_documents') + ? $IMPLEMENTED_BY->my_documents + : Carp::croak("The my_documents method is not implemented on this platform"); +} + +sub my_music { + $IMPLEMENTED_BY->can('my_music') + ? $IMPLEMENTED_BY->my_music + : Carp::croak("The my_music method is not implemented on this platform"); +} + +sub my_pictures { + $IMPLEMENTED_BY->can('my_pictures') + ? $IMPLEMENTED_BY->my_pictures + : Carp::croak("The my_pictures method is not implemented on this platform"); +} + +sub my_videos { + $IMPLEMENTED_BY->can('my_videos') + ? $IMPLEMENTED_BY->my_videos + : Carp::croak("The my_videos method is not implemented on this platform"); +} + +sub my_data { + $IMPLEMENTED_BY->can('my_data') + ? $IMPLEMENTED_BY->my_data + : Carp::croak("The my_data method is not implemented on this platform"); +} + + + + + +##################################################################### +# General User Methods + +sub users_home { + $IMPLEMENTED_BY->can('users_home') + ? $IMPLEMENTED_BY->users_home( $_[-1] ) + : Carp::croak("The users_home method is not implemented on this platform"); +} + +sub users_desktop { + $IMPLEMENTED_BY->can('users_desktop') + ? $IMPLEMENTED_BY->users_desktop( $_[-1] ) + : Carp::croak("The users_desktop method is not implemented on this platform"); +} + +sub users_documents { + $IMPLEMENTED_BY->can('users_documents') + ? $IMPLEMENTED_BY->users_documents( $_[-1] ) + : Carp::croak("The users_documents method is not implemented on this platform"); +} + +sub users_music { + $IMPLEMENTED_BY->can('users_music') + ? $IMPLEMENTED_BY->users_music( $_[-1] ) + : Carp::croak("The users_music method is not implemented on this platform"); +} + +sub users_pictures { + $IMPLEMENTED_BY->can('users_pictures') + ? $IMPLEMENTED_BY->users_pictures( $_[-1] ) + : Carp::croak("The users_pictures method is not implemented on this platform"); +} + +sub users_videos { + $IMPLEMENTED_BY->can('users_videos') + ? $IMPLEMENTED_BY->users_videos( $_[-1] ) + : Carp::croak("The users_videos method is not implemented on this platform"); +} + +sub users_data { + $IMPLEMENTED_BY->can('users_data') + ? $IMPLEMENTED_BY->users_data( $_[-1] ) + : Carp::croak("The users_data method is not implemented on this platform"); +} + + + + + + +##################################################################### +# Legacy Methods + +# Find the home directory of an arbitrary user +sub home (;$) { + # Allow to be called as a method + if ( $_[0] and $_[0] eq 'File::HomeDir' ) { + shift(); + } + + # No params means my home + return my_home() unless @_; + + # Check the param + my $name = shift; + if ( ! defined $name ) { + Carp::croak("Can't use undef as a username"); + } + if ( ! length $name ) { + Carp::croak("Can't use empty-string (\"\") as a username"); + } + + # A dot also means my home + ### Is this meant to mean File::Spec->curdir? + if ( $name eq '.' ) { + return my_home(); + } + + # Now hand off to the implementor + $IMPLEMENTED_BY->users_home($name); +} + + + + + +##################################################################### +# Tie-Based Interface + +# Okay, things below this point get scary + +CLASS: { + # Make the class for the %~ tied hash: + package File::HomeDir::TIE; + + # Make the singleton object. + # (We don't use the hash for anything, though) + ### THEN WHY MAKE IT??? + my $SINGLETON = bless {}; + + sub TIEHASH { $SINGLETON } + + sub FETCH { + # Catch a bad username + unless ( defined $_[1] ) { + Carp::croak("Can't use undef as a username"); + } + + # Get our homedir + unless ( length $_[1] ) { + return File::HomeDir::my_home(); + } + + # Get a named user's homedir + return File::HomeDir::home($_[1]); + } + + sub STORE { _bad('STORE') } + sub EXISTS { _bad('EXISTS') } + sub DELETE { _bad('DELETE') } + sub CLEAR { _bad('CLEAR') } + sub FIRSTKEY { _bad('FIRSTKEY') } + sub NEXTKEY { _bad('NEXTKEY') } + + sub _bad ($) { + Carp::croak("You can't $_[0] with the %~ hash") + } +} + +# Do the actual tie of the global %~ variable +tie %~, 'File::HomeDir::TIE'; + +1; + +__END__ + +=pod + +=head1 NAME + +File::HomeDir - Find your home and other directories, on any platform + +=head1 SYNOPSIS + + use File::HomeDir; + + # Modern Interface (Current User) + $home = File::HomeDir->my_home; + $desktop = File::HomeDir->my_desktop; + $docs = File::HomeDir->my_documents; + $music = File::HomeDir->my_music; + $pics = File::HomeDir->my_pictures; + $videos = File::HomeDir->my_videos; + $data = File::HomeDir->my_data; + + # Modern Interface (Other Users) + $home = File::HomeDir->users_home('foo'); + $desktop = File::HomeDir->users_desktop('foo'); + $docs = File::HomeDir->users_documents('foo'); + $music = File::HomeDir->users_music('foo'); + $pics = File::HomeDir->users_pictures('foo'); + $video = File::HomeDir->users_videos('foo'); + $data = File::HomeDir->users_data('foo'); + + # Legacy Interfaces + print "My dir is ", home(), " and root's is ", home('root'), "\n"; + print "My dir is $~{''} and root's is $~{root}\n"; + # These both print the same thing, something like: + # "My dir is /home/user/mojo and root's is /" + +=head1 DESCRIPTION + +B<File::HomeDir> is a module for dealing with issues relating to the +location of directories that are "owned" by a user, primarily your user, +and to solve these issues consistently across a wide variety of +platforms. + +Thus, a single API is presented that can find your resources on any +platform. + +This module provides two main interfaces. + +The first is a modern L<File::Spec>-style interface with a consistent +OO API and different implementation modules to support various +platforms. You are B<strongly> recommended to use this interface. + +The second interface is for legacy support of the original 0.07 interface +that exported a C<home()> function by default and tied the C<%~> variable. + +It is generally not recommended that you use this interface, but due to +back-compatibility reasons they will remain supported until at least 2010. + +After this date, the home() function will remain, but we will consider +deprecating the (namespace-polluting) C<%~> tied hash, to be removed by +2015 (maintaining the general Perl convention of a 10 year support period +for legacy APIs potentially or actually in common use). + +=head2 Platform Neutrality + +In the Unix world, many different types of data can be mixed together +in your home directory (although on some Unix platforms this is no longer +the case, particularly for "desktop"-oriented platforms). + +On some non-Unix platforms, seperate directories are allocated for +different types of data and have been for a long time. + +When writing applications on top of B<File::HomeDir>, you should thus +always try to use the most specific method you can. User documents should +be saved in C<my_documents>, data that supports an application but isn't +normally editing by the user directory should go into C<my_data>. + +On platforms that do not make any distinction, all these different +methods will harmlessly degrade to the main home directory, but on +platforms that care B<File::HomeDir> will always try to Do The Right +Thing(tm). + +=head1 METHODS + +Two types of methods are provided. The C<my_method> series of methods for +finding resources for the current user, and the C<users_method> (read as +"user's method") series for finding resources for arbitrary users. + +This split is necesary, as on most platforms it is B<much> easier to find +information about the current user compared to other users, and indeed +on a number you cannot find out information such as C<users_desktop> at +all, due to security restrictions. + +All methods will double check (using a C<-d> test) that a directory +actually exists before returning it, so you may trust in the values +that are returned (subject to the usual caveats of race conditions of +directories being deleted at the moment between a directory being returned +and you using it). + +However, because in some cases platforms may not support the concept of home +directories at all, any method may return C<undef> (both in scalar and list +context) to indicate that there is no matching directory on the system. + +For example, most untrusted 'nobody'-type users do not have a home +directory. So any modules that are used in a CGI application that +at some level of recursion use your code, will result in calls to +File::HomeDir returning undef, even for a basic home() call. + +=head2 my_home + +The C<my_home> method takes no arguments and returns the main home/profile +directory for the current user. + +If the distinction is important to you, the term "current" refers to the +real user, and not the effective user. + +This is also the case for all of the other "my" methods. + +Returns the directory path as a string, C<undef> if the current user +does not have a home directory, or dies on error. + +=head2 my_desktop + +The C<my_desktop> method takes no arguments and returns the "desktop" +directory for the current user. + +Due to the diversity and complexity of implementions required to deal with +implementing the required functionality fully and completely, for the moment +C<my_desktop> is B<not> going to be implemented. + +That said, I am extremely interested in code to implement C<my_desktop> on +Unix, as long as it is capable of dealing (as the Windows implementation +does) with internationalisation. It should also avoid false positive +results by making sure it only returns the appropriate directories for the +appropriate platforms. + +Returns the directory path as a string, C<undef> if the current user +does not have a desktop directory, or dies on error. + +=head2 my_documents + +The C<my_documents> method takes no arguments and returns the directory (for +the current user) where the user's documents are stored. + +Returns the directory path as a string, C<undef> if the current user +does not have a documents directory, or dies on error. + +=head2 my_music + +The C<my_music> method takes no arguments and returns the directory +where the current user's music is stored. + +No bias is made to any particular music type or music program, rather the +concept of a directory to hold the user's music is made at the level of the +underlying operating system or (at least) desktop environment. + +Returns the directory path as a string, C<undef> if the current user +does not have a suitable directory, or dies on error. + +=head2 my_pictures + +The C<my_pictures> method takes no arguments and returns the directory +where the current user's pictures are stored. + +No bias is made to any particular picture type or picture program, rather the +concept of a directory to hold the user's pictures is made at the level of the +underlying operating system or (at least) desktop environment. + +Returns the directory path as a string, C<undef> if the current user +does not have a suitable directory, or dies on error. + +=head2 my_videos + +The C<my_videos> method takes no arguments and returns the directory +where the current user's videos are stored. + +No bias is made to any particular video type or video program, rather the +concept of a directory to hold the user's videos is made at the level of the +underlying operating system or (at least) desktop environment. + +Returns the directory path as a string, C<undef> if the current user +does not have a suitable directory, or dies on error. + +=head2 my_data + +The C<my_data> method takes no arguments and returns the directory where +local applications should stored their internal data for the current +user. + +Generally an application would create a subdirectory such as C<.foo>, +beneath this directory, and store its data there. By creating your +directory this way, you get an accurate result on the maximum number +of platforms. + +For example, on Unix you get C<~/.foo> and on Win32 you get +C<~/Local Settings/Application Data/.foo> + +Returns the directory path as a string, C<undef> if the current user +does not have a data directory, or dies on error. + +=head2 users_home + + $home = File::HomeDir->users_home('foo'); + +The C<users_home> method takes a single param and is used to locate the +parent home/profile directory for an identified user on the system. + +While most of the time this identifier would be some form of user name, +it is permitted to vary per-platform to support user ids or UUIDs as +applicable for that platform. + +Returns the directory path as a string, C<undef> if that user +does not have a home directory, or dies on error. + +=head2 users_documents + + $docs = File::HomeDir->users_documents('foo'); + +Returns the directory path as a string, C<undef> if that user +does not have a documents directory, or dies on error. + +=head2 users_data + + $data = File::HomeDir->users_data('foo'); + +Returns the directory path as a string, C<undef> if that user +does not have a data directory, or dies on error. + +=head1 FUNCTIONS + +=head2 home + + use File::HomeDir; + $home = home(); + $home = home('foo'); + $home = File::HomeDir::home(); + $home = File::HomeDir::home('foo'); + +The C<home> function is exported by default and is provided for +compatibility with legacy applications. In new applications, you should +use the newer method-based interface above. + +Returns the directory path to a named user's home/profile directory. + +If provided no param, returns the directory path to the current user's +home/profile directory. + +=head1 TIED INTERFACE + +=head2 %~ + + $home = $~{""}; + $home = $~{undef}; + $home = $~{$user}; + $home = $~{username}; + print "... $~{''} ..."; + print "... $~{$user} ..."; + print "... $~{username} ..."; + +This calls C<home($user)> or C<home('username')> -- except that if you +ask for C<$~{some_user}> and there is no such user, it will die. + +Note that this is especially useful in double-quotish strings, like: + + print "Jojo's .newsrc is ", -s "$~{jojo}/.newsrc", "b long!\n"; + # (helpfully dies if there is no user 'jojo') + +If you want to avoid the fatal errors, first test the value of +C<home('jojo')>, which will return undef (instead of dying) in case of +there being no such user. + +Note, however, that if the hash key is "" or undef (whether thru being +a literal "", or a scalar whose value is empty-string or undef), then +this returns zero-argument C<home()>, i.e., your home directory: + +Further, please note that because the C<%~> hash compulsorily modifies +a hash outside of it's namespace, and presents an overly simplistic +approach to home directories, it is likely to ultimately be removed. + +The interface is currently expected to be formally deprecated from 2010 +(but no earlier) and removed from 2015 (but no earlier). If very heavy +use is found in the wild, these plans may be pushed back. + +=head1 TO DO + +=over 4 + +=item * Become generally clearer on situations in which a user might not +have a particular resource. + +=item * Add more granularity to Unix, and add support to VMS and other +esoteric platforms, so we can consider going core. + +=item * Add consistent support for users_* methods + +=back + +=head1 SUPPORT + +This module is stored in an Open Repository at the following address. + +L<http://svn.ali.as/cpan/trunk/File-HomeDir> + +Write access to the repository is made available automatically to any +published CPAN author, and to most other volunteers on request. + +If you are able to submit your bug report in the form of new (failing) +unit tests, or can apply your fix directly instead of submitting a patch, +you are B<strongly> encouraged to do so as the author currently maintains +over 100 modules and it can take some time to deal with non-Critical bug +reports or patches. + +This will guarantee that your issue will be addressed in the next +release of the module. + +If you cannot provide a direct test or fix, or don't have time to do so, +then regular bug reports are still accepted and appreciated via the CPAN +bug tracker. + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-HomeDir> + +For other issues, for commercial enhancement or support, or to have your +write access enabled for the repository, contact the author at the email +address above. + +=head1 ACKNOWLEDGEMENTS + +The biggest acknowledgement must go to Chris Nandor, who wielded his +legendary Mac-fu and turned my initial fairly ordinary Darwin +implementation into something that actually worked properly everywhere, +and then donated a Mac OS X license to allow it to be maintained properly. + +=head1 AUTHORS + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Sean M. Burke E<lt>sburke@cpan.orgE<gt> + +Chris Nandor E<lt>cnandor@cpan.orgE<gt> + +Stephen Steneker E<lt>stennie@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::ShareDir>, L<File::HomeDir::Win32> (legacy) + +=head1 COPYRIGHT + +Copyright 2005 - 2010 Adam Kennedy. + +Some parts copyright 2000 Sean M. Burke. + +Some parts copyright 2006 Chris Nandor. + +Some parts copyright 2006 Stephen Steneker. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin.pm new file mode 100755 index 00000000000..fbe7847edda --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin.pm @@ -0,0 +1,152 @@ +package File::HomeDir::Darwin; + +use 5.00503; +use strict; +use Cwd (); +use Carp (); +use File::HomeDir::Unix (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '0.89'; + @ISA = 'File::HomeDir::Unix'; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + my $home = (getpwuid($<))[7]; + return $home if $home && -d $home; + + return undef; +} + +sub _my_home { + my($class, $path) = @_; + my $home = $class->my_home; + return undef unless defined $home; + + my $folder = "$home/$path"; + unless ( -d $folder ) { + # Make sure that symlinks resolve to directories. + return unless -l $folder; + my $dir = readlink $folder or return; + return unless -d $dir; + } + + return Cwd::abs_path($folder); +} + +sub my_desktop { + my $class = shift; + $class->_my_home('Desktop'); +} + +sub my_documents { + my $class = shift; + $class->_my_home('Documents'); +} + +sub my_data { + my $class = shift; + $class->_my_home('Library/Application Support'); +} + +sub my_music { + my $class = shift; + $class->_my_home('Music'); +} + +sub my_pictures { + my $class = shift; + $class->_my_home('Pictures'); +} + +sub my_videos { + my $class = shift; + $class->_my_home('Movies'); +} + + + + + +##################################################################### +# Arbitrary User Methods + +sub users_home { + my $class = shift; + my $home = $class->SUPER::users_home(@_); + return defined $home ? Cwd::abs_path($home) : undef; +} + +sub users_desktop { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_desktop, $name ); +} + +sub users_documents { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_documents, $name ); +} + +sub users_data { + my ($class, $name) = @_; + $class->_to_user( $class->my_data, $name ) + || + $class->users_home($name); +} + +# cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since +# there's really no other good way to do it at this time, that i know of -- pudge +sub _to_user { + my ($class, $path, $name) = @_; + my $my_home = $class->my_home; + my $users_home = $class->users_home($name); + defined $users_home or return undef; + $path =~ s/^\Q$my_home/$users_home/; + return $path; +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Darwin - Find your home and other directories, on Darwin (OS X) without Carbon/Cocoa + +=head1 DESCRIPTION + +This module provides Mac OS X specific file path for determining +common user directories in pure perl, by just using C<$ENV{HOME}> +without Carbon nor Cocoa API calls. In normal usage this module will +always be used via L<File::HomeDir>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /Users/mylogin + $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop + $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents + $music = File::HomeDir->my_music; # /Users/mylogin/Music + $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures + $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies + $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin/Carbon.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin/Carbon.pm new file mode 100755 index 00000000000..3234156b0eb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin/Carbon.pm @@ -0,0 +1,210 @@ +package File::HomeDir::Darwin::Carbon; + +# Basic implementation for the Dawin family of operating systems. +# This includes (most prominently) Mac OS X. + +use 5.00503; +use strict; +use Cwd (); +use Carp (); +use File::HomeDir::Darwin (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '0.89'; + + # This is only a child class of the pure Perl darwin + # class so that we can do homedir detection of all three + # drivers at one via ->isa. + @ISA = 'File::HomeDir::Darwin'; + + # Load early if in a forking environment and we have + # prefork, or at run-time if not. + local $@; + eval "use prefork 'Mac::Files'"; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # A lot of unix people and unix-derived tools rely on + # the ability to overload HOME. We will support it too + # so that they can replace raw HOME calls with File::HomeDir. + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + require Mac::Files; + $class->_find_folder( + Mac::Files::kCurrentUserFolderType(), + ); +} + +sub my_desktop { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kDesktopFolderType(), + ); +} + +sub my_documents { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kDocumentsFolderType(), + ); +} + +sub my_data { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kApplicationSupportFolderType(), + ); +} + +sub my_music { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kMusicDocumentsFolderType(), + ); +} + +sub my_pictures { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kPictureDocumentsFolderType(), + ); +} + +sub my_videos { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kMovieDocumentsFolderType(), + ); +} + +sub _find_folder { + my $class = shift; + my $name = shift; + + require Mac::Files; + my $folder = Mac::Files::FindFolder( + Mac::Files::kUserDomain(), + $name, + ); + return unless defined $folder; + + unless ( -d $folder ) { + # Make sure that symlinks resolve to directories. + return unless -l $folder; + my $dir = readlink $folder or return; + return unless -d $dir; + } + + return Cwd::abs_path($folder); +} + + + + + +##################################################################### +# Arbitrary User Methods + +sub users_home { + my $class = shift; + my $home = $class->SUPER::users_home(@_); + return defined $home ? Cwd::abs_path($home) : undef; +} + +# in theory this can be done, but for now, let's cheat, since the +# rest is Hard +sub users_desktop { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_desktop, $name ); +} + +sub users_documents { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_documents, $name ); +} + +sub users_data { + my ($class, $name) = @_; + $class->_to_user( $class->my_data, $name ) + || + $class->users_home($name); +} + +# cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since +# there's really no other good way to do it at this time, that i know of -- pudge +sub _to_user { + my ($class, $path, $name) = @_; + my $my_home = $class->my_home; + my $users_home = $class->users_home($name); + defined $users_home or return undef; + $path =~ s/^\Q$my_home/$users_home/; + return $path; +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Darwin - Find your home and other directories, on Darwin (OS X) + +=head1 DESCRIPTION + +This module provides Darwin-specific implementations for determining +common user directories. In normal usage this module will always be +used via L<File::HomeDir>. + +Note -- since this module requires Mac::Carbon and Mac::Carbon does +not work with 64-bit perls, on such systems, File::HomeDir will try +L<File::HomeDir::Darwin::Cocoa> and then fall back to the (pure Perl) +L<File::HomeDir::Darwin>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /Users/mylogin + $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop + $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents + $music = File::HomeDir->my_music; # /Users/mylogin/Music + $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures + $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies + $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support + +=head1 TODO + +=over 4 + +=item * Test with Mac OS (versions 7, 8, 9) + +=item * Some better way for users_* ? + +=back diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin/Cocoa.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin/Cocoa.pm new file mode 100755 index 00000000000..e82dd9d449c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/Darwin/Cocoa.pm @@ -0,0 +1,165 @@ +package File::HomeDir::Darwin::Cocoa; + +use 5.00503; +use strict; +use Cwd (); +use Carp (); +use File::HomeDir::Darwin (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '0.89'; + @ISA = 'File::HomeDir::Darwin'; + + # Load early if in a forking environment and we have + # prefork, or at run-time if not. + local $@; + eval "use prefork 'Mac::SystemDirectory'"; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # A lot of unix people and unix-derived tools rely on + # the ability to overload HOME. We will support it too + # so that they can replace raw HOME calls with File::HomeDir. + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + require Mac::SystemDirectory; + return Mac::SystemDirectory::HomeDirectory(); +} + +# from 10.4 +sub my_desktop { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSDesktopDirectory()) + } + || + $class->SUPER::my_desktop; +} + +# from 10.2 +sub my_documents { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSDocumentDirectory()) + } + || + $class->SUPER::my_documents; +} + +# from 10.4 +sub my_data { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSApplicationSupportDirectory()) + } + || + $class->SUPER::my_data; +} + +# from 10.6 +sub my_music { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSMusicDirectory()) + } + || + $class->SUPER::my_music; +} + +# from 10.6 +sub my_pictures { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSPicturesDirectory()) + } + || + $class->SUPER::my_pictures; +} + +# from 10.6 +sub my_videos { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSMoviesDirectory()) + } + || + $class->SUPER::my_videos; +} + +sub _find_folder { + my $class = shift; + my $name = shift; + + require Mac::SystemDirectory; + my $folder = Mac::SystemDirectory::FindDirectory($name); + return unless defined $folder; + + unless ( -d $folder ) { + # Make sure that symlinks resolve to directories. + return unless -l $folder; + my $dir = readlink $folder or return; + return unless -d $dir; + } + + return Cwd::abs_path($folder); +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Darwin::Cocoa - Find your home and other directories, on Darwin (OS X) + +=head1 DESCRIPTION + +This module provides Darwin-specific implementations for determining +common user directories using Cocoa API through +L<Mac::SystemDirectory>. In normal usage this module will always be +used via L<File::HomeDir>. + +Theoretically, this should return the same paths as both of the other +Darwin drivers. + +Because this module requires L<Mac::SystemDirectory>, if the module +is not installed, L<File::HomeDir> will fall back to L<File::HomeDir::Darwin>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /Users/mylogin + $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop + $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents + $music = File::HomeDir->my_music; # /Users/mylogin/Music + $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures + $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies + $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/Driver.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/Driver.pm new file mode 100755 index 00000000000..c47a7caaad1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/Driver.pm @@ -0,0 +1,19 @@ +package File::HomeDir::Driver; + +# Abstract base class that provides no functionality, +# but confirms the class is a File::HomeDir driver class. + +use 5.00503; +use strict; +use Carp (); + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.89'; +} + +sub my_home { + Carp::croak("$_[0] does not implement compulsory method $_[1]"); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/MacOS9.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/MacOS9.pm new file mode 100755 index 00000000000..f9fe9e0fbe6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/MacOS9.pm @@ -0,0 +1,97 @@ +package File::HomeDir::MacOS9; + +# Half-assed implementation for the legacy Mac OS9 operating system. +# Provided mainly to provide legacy compatibility. May be removed at +# a later date. + +use 5.00503; +use strict; +use Carp (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '0.89'; + @ISA = 'File::HomeDir::Driver'; +} + +# Load early if in a forking environment and we have +# prefork, or at run-time if not. +SCOPE: { + local $@; + eval "use prefork 'Mac::Files'"; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # Try for $ENV{HOME} if we have it + if ( defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + ### DESPERATION SETS IN + + # We could use the desktop + SCOPE: { + local $@; + eval { + my $home = $class->my_desktop; + return $home if $home and -d $home; + }; + } + + # Desperation on any platform + SCOPE: { + # On some platforms getpwuid dies if called at all + local $SIG{'__DIE__'} = ''; + my $home = (getpwuid($<))[7]; + return $home if $home and -d $home; + } + + Carp::croak("Could not locate current user's home directory"); +} + +sub my_desktop { + my $class = shift; + + # Find the desktop via Mac::Files + local $SIG{'__DIE__'} = ''; + require Mac::Files; + my $home = Mac::Files::FindFolder( + Mac::Files::kOnSystemDisk(), + Mac::Files::kDesktopFolderType(), + ); + return $home if $home and -d $home; + + Carp::croak("Could not locate current user's desktop"); +} + + + + + +##################################################################### +# General User Methods + +sub users_home { + my ($class, $name) = @_; + + SCOPE: { + # On some platforms getpwnam dies if called at all + local $SIG{'__DIE__'} = ''; + my $home = (getpwnam($name))[7]; + return $home if defined $home and -d $home; + } + + Carp::croak("Failed to find home directory for user '$name'"); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/Unix.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/Unix.pm new file mode 100755 index 00000000000..640f64e7b26 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/Unix.pm @@ -0,0 +1,167 @@ +package File::HomeDir::Unix; + +# Unix-specific functionality + +use 5.00503; +use strict; +use Carp (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '0.89'; + @ISA = 'File::HomeDir::Driver'; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + my $home = $class->_my_home(@_); + + # On Unix in general, a non-existant home means "no home" + # For example, "nobody"-like users might use /nonexistant + if ( defined $home and ! -d $home ) { + $home = undef; + } + + return $home; +} + +sub _my_home { + my $class = shift; + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + # This is from the original code, but I'm guessing + # it means "login directory" and exists on some Unixes. + if ( exists $ENV{LOGDIR} and $ENV{LOGDIR} ) { + return $ENV{LOGDIR}; + } + + ### More-desperate methods + + # Light desperation on any (Unixish) platform + SCOPE: { + my $home = (getpwuid($<))[7]; + return $home if $home and -d $home; + } + + return undef; +} + +# On unix by default, everything is under the same folder +sub my_desktop { + shift->my_home; +} + +sub my_documents { + shift->my_home; +} + +sub my_data { + shift->my_home; +} + +sub my_music { + shift->my_home; +} + +sub my_pictures { + shift->my_home; +} + +sub my_videos { + shift->my_home; +} + + + + + +##################################################################### +# General User Methods + +sub users_home { + my ($class, $name) = @_; + + # IF and only if we have getpwuid support, and the + # name of the user is our own, shortcut to my_home. + # This is needed to handle HOME environment settings. + if ( $name eq getpwuid($<) ) { + return $class->my_home; + } + + SCOPE: { + my $home = (getpwnam($name))[7]; + return $home if $home and -d $home; + } + + return undef; +} + +sub users_desktop { + shift->users_home(@_); +} + +sub users_documents { + shift->users_home(@_); +} + +sub users_data { + shift->users_home(@_); +} + +sub users_music { + shift->users_home(@_); +} + +sub users_pictures { + shift->users_home(@_); +} + +sub users_videos { + shift->users_home(@_); +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Unix - find your home and other directories, on Unix + +=head1 DESCRIPTION + +This module provides implementations for determining common user +directories. In normal usage this module will always be +used via L<File::HomeDir>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /home/mylogin + + $desktop = File::HomeDir->my_desktop; # All of these will... + $docs = File::HomeDir->my_documents; # ...default to home... + $music = File::HomeDir->my_music; # ...directory at the... + $pics = File::HomeDir->my_pictures; # ...moment. + $videos = File::HomeDir->my_videos; # + $data = File::HomeDir->my_data; # + +=head1 TODO + +=over 4 + +=item * Add support for common unix desktop and data directories when using KDE / Gnome / ... + +=back diff --git a/Master/tlpkg/tlperl/lib/File/HomeDir/Windows.pm b/Master/tlpkg/tlperl/lib/File/HomeDir/Windows.pm new file mode 100755 index 00000000000..888ccc8b819 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/HomeDir/Windows.pm @@ -0,0 +1,176 @@ +package File::HomeDir::Windows; + +# Generalised implementation for the entire Windows family of operating +# systems. + +use 5.00503; +use strict; +use Carp (); +use File::Spec (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '0.89'; + @ISA = 'File::HomeDir::Driver'; +} + +sub CREATE () { 1 } + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # A lot of unix people and unix-derived tools rely on + # the ability to overload HOME. We will support it too + # so that they can replace raw HOME calls with File::HomeDir. + if ( exists $ENV{HOME} and $ENV{HOME} ) { + return $ENV{HOME}; + } + + # Do we have a user profile? + if ( exists $ENV{USERPROFILE} and $ENV{USERPROFILE} ) { + return $ENV{USERPROFILE}; + } + + # Some Windows use something like $ENV{HOME} + if ( exists $ENV{HOMEDRIVE} and exists $ENV{HOMEPATH} and $ENV{HOMEDRIVE} and $ENV{HOMEPATH} ) { + return File::Spec->catpath( + $ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '', + ); + } + + return undef; +} + +sub my_desktop { + my $class = shift; + + # The most correct way to find the desktop + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_DESKTOP(), CREATE); + return $dir if $dir and -d $dir; + } + + # MSWindows sets WINDIR, MS WinNT sets USERPROFILE. + foreach my $e ( 'USERPROFILE', 'WINDIR' ) { + next unless $ENV{$e}; + my $desktop = File::Spec->catdir($ENV{$e}, 'Desktop'); + return $desktop if $desktop and -d $desktop; + } + + # As a last resort, try some hard-wired values + foreach my $fixed ( + # The reason there are both types of slash here is because + # this set of paths has been kept from thethe original version + # of File::HomeDir::Win32 (before it was rewritten). + # I can only assume this is Cygwin-related stuff. + "C:\\windows\\desktop", + "C:\\win95\\desktop", + "C:/win95/desktop", + "C:/windows/desktop", + ) { + return $fixed if -d $fixed; + } + + return undef; +} + +sub my_documents { + my $class = shift; + + # The most correct way to find my documents + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_PERSONAL(), CREATE); + return $dir if $dir and -d $dir; + } + + return undef; +} + +sub my_data { + my $class = shift; + + # The most correct way to find my documents + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_LOCAL_APPDATA(), CREATE); + return $dir if $dir and -d $dir; + } + + return undef; +} + +sub my_music { + my $class = shift; + + # The most correct way to find my music + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_MYMUSIC(), CREATE); + return $dir if $dir and -d $dir; + } + + return undef; +} + +sub my_pictures { + my $class = shift; + + # The most correct way to find my pictures + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_MYPICTURES(), CREATE); + return $dir if $dir and -d $dir; + } + + return undef; +} + +sub my_videos { + my $class = shift; + + # The most correct way to find my videos + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_MYVIDEO(), CREATE); + return $dir if $dir and -d $dir; + } + + return undef; +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Windows - find your home and other directories, on Windows + +=head1 DESCRIPTION + +This module provides Windows-specific implementations for determining +common user directories. In normal usage this module will always be +used via L<File::HomeDir>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user (eg. using Windows XP Professional) + $home = File::HomeDir->my_home; # C:\Documents and Settings\mylogin + $desktop = File::HomeDir->my_desktop; # C:\Documents and Settings\mylogin\Desktop + $docs = File::HomeDir->my_documents; # C:\Documents and Settings\mylogin\My Documents + $music = File::HomeDir->my_music; # C:\Documents and Settings\mylogin\My Documents\My Music + $pics = File::HomeDir->my_pictures; # C:\Documents and Settings\mylogin\My Documents\My Pictures + $videos = File::HomeDir->my_videos; # C:\Documents and Settings\mylogin\My Documents\My Video + $data = File::HomeDir->my_data; # C:\Documents and Settings\mylogin\Local Settings\Application Data diff --git a/Master/tlpkg/tlperl/lib/File/Listing.pm b/Master/tlpkg/tlperl/lib/File/Listing.pm new file mode 100755 index 00000000000..85d44ac8827 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Listing.pm @@ -0,0 +1,406 @@ +package File::Listing; + +sub Version { $VERSION; } +$VERSION = "5.814"; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(parse_dir); + +use strict; + +use Carp (); +use HTTP::Date qw(str2time); + + + +sub parse_dir ($;$$$) +{ + my($dir, $tz, $fstype, $error) = @_; + + $fstype ||= 'unix'; + $fstype = "File::Listing::" . lc $fstype; + + my @args = $_[0]; + push(@args, $tz) if(@_ >= 2); + push(@args, $error) if(@_ >= 4); + + $fstype->parse(@args); +} + + +sub line { Carp::croak("Not implemented yet"); } +sub init { } # Dummy sub + + +sub file_mode ($) +{ + # This routine was originally borrowed from Graham Barr's + # Net::FTP package. + + local $_ = shift; + my $mode = 0; + my($type,$ch); + + s/^(.)// and $type = $1; + + while (/(.)/g) { + $mode <<= 1; + $mode |= 1 if $1 ne "-" && + $1 ne 'S' && + $1 ne 't' && + $1 ne 'T'; + } + + $type eq "d" and $mode |= 0040000 or # Directory + $type eq "l" and $mode |= 0120000 or # Symbolic Link + $mode |= 0100000; # Regular File + + $mode |= 0004000 if /^...s....../i; + $mode |= 0002000 if /^......s.../i; + $mode |= 0001000 if /^.........t/i; + + $mode; +} + + +sub parse +{ + my($pkg, $dir, $tz, $error) = @_; + + # First let's try to determine what kind of dir parameter we have + # received. We allow both listings, reference to arrays and + # file handles to read from. + + if (ref($dir) eq 'ARRAY') { + # Already splitted up + } + elsif (ref($dir) eq 'GLOB') { + # A file handle + } + elsif (ref($dir)) { + Carp::croak("Illegal argument to parse_dir()"); + } + elsif ($dir =~ /^\*\w+(::\w+)+$/) { + # This scalar looks like a file handle, so we assume it is + } + else { + # A normal scalar listing + $dir = [ split(/\n/, $dir) ]; + } + + $pkg->init(); + + my @files = (); + if (ref($dir) eq 'ARRAY') { + for (@$dir) { + push(@files, $pkg->line($_, $tz, $error)); + } + } + else { + local($_); + while (<$dir>) { + chomp; + push(@files, $pkg->line($_, $tz, $error)); + } + } + wantarray ? @files : \@files; +} + + + +package File::Listing::unix; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir @ISA); + +@ISA = qw(File::Listing); + + + +sub init +{ + $curdir = ''; +} + + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + #study; + + my ($kind, $size, $date, $name); + if (($kind, $size, $date, $name) = + /^([\-FlrwxsStTdD]{10}) # Type and permission bits + .* # Graps + \D(\d+) # File size + \s+ # Some space + (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date + \s+ # Some more space + (.*)$ # File name + /x ) + + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) { + $name = $1; + $type = "l $2"; + } + elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file + $type = 'f'; + } + elsif ($kind =~ /^[dD]/) { + $type = 'd'; + $size = undef; # Don't believe the reported size + } + return [$name, $type, $size, str2time($date, $tz), + File::Listing::file_mode($kind)]; + + } + elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) { + my $dir = $1; + return () if $dir eq '.'; + $curdir = $dir; + return (); + } + elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) { + return (); + } + elsif (/not found/ || # OSF1, HPUX, and SunOS return + # "$file not found" + /No such file/ || # IRIX returns + # "UX:ls: ERROR: Cannot access $file: No such file or directory" + # Solaris returns + # "$file: No such file or directory" + /cannot find/ # Windows NT returns + # "The system cannot find the path specified." + ) { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Error: $_\n" if $error eq 'warn'; + return (); + } + elsif ($_ eq '') { # AIX, and Linux return nothing + return () unless defined $error; + &$error("No such file or directory") if ref($error) eq 'CODE'; + warn "Warning: No such file or directory\n" if $error eq 'warn'; + return (); + } + else { + # parse failed, check if the dosftp parse understands it + File::Listing::dosftp->init(); + return(File::Listing::dosftp->line($_,$tz,$error)); + } + +} + + + +package File::Listing::dosftp; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir @ISA); + +@ISA = qw(File::Listing); + + + +sub init +{ + $curdir = ''; +} + + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + + my ($date, $size_or_dir, $name, $size); + + # 02-05-96 10:48AM 1415 src.slf + # 09-10-96 09:18AM <DIR> sl_util + if (($date, $size_or_dir, $name) = + /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info + \s+ # Some space + (<\w{3}>|\d+) # Dir or Size + \s+ # Some more space + (.+)$ # File name + /x ) + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($size_or_dir eq '<DIR>') { + $type = "d"; + $size = ""; # directories have no size in the pc listing + } + else { + $type = 'f'; + $size = $size_or_dir; + } + return [$name, $type, $size, str2time($date, $tz), undef]; + } + else { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Can't parse: $_\n" if $error eq 'warn'; + return (); + } + +} + + + +package File::Listing::vms; +@File::Listing::vms::ISA = qw(File::Listing); + +package File::Listing::netware; +@File::Listing::netware::ISA = qw(File::Listing); + + + +package File::Listing::apache; + +use vars qw(@ISA); + +@ISA = qw(File::Listing); + + +sub init { } + + +sub line { + shift; # package name + local($_) = shift; + my($tz, $error) = @_; # ignored for now... + + if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kM]?|-))!i) { + my($filename, $filesize) = ($1, $7); + my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6); + + $filesize = 0 if $filesize eq '-'; + if ($filesize =~ s/k$//i) { + $filesize *= 1024; + } + elsif ($filesize =~ s/M$//) { + $filesize *= 1024*1024; + } + elsif ($filesize =~ s/G$//) { + $filesize *= 1024*1024*1024; + } + $filesize = int $filesize; + + require Time::Local; + my $filetime = Time::Local::timelocal(0,$M,$H,$d,_monthabbrev_number($m)-1,_guess_year($y)-1900); + my $filetype = ($filename =~ s|/$|| ? "d" : "f"); + return [$filename, $filetype, $filesize, $filetime, undef]; + } + + return (); +} + + +sub _guess_year { + my $y = shift; + if ($y >= 90) { + $y = 1900+$y; + } + elsif ($y < 100) { + $y = 2000+$y; + } + $y; +} + + +sub _monthabbrev_number { + my $mon = shift; + +{'Jan' => 1, + 'Feb' => 2, + 'Mar' => 3, + 'Apr' => 4, + 'May' => 5, + 'Jun' => 6, + 'Jul' => 7, + 'Aug' => 8, + 'Sep' => 9, + 'Oct' => 10, + 'Nov' => 11, + 'Dec' => 12, + }->{$mon}; +} + + +1; + +__END__ + +=head1 NAME + +File::Listing - parse directory listing + +=head1 SYNOPSIS + + use File::Listing qw(parse_dir); + $ENV{LANG} = "C"; # dates in non-English locales not supported + for (parse_dir(`ls -l`)) { + ($name, $type, $size, $mtime, $mode) = @$_; + next if $type ne 'f'; # plain file + #... + } + + # directory listing can also be read from a file + open(LISTING, "zcat ls-lR.gz|"); + $dir = parse_dir(\*LISTING, '+0000'); + +=head1 DESCRIPTION + +This module exports a single function called parse_dir(), which can be +used to parse directory listings. + +The first parameter to parse_dir() is the directory listing to parse. +It can be a scalar, a reference to an array of directory lines or a +glob representing a filehandle to read the directory listing from. + +The second parameter is the time zone to use when parsing time stamps +in the listing. If this value is undefined, then the local time zone is +assumed. + +The third parameter is the type of listing to assume. Currently +supported formats are 'unix', 'apache' and 'dosftp'. The default +value 'unix'. Ideally, the listing type should be determined +automatically. + +The fourth parameter specifies how unparseable lines should be treated. +Values can be 'ignore', 'warn' or a code reference. Warn means that +the perl warn() function will be called. If a code reference is +passed, then this routine will be called and the return value from it +will be incorporated in the listing. The default is 'ignore'. + +Only the first parameter is mandatory. + +The return value from parse_dir() is a list of directory entries. In +a scalar context the return value is a reference to the list. The +directory entries are represented by an array consisting of [ +$filename, $filetype, $filesize, $filetime, $filemode ]. The +$filetype value is one of the letters 'f', 'd', 'l' or '?'. The +$filetime value is the seconds since Jan 1, 1970. The +$filemode is a bitmask like the mode returned by stat(). + +=head1 CREDITS + +Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and +Net::FTP's parse_dir (Graham Barr). diff --git a/Master/tlpkg/tlperl/lib/File/Path.pm b/Master/tlpkg/tlperl/lib/File/Path.pm new file mode 100755 index 00000000000..387cdb19cb1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Path.pm @@ -0,0 +1,982 @@ +package File::Path; + +use 5.005_04; +use strict; + +use Cwd 'getcwd'; +use File::Basename (); +use File::Spec (); + +BEGIN { + if ($] < 5.006) { + # can't say 'opendir my $dh, $dirname' + # need to initialise $dh + eval "use Symbol"; + } +} + +use Exporter (); +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +$VERSION = '2.08'; +@ISA = qw(Exporter); +@EXPORT = qw(mkpath rmtree); +@EXPORT_OK = qw(make_path remove_tree); + +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 = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); + +# Unix-like systems need to stat each directory in order to detect +# race condition. MS-Windows is immune to this particular attack. +my $Need_Stat_Check = !($^O eq 'MSWin32'); + +sub _carp { + require Carp; + goto &Carp::carp; +} + +sub _croak { + require Carp; + goto &Carp::croak; +} + +sub _error { + my $arg = shift; + my $message = shift; + my $object = shift; + + if ($arg->{error}) { + $object = '' unless defined $object; + $message .= ": $!" if $!; + push @{${$arg->{error}}}, {$object => $message}; + } + else { + _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); + } +} + +sub make_path { + push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + goto &mkpath; +} + +sub mkpath { + my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + + my $arg; + my $paths; + + if ($old_style) { + my ($verbose, $mode); + ($paths, $verbose, $mode) = @_; + $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + $arg->{verbose} = $verbose; + $arg->{mode} = defined $mode ? $mode : 0777; + } + else { + $arg = pop @_; + $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; + $arg->{mode} = 0777 unless exists $arg->{mode}; + ${$arg->{error}} = [] if exists $arg->{error}; + $arg->{owner} = delete $arg->{user} if exists $arg->{user}; + $arg->{owner} = delete $arg->{uid} if exists $arg->{uid}; + if (exists $arg->{owner} and $arg->{owner} =~ /\D/) { + my $uid = (getpwnam $arg->{owner})[2]; + if (defined $uid) { + $arg->{owner} = $uid; + } + else { + _error($arg, "unable to map $arg->{owner} to a uid, ownership not changed"); + delete $arg->{owner}; + } + } + if (exists $arg->{group} and $arg->{group} =~ /\D/) { + my $gid = (getgrnam $arg->{group})[2]; + if (defined $gid) { + $arg->{group} = $gid; + } + else { + _error($arg, "unable to map $arg->{group} to a gid, group ownership not changed"); + delete $arg->{group}; + } + } + if (exists $arg->{owner} and not exists $arg->{group}) { + $arg->{group} = -1; # chown will leave group unchanged + } + if (exists $arg->{group} and not exists $arg->{owner}) { + $arg->{owner} = -1; # chown will leave owner unchanged + } + $paths = [@_]; + } + return _mkpath($arg, $paths); +} + +sub _mkpath { + my $arg = shift; + my $paths = shift; + + my(@created,$path); + foreach $path (@$paths) { + next unless defined($path) and length($path); + $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); + } + next if -d $path; + my $parent = File::Basename::dirname($path); + unless (-d $parent or $path eq $parent) { + push(@created,_mkpath($arg, [$parent])); + } + print "mkdir $path\n" if $arg->{verbose}; + if (mkdir($path,$arg->{mode})) { + push(@created, $path); + if (exists $arg->{owner}) { + # NB: $arg->{group} guaranteed to be set during initialisation + if (!chown $arg->{owner}, $arg->{group}, $path) { + _error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}"); + } + } + } + else { + my $save_bang = $!; + my ($e, $e1) = ($save_bang, $^E); + $e .= "; $e1" if $e ne $e1; + # allow for another process to have created it meanwhile + if (!-d $path) { + $! = $save_bang; + if ($arg->{error}) { + push @{${$arg->{error}}}, {$path => $e}; + } + else { + _croak("mkdir $path: $e"); + } + } + } + } + return @created; +} + +sub remove_tree { + push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + goto &rmtree; +} + +sub _is_subdir { + my($dir, $test) = @_; + + my($dv, $dd) = File::Spec->splitpath($dir, 1); + my($tv, $td) = File::Spec->splitpath($test, 1); + + # not on same volume + return 0 if $dv ne $tv; + + my @d = File::Spec->splitdir($dd); + my @t = File::Spec->splitdir($td); + + # @t can't be a subdir if it's shorter than @d + return 0 if @t < @d; + + return join('/', @d) eq join('/', splice @t, 0, +@d); +} + +sub rmtree { + my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + + my $arg; + my $paths; + + if ($old_style) { + my ($verbose, $safe); + ($paths, $verbose, $safe) = @_; + $arg->{verbose} = $verbose; + $arg->{safe} = defined $safe ? $safe : 0; + + if (defined($paths) and length($paths)) { + $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + } + else { + _carp ("No root path(s) specified\n"); + return 0; + } + } + else { + $arg = pop @_; + ${$arg->{error}} = [] if exists $arg->{error}; + ${$arg->{result}} = [] if exists $arg->{result}; + $paths = [@_]; + } + + $arg->{prefix} = ''; + $arg->{depth} = 0; + + my @clean_path; + $arg->{cwd} = getcwd() or do { + _error($arg, "cannot fetch initial working directory"); + return 0; + }; + for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint + + for my $p (@$paths) { + # need to fixup case and map \ to / on Windows + my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p; + my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd}; + my $ortho_root_length = length($ortho_root); + $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']' + if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) { + local $! = 0; + _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p); + next; + } + + if ($Is_MacOS) { + $p = ":$p" unless $p =~ /:/; + $p .= ":" unless $p =~ /:\z/; + } + elsif ($^O eq 'MSWin32') { + $p =~ s{[/\\]\z}{}; + } + else { + $p =~ s{/\z}{}; + } + push @clean_path, $p; + } + + @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do { + _error($arg, "cannot stat initial working directory", $arg->{cwd}); + return 0; + }; + + return _rmtree($arg, \@clean_path); +} + +sub _rmtree { + my $arg = shift; + my $paths = shift; + + my $count = 0; + my $curdir = File::Spec->curdir(); + my $updir = File::Spec->updir(); + + my (@files, $root); + ROOT_DIR: + foreach $root (@$paths) { + # since we chdir into each directory, it may not be obvious + # to figure out where we are if we generate a message about + # a file name. We therefore construct a semi-canonical + # filename, anchored from the directory being unlinked (as + # opposed to being truly canonical, anchored from the root (/). + + my $canon = $arg->{prefix} + ? File::Spec->catfile($arg->{prefix}, $root) + : $root + ; + + my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; + + if ( -d _ ) { + $root = VMS::Filespec::pathify($root) if $Is_VMS; + + if (!chdir($root)) { + # see if we can escalate privileges to get in + # (e.g. funny protection mask such as -w- instead of rwx) + $perm &= 07777; + my $nperm = $perm | 0700; + if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { + _error($arg, "cannot make child directory read-write-exec", $canon); + next ROOT_DIR; + } + elsif (!chdir($root)) { + _error($arg, "cannot chdir to child", $canon); + next ROOT_DIR; + } + } + + my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do { + _error($arg, "cannot stat current working directory", $canon); + next ROOT_DIR; + }; + + if ($Need_Stat_Check) { + ($ldev eq $cur_dev and $lino eq $cur_inode) + or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); + } + + $perm &= 07777; # don't forget setuid, setgid, sticky bits + my $nperm = $perm | 0700; + + # 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 + + if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) { + _error($arg, "cannot make directory read+writeable", $canon); + $nperm = $perm; + } + + my $d; + $d = gensym() if $] < 5.006; + if (!opendir $d, $curdir) { + _error($arg, "cannot opendir", $canon); + @files = (); + } + else { + no strict 'refs'; + if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { + # Blindly untaint dir names if taint mode is + # active, or any perl < 5.006 + @files = map { /\A(.*)\z/s; $1 } readdir $d; + } + else { + @files = readdir $d; + } + closedir $d; + } + + if ($Is_VMS) { + # Deleting large numbers of files from VMS Files-11 + # filesystems is faster if done in reverse ASCIIbetical order. + # include '.' to '.;' from blead patch #31775 + @files = map {$_ eq '.' ? '.;' : $_} reverse @files; + ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//; + } + + @files = grep {$_ ne $updir and $_ ne $curdir} @files; + + if (@files) { + # remove the contained files before the directory itself + my $narg = {%$arg}; + @{$narg}{qw(device inode cwd prefix depth)} + = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1); + $count += _rmtree($narg, \@files); + } + + # restore directory permissions of required now (in case the rmdir + # below fails), while we are still in the directory and may do so + # without a race via '.' + if ($nperm != $perm and not chmod($perm, $curdir)) { + _error($arg, "cannot reset chmod", $canon); + } + + # don't leave the client code in an unexpected directory + chdir($arg->{cwd}) + or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); + + # ensure that a chdir upwards didn't take us somewhere other + # than we expected (see CVE-2002-0435) + ($cur_dev, $cur_inode) = (stat $curdir)[0,1] + or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); + + if ($Need_Stat_Check) { + ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode) + or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); + } + + if ($arg->{depth} or !$arg->{keep_root}) { + if ($arg->{safe} && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $arg->{verbose}; + next ROOT_DIR; + } + if ($Force_Writeable and !chmod $perm | 0700, $root) { + _error($arg, "cannot make directory writeable", $canon); + } + print "rmdir $root\n" if $arg->{verbose}; + if (rmdir $root) { + push @{${$arg->{result}}}, $root if $arg->{result}; + ++$count; + } + else { + _error($arg, "cannot remove directory", $canon); + if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + ) { + _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + } + } + } + } + else { + # not a directory + $root = VMS::Filespec::vmsify("./$root") + if $Is_VMS + && !File::Spec->file_name_is_absolute($root) + && ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax + + if ($arg->{safe} && + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { + print "skipped $root\n" if $arg->{verbose}; + next ROOT_DIR; + } + + my $nperm = $perm & 07777 | 0600; + if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) { + _error($arg, "cannot make file writeable", $canon); + } + print "unlink $canon\n" if $arg->{verbose}; + # delete all versions under VMS + for (;;) { + if (unlink $root) { + push @{${$arg->{result}}}, $root if $arg->{result}; + } + else { + _error($arg, "cannot unlink file", $canon); + $Force_Writeable and chmod($perm, $root) or + _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + return $count; +} + +sub _slash_lc { + # fix up slashes and case on MSWin32 so that we can determine that + # c:\path\to\dir is underneath C:/Path/To + my $path = shift; + $path =~ tr{\\}{/}; + return lc($path); +} + +1; +__END__ + +=head1 NAME + +File::Path - Create or remove directory trees + +=head1 VERSION + +This document describes version 2.08 of File::Path, released +2009-10-04. + +=head1 SYNOPSIS + + use File::Path qw(make_path remove_tree); + + make_path('foo/bar/baz', '/zug/zwang'); + make_path('foo/bar/baz', '/zug/zwang', { + verbose => 1, + mode => 0711, + }); + + remove_tree('foo/bar/baz', '/zug/zwang'); + remove_tree('foo/bar/baz', '/zug/zwang', { + verbose => 1, + error => \my $err_list, + }); + + # legacy (interface promoted before v2.00) + mkpath('/foo/bar/baz'); + mkpath('/foo/bar/baz', 1, 0711); + mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + rmtree('foo/bar/baz', 1, 1); + rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); + + # legacy (interface promoted before v2.06) + mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + +=head1 DESCRIPTION + +This module provide a convenient way to create directories of +arbitrary depth and to delete an entire directory subtree from the +filesystem. + +The following functions are provided: + +=over + +=item make_path( $dir1, $dir2, .... ) + +=item make_path( $dir1, $dir2, ...., \%opts ) + +The C<make_path> function creates the given directories if they don't +exists before, much like the Unix command C<mkdir -p>. + +The function accepts a list of directories to be created. Its +behaviour may be tuned by an optional hashref appearing as the last +parameter on the call. + +The function returns the list of directories actually created during +the call; in scalar context the number of directories created. + +The following keys are recognised in the option hash: + +=over + +=item mode => $num + +The numeric permissions mode to apply to each created directory +(defaults to 0777), to be modified by the current C<umask>. If the +directory already exists (and thus does not need to be created), +the permissions will not be modified. + +C<mask> is recognised as an alias for this parameter. + +=item verbose => $bool + +If present, will cause C<make_path> to print the name of each directory +as it is created. By default nothing is printed. + +=item error => \$err + +If present, it should be a reference to a scalar. +This scalar will be made to reference an array, which will +be used to store any errors that are encountered. See the L</"ERROR +HANDLING"> section for more information. + +If this parameter is not used, certain error conditions may raise +a fatal error that will cause the program will halt, unless trapped +in an C<eval> block. + +=item owner => $owner + +=item user => $owner + +=item uid => $owner + +If present, will cause any created directory to be owned by C<$owner>. +If the value is numeric, it will be interpreted as a uid, otherwise +as username is assumed. An error will be issued if the username cannot be +mapped to a uid, or the uid does not exist, or the process lacks the +privileges to change ownership. + +Ownwership of directories that already exist will not be changed. + +C<user> and C<uid> are aliases of C<owner>. + +=item group => $group + +If present, will cause any created directory to be owned by the group C<$group>. +If the value is numeric, it will be interpreted as a gid, otherwise +as group name is assumed. An error will be issued if the group name cannot be +mapped to a gid, or the gid does not exist, or the process lacks the +privileges to change group ownership. + +Group ownwership of directories that already exist will not be changed. + + make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'}; + +=back + +=item mkpath( $dir ) + +=item mkpath( $dir, $verbose, $mode ) + +=item mkpath( [$dir1, $dir2,...], $verbose, $mode ) + +=item mkpath( $dir1, $dir2,..., \%opt ) + +The mkpath() function provide the legacy interface of make_path() with +a different interpretation of the arguments passed. The behaviour and +return value of the function is otherwise identical to make_path(). + +=item remove_tree( $dir1, $dir2, .... ) + +=item remove_tree( $dir1, $dir2, ...., \%opts ) + +The C<remove_tree> function deletes the given directories and any +files and subdirectories they might contain, much like the Unix +command C<rm -r> or C<del /s> on Windows. + +The function accepts a list of directories to be +removed. Its behaviour may be tuned by an optional hashref +appearing as the last parameter on the call. + +The functions returns the number of files successfully deleted. + +The following keys are recognised in the option hash: + +=over + +=item verbose => $bool + +If present, will cause C<remove_tree> to print the name of each file as +it is unlinked. By default nothing is printed. + +=item safe => $bool + +When set to a true value, will cause C<remove_tree> to skip the files +for which the process lacks the required privileges needed to delete +files, such as delete privileges on VMS. In other words, the code +will make no attempt to alter file permissions. Thus, if the process +is interrupted, no filesystem object will be left in a more +permissive mode. + +=item keep_root => $bool + +When set to a true value, will cause all files and subdirectories +to be removed, except the initially specified directories. This comes +in handy when cleaning out an application's scratch directory. + + remove_tree( '/tmp', {keep_root => 1} ); + +=item result => \$res + +If present, it should be a reference to a scalar. +This scalar will be made to reference an array, which will +be used to store all files and directories unlinked +during the call. If nothing is unlinked, the array will be empty. + + remove_tree( '/tmp', {result => \my $list} ); + print "unlinked $_\n" for @$list; + +This is a useful alternative to the C<verbose> key. + +=item error => \$err + +If present, it should be a reference to a scalar. +This scalar will be made to reference an array, which will +be used to store any errors that are encountered. See the L</"ERROR +HANDLING"> section for more information. + +Removing things is a much more dangerous proposition than +creating things. As such, there are certain conditions that +C<remove_tree> may encounter that are so dangerous that the only +sane action left is to kill the program. + +Use C<error> to trap all that is reasonable (problems with +permissions and the like), and let it die if things get out +of hand. This is the safest course of action. + +=back + +=item rmtree( $dir ) + +=item rmtree( $dir, $verbose, $safe ) + +=item rmtree( [$dir1, $dir2,...], $verbose, $safe ) + +=item rmtree( $dir1, $dir2,..., \%opt ) + +The rmtree() function provide the legacy interface of remove_tree() +with a different interpretation of the arguments passed. The behaviour +and return value of the function is otherwise identical to +remove_tree(). + +=back + +=head2 ERROR HANDLING + +=over 4 + +=item B<NOTE:> + +The following error handling mechanism is considered +experimental and is subject to change pending feedback from +users. + +=back + +If C<make_path> or C<remove_tree> encounter an error, a diagnostic +message will be printed to C<STDERR> via C<carp> (for non-fatal +errors), or via C<croak> (for fatal errors). + +If this behaviour is not desirable, the C<error> attribute may be +used to hold a reference to a variable, which will be used to store +the diagnostics. The variable is made a reference to an array of hash +references. Each hash contain a single key/value pair where the key +is the name of the file, and the value is the error message (including +the contents of C<$!> when appropriate). If a general error is +encountered the diagnostic key will be empty. + +An example usage looks like: + + remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} ); + if (@$err) { + for my $diag (@$err) { + my ($file, $message) = %$diag; + if ($file eq '') { + print "general error: $message\n"; + } + else { + print "problem unlinking $file: $message\n"; + } + } + } + else { + print "No error encountered\n"; + } + +Note that if no errors are encountered, C<$err> will reference an +empty array. This means that C<$err> will always end up TRUE; so you +need to test C<@$err> to determine if errors occured. + +=head2 NOTES + +C<File::Path> blindly exports C<mkpath> and C<rmtree> into the +current namespace. These days, this is considered bad style, but +to change it now would break too much code. Nonetheless, you are +invited to specify what it is you are expecting to use: + + use File::Path 'rmtree'; + +The routines C<make_path> and C<remove_tree> are B<not> exported +by default. You must specify which ones you want to use. + + use File::Path 'remove_tree'; + +Note that a side-effect of the above is that C<mkpath> and C<rmtree> +are no longer exported at all. This is due to the way the C<Exporter> +module works. If you are migrating a codebase to use the new +interface, you will have to list everything explicitly. But that's +just good practice anyway. + + use File::Path qw(remove_tree rmtree); + +=head3 API CHANGES + +The API was changed in the 2.0 branch. For a time, C<mkpath> and +C<rmtree> tried, unsuccessfully, to deal with the two different +calling mechanisms. This approach was considered a failure. + +The new semantics are now only available with C<make_path> and +C<remove_tree>. The old semantics are only available through +C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade +to at least 2.08 in order to avoid surprises. + +=head3 SECURITY CONSIDERATIONS + +There were race conditions 1.x implementations of File::Path's +C<rmtree> function (although sometimes patched depending on the OS +distribution or platform). The 2.0 version contains code to avoid the +problem mentioned in CVE-2002-0435. + +See the following pages for more information: + + http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 + http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html + http://www.debian.org/security/2005/dsa-696 + +Additionally, unless the C<safe> parameter is set (or the +third parameter in the traditional interface is TRUE), should a +C<remove_tree> be interrupted, files that were originally in read-only +mode may now have their permissions set to a read-write (or "delete +OK") mode. + +=head1 DIAGNOSTICS + +FATAL errors will cause the program to halt (C<croak>), since the +problem is so severe that it would be dangerous to continue. (This +can always be trapped with C<eval>, but it's not a good idea. Under +the circumstances, dying is the best thing to do). + +SEVERE errors may be trapped using the modern interface. If the +they are not trapped, or the old interface is used, such an error +will cause the program will halt. + +All other errors may be trapped using the modern interface, otherwise +they will be C<carp>ed about. Program execution will not be halted. + +=over 4 + +=item mkdir [path]: [errmsg] (SEVERE) + +C<make_path> was unable to create the path. Probably some sort of +permissions error at the point of departure, or insufficient resources +(such as free inodes on Unix). + +=item No root path(s) specified + +C<make_path> was not given any paths to create. This message is only +emitted if the routine is called with the traditional interface. +The modern interface will remain silent if given nothing to do. + +=item No such file or directory + +On Windows, if C<make_path> gives you this warning, it may mean that +you have exceeded your filesystem's maximum path length. + +=item cannot fetch initial working directory: [errmsg] + +C<remove_tree> attempted to determine the initial directory by calling +C<Cwd::getcwd>, but the call failed for some reason. No attempt +will be made to delete anything. + +=item cannot stat initial working directory: [errmsg] + +C<remove_tree> attempted to stat the initial directory (after having +successfully obtained its name via C<getcwd>), however, the call +failed for some reason. No attempt will be made to delete anything. + +=item cannot chdir to [dir]: [errmsg] + +C<remove_tree> attempted to set the working directory in order to +begin deleting the objects therein, but was unsuccessful. This is +usually a permissions issue. The routine will continue to delete +other things, but this directory will be left intact. + +=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) + +C<remove_tree> recorded the device and inode of a directory, and then +moved into it. It then performed a C<stat> on the current directory +and detected that the device and inode were no longer the same. As +this is at the heart of the race condition problem, the program +will die at this point. + +=item cannot make directory [dir] read+writeable: [errmsg] + +C<remove_tree> attempted to change the permissions on the current directory +to ensure that subsequent unlinkings would not run into problems, +but was unable to do so. The permissions remain as they were, and +the program will carry on, doing the best it can. + +=item cannot read [dir]: [errmsg] + +C<remove_tree> tried to read the contents of the directory in order +to acquire the names of the directory entries to be unlinked, but +was unsuccessful. This is usually a permissions issue. The +program will continue, but the files in this directory will remain +after the call. + +=item cannot reset chmod [dir]: [errmsg] + +C<remove_tree>, after having deleted everything in a directory, attempted +to restore its permissions to the original state but failed. The +directory may wind up being left behind. + +=item cannot remove [dir] when cwd is [dir] + +The current working directory of the program is F</some/path/to/here> +and you are attempting to remove an ancestor, such as F</some/path>. +The directory tree is left untouched. + +The solution is to C<chdir> out of the child directory to a place +outside the directory tree to be removed. + +=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL) + +C<remove_tree>, after having deleted everything and restored the permissions +of a directory, was unable to chdir back to the parent. The program +halts to avoid a race condition from occurring. + +=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) + +C<remove_tree> was unable to stat the parent directory after have returned +from the child. Since there is no way of knowing if we returned to +where we think we should be (by comparing device and inode) the only +way out is to C<croak>. + +=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) + +When C<remove_tree> returned from deleting files in a child directory, a +check revealed that the parent directory it returned to wasn't the one +it started out from. This is considered a sign of malicious activity. + +=item cannot make directory [dir] writeable: [errmsg] + +Just before removing a directory (after having successfully removed +everything it contained), C<remove_tree> attempted to set the permissions +on the directory to ensure it could be removed and failed. Program +execution continues, but the directory may possibly not be deleted. + +=item cannot remove directory [dir]: [errmsg] + +C<remove_tree> attempted to remove a directory, but failed. This may because +some objects that were unable to be removed remain in the directory, or +a permissions issue. The directory will be left behind. + +=item cannot restore permissions of [dir] to [0nnn]: [errmsg] + +After having failed to remove a directory, C<remove_tree> was unable to +restore its permissions from a permissive state back to a possibly +more restrictive setting. (Permissions given in octal). + +=item cannot make file [file] writeable: [errmsg] + +C<remove_tree> attempted to force the permissions of a file to ensure it +could be deleted, but failed to do so. It will, however, still attempt +to unlink the file. + +=item cannot unlink file [file]: [errmsg] + +C<remove_tree> failed to remove a file. Probably a permissions issue. + +=item cannot restore permissions of [file] to [0nnn]: [errmsg] + +After having failed to remove a file, C<remove_tree> was also unable +to restore the permissions on the file to a possibly less permissive +setting. (Permissions given in octal). + +=item unable to map [owner] to a uid, ownership not changed"); + +C<make_path> was instructed to give the ownership of created +directories to the symbolic name [owner], but C<getpwnam> did +not return the corresponding numeric uid. The directory will +be created, but ownership will not be changed. + +=item unable to map [group] to a gid, group ownership not changed + +C<make_path> was instructed to give the group ownership of created +directories to the symbolic name [group], but C<getgrnam> did +not return the corresponding numeric gid. The directory will +be created, but group ownership will not be changed. + +=back + +=head1 SEE ALSO + +=over 4 + +=item * + +L<File::Remove> + +Allows files and directories to be moved to the Trashcan/Recycle +Bin (where they may later be restored if necessary) if the operating +system supports such functionality. This feature may one day be +made available directly in C<File::Path>. + +=item * + +L<File::Find::Rule> + +When removing directory trees, if you want to examine each file to +decide whether to delete it (and possibly leaving large swathes +alone), F<File::Find::Rule> offers a convenient and flexible approach +to examining directory trees. + +=back + +=head1 BUGS + +Please report all bugs on the RT queue: + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> + +=head1 ACKNOWLEDGEMENTS + +Paul Szabo identified the race condition originally, and Brendan +O'Dea wrote an implementation for Debian that addressed the problem. +That code was used as a basis for the current code. Their efforts +are greatly appreciated. + +Gisle Aas made a number of improvements to the documentation for +2.07 and his advice and assistance is also greatly appreciated. + +=head1 AUTHORS + +Tim Bunce and Charles Bailey. Currently maintained by David Landgren +<F<david@landgren.net>>. + +=head1 COPYRIGHT + +This module is copyright (C) Charles Bailey, Tim Bunce and +David Landgren 1995-2009. All rights reserved. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/Remove.pm b/Master/tlpkg/tlperl/lib/File/Remove.pm new file mode 100755 index 00000000000..15df470cf47 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Remove.pm @@ -0,0 +1,329 @@ +package File::Remove; + +use 5.005; +use strict; + +use vars qw{$VERSION @ISA @EXPORT_OK}; +use vars qw{$debug $unlink $rmdir}; +BEGIN { + $VERSION = '1.42'; + @ISA = qw{ Exporter}; + @EXPORT_OK = qw{ remove rm clear trash }; +} + +# If we ever need a Mac::Glue object we will want to cache it. +my $glue; + +use File::Spec (); +use File::Path (); +use File::Glob (); + +sub expand (@) { + map { -e $_ ? $_ : File::Glob::bsd_glob($_) } @_; +} + +# $debug variable must be set before loading File::Remove. +# Convert to a constant to allow debugging code to be pruned out. +use constant DEBUG => !! $debug; + +# Are we on VMS? +# If so copy File::Path and assume VMS::Filespec is loaded +use constant IS_VMS => !! ( $^O eq 'VMS' ); + +# Are we on Mac? +# If so we'll need to do some special trash work +use constant IS_MAC => !! ( $^O eq 'darwin' ); + +# Are we on Win32? +# If so write permissions does not imply deletion permissions +use constant IS_WIN32 => !! ( $^O =~ /^MSWin/ or $^O eq 'cygwin' ); + + + + + +##################################################################### +# Main Functions + +my @END_DELETE = (); + +sub clear (@) { + my @files = expand( @_ ); + + # Do the initial deletion + foreach my $file ( @files ) { + next unless -e $file; + remove( \1, $file ); + } + + # Delete again at END-time + push @END_DELETE, @files; +} + +END { + foreach my $file ( @END_DELETE ) { + next unless -e $file; + remove( \1, $file ); + } +} + +# acts like unlink would until given a directory as an argument, then +# it acts like rm -rf ;) unless the recursive arg is zero which it is by +# default +sub remove (@) { + my $recursive = (ref $_[0] eq 'SCALAR') ? shift : \0; + my @files = expand(@_); + + # Iterate over the files + my @removes; + foreach my $path ( @files ) { + # need to check for symlink first + # could be pointing to nonexisting/non-readable destination + if ( -l $path ) { + print "link: $path\n" if DEBUG; + if ( $unlink ? $unlink->($path) : unlink($path) ) { + push @removes, $path; + } + next; + } + unless ( -e $path ) { + print "missing: $path\n" if DEBUG; + push @removes, $path; # Say we deleted it + next; + } + my $can_delete; + if ( IS_VMS ) { + $can_delete = VMS::Filespec::candelete($path); + } elsif ( IS_WIN32 ) { + # Assume we can delete it for the moment + $can_delete = 1; + } elsif ( -w $path ) { + # We have write permissions already + $can_delete = 1; + } elsif ( $< == 0 ) { + # Unixy and root + $can_delete = 1; + } elsif ( (lstat($path))[4] == $< ) { + # I own the file + $can_delete = 1; + } else { + # I don't think we can delete it + $can_delete = 0; + } + unless ( $can_delete ) { + print "nowrite: $path\n" if DEBUG; + next; + } + + if ( -f $path ) { + print "file: $path\n" if DEBUG; + unless ( -w $path ) { + # Make the file writable (implementation from File::Path) + (undef, undef, my $rp) = lstat $path or next; + $rp &= 07777; # Don't forget setuid, setgid, sticky bits + $rp |= 0600; # Turn on user read/write + chmod $rp, $path; + } + if ( $unlink ? $unlink->($path) : unlink($path) ) { + # Failed to delete the file + next if -e $path; + push @removes, $path; + } + + } elsif ( -d $path ) { + print "dir: $path\n" if DEBUG; + my $dir = File::Spec->canonpath( $path ); + if ( $$recursive ) { + if ( File::Path::rmtree( [ $dir ], DEBUG, 0 ) ) { + # Failed to delete the directory + next if -e $path; + push @removes, $path; + } + + } else { + my ($save_mode) = (stat $dir)[2]; + chmod $save_mode & 0777, $dir; # just in case we cannot remove it. + if ( $rmdir ? $rmdir->($dir) : rmdir($dir) ) { + # Failed to delete the directory + next if -e $path; + push @removes, $path; + } + } + + } else { + print "???: $path\n" if DEBUG; + } + } + + return @removes; +} + +sub rm (@) { + goto &remove; +} + +sub trash (@) { + local $unlink = $unlink; + local $rmdir = $rmdir; + + if ( ref $_[0] eq 'HASH' ) { + my %options = %{+shift @_}; + $unlink = $options{unlink}; + $rmdir = $options{rmdir}; + + } elsif ( IS_WIN32 ) { + local $@; + eval 'use Win32::FileOp ();'; + die "Can't load Win32::FileOp to support the Recycle Bin: \$@ = $@" if length $@; + $unlink = \&Win32::FileOp::Recycle; + $rmdir = \&Win32::FileOp::Recycle; + + } elsif ( IS_MAC ) { + unless ( $glue ) { + local $@; + eval 'use Mac::Glue ();'; + die "Can't load Mac::Glue::Finder to support the Trash Can: \$@ = $@" if length $@; + $glue = Mac::Glue->new('Finder'); + } + my $code = sub { + my @files = map { + Mac::Glue::param_type( + Mac::Glue::typeAlias() => $_ + ) + } @_; + $glue->delete(\@files); + }; + $unlink = $code; + $rmdir = $code; + } else { + die "Support for trash() on platform '$^O' not available at this time.\n"; + } + + goto &remove; +} + +sub undelete (@) { + goto &trash; +} + +1; + +__END__ + +=pod + +=head1 NAME + +File::Remove - Remove files and directories + +=head1 SYNOPSIS + + use File::Remove 'remove'; + + # removes (without recursion) several files + remove( '*.c', '*.pl' ); + + # removes (with recursion) several directories + remove( \1, qw{directory1 directory2} ); + + # removes (with recursion) several files and directories + remove( \1, qw{file1 file2 directory1 *~} ); + + # trashes (with support for undeleting later) several files + trash( '*~' ); + +=head1 DESCRIPTION + +B<File::Remove::remove> removes files and directories. It acts like +B</bin/rm>, for the most part. Although C<unlink> can be given a list +of files, it will not remove directories; this module remedies that. +It also accepts wildcards, * and ?, as arguments for filenames. + +B<File::Remove::trash> accepts the same arguments as B<remove>, with +the addition of an optional, infrequently used "other platforms" +hashref. + +=head1 SUBROUTINES + +=head2 remove + +Removes files and directories. Directories are removed recursively like +in B<rm -rf> if the first argument is a reference to a scalar that +evaluates to true. If the first arguemnt is a reference to a scalar +then it is used as the value of the recursive flag. By default it's +false so only pass \1 to it. + +In list context it returns a list of files/directories removed, in +scalar context it returns the number of files/directories removed. The +list/number should match what was passed in if everything went well. + +=head2 rm + +Just calls B<remove>. It's there for people who get tired of typing +B<remove>. + +=head2 clear + +The C<clear> function is a version of C<remove> designed for +use in test scripts. It takes a list of paths that it will both +initially delete during the current test run, and then further +flag for deletion at END-time as a convenience for the next test +run. + +=head2 trash + +Removes files and directories, with support for undeleting later. +Accepts an optional "other platforms" hashref, passing the remaining +arguments to B<remove>. + +=over 4 + +=item Win32 + +Requires L<Win32::FileOp>. + +Installation not actually enforced on Win32 yet, since L<Win32::FileOp> +has badly failing dependencies at time of writing. + +=item OS X + +Requires L<Mac::Glue>. + +=item Other platforms + +The first argument to trash() must be a hashref with two keys, +'rmdir' and 'unlink', each referencing a coderef. The coderefs +will be called with the filenames that are to be deleted. + +=back + +=head1 SUPPORT + +Bugs should always be submitted via the CPAN bug tracker + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Remove> + +For other issues, contact the maintainer. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 COPYRIGHT + +Some parts copyright 2006 - 2008 Adam Kennedy. + +Taken over by Adam Kennedy E<lt>adamk@cpan.orgE<gt>, to fix the +"deep readonly files" bug, and do some more cleaning up. + +Some parts copyright 2004 - 2005 Richard Soderberg. + +Taken over by Richard Soderberg E<lt>perl@crystalflame.netE<gt>, so as +to port it to L<File::Spec> and add tests. + +Original copyright: 1998 by Gabor Egressy, E<lt>gabor@vmunix.comE<gt>. + +This program is free software; you can redistribute and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/Spec.pm b/Master/tlpkg/tlperl/lib/File/Spec.pm new file mode 100755 index 00000000000..40c731649ac --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec.pm @@ -0,0 +1,336 @@ +package File::Spec; + +use strict; +use vars qw(@ISA $VERSION); + +$VERSION = '3.31'; +$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 +X<canonpath> + +No physical check on the filesystem, but a logical cleanup of a +path. + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=item catdir +X<catdir> + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS/2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + + $path = File::Spec->catdir( @directories ); + +=item catfile +X<catfile> + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + + $path = File::Spec->catfile( @directories, $filename ); + +=item curdir +X<curdir> + +Returns a string representation of the current directory. + + $curdir = File::Spec->curdir(); + +=item devnull +X<devnull> + +Returns a string representation of the null device. + + $devnull = File::Spec->devnull(); + +=item rootdir +X<rootdir> + +Returns a string representation of the root directory. + + $rootdir = File::Spec->rootdir(); + +=item tmpdir +X<tmpdir> + +Returns a string representation of the first writable directory from a +list of possible temporary directories. Returns the current directory +if no writable temporary directories are found. The list of directories +checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> +(unless taint is on) and F</tmp>. + + $tmpdir = File::Spec->tmpdir(); + +=item updir +X<updir> + +Returns a string representation of the parent directory. + + $updir = File::Spec->updir(); + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + + @paths = File::Spec->no_upwards( @paths ); + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +case is not or is significant when comparing file specifications. + + $is_case_tolerant = File::Spec->case_tolerant(); + +=item file_name_is_absolute + +Takes as its argument a path, and returns true if it is an absolute path. + + $is_absolute = File::Spec->file_name_is_absolute( $path ); + +This does not consult the local filesystem on Unix, Win32, OS/2, or +Mac OS (Classic). It does consult the working environment for VMS +(see L<File::Spec::VMS/file_name_is_absolute>). + +=item path +X<path> + +Takes no argument. Returns the environment variable C<PATH> (or the local +platform's equivalent) as a list. + + @PATH = File::Spec->path(); + +=item join +X<join, path> + +join is the same as catfile. + +=item splitpath +X<splitpath> X<split, path> + +Splits a path in to volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless C<$no_file> is true or a +trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=item splitdir +X<splitdir> X<split, dir> + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +C<$directories> must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSes. + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is +inserted if need be. On other OSes, C<$volume> is significant. + + $full_path = File::Spec->catpath( $volume, $directory, $file ); + +=item abs2rel +X<abs2rel> X<absolute, path> X<relative, path> + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<Cwd::cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<Cwd::cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=item rel2abs() +X<rel2abs> X<absolute, path> X<relative, path> + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<Cwd::cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=back + +For further information, please see L<File::Spec::Unix>, +L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or +L<File::Spec::VMS>. + +=head1 SEE ALSO + +L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, +L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, +L<ExtUtils::MakeMaker> + +=head1 AUTHOR + +Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< <kjahds@kjahds.com> >>, +Andy Dougherty C<< <doughera@lafayette.edu> >>, +Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>, +Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>. +VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>. +OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>. +Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and +Thomas Wegner C<< <wegner_thomas@yahoo.com> >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>, +modified by Barrie Slaymaker C<< <barries@slaysys.com> >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm new file mode 100755 index 00000000000..050a1bb2b77 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm @@ -0,0 +1,155 @@ +package File::Spec::Cygwin; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Cygwin - methods for Cygwin file specs + +=head1 SYNOPSIS + + require File::Spec::Cygwin; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +This module is still in beta. Cygwin-knowledgeable folks are invited +to offer patches and suggestions. + +=cut + +=pod + +=over 4 + +=item canonpath + +Any C<\> (backslashes) are converted to C</> (forward slashes), +and then File::Spec::Unix canonpath() is called on the result. + +=cut + +sub canonpath { + my($self,$path) = @_; + return unless defined $path; + + $path =~ s|\\|/|g; + + # Handle network path names beginning with double slash + my $node = ''; + if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) { + $node = $1; + } + return $node . $self->SUPER::canonpath($path); +} + +sub catdir { + my $self = shift; + return unless @_; + + # Don't create something that looks like a //network/path + if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { + shift; + return $self->SUPER::catdir('', @_); + } + + $self->SUPER::catdir(@_); +} + +=pod + +=item file_name_is_absolute + +True is returned if the file name begins with C<drive_letter:>, +and if not, File::Spec::Unix file_name_is_absolute() is called. + +=cut + + +sub file_name_is_absolute { + my ($self,$file) = @_; + return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test + return $self->SUPER::file_name_is_absolute($file); +} + +=item tmpdir (override) + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + /tmp + $ENV{'TMP'} + $ENV{'TEMP'} + C:/temp + +Since Perl 5.8.0, if running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' ); +} + +=item case_tolerant + +Override Unix. Cygwin case-tolerance depends on managed mount settings and +as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Default: 1 + +=cut + +sub case_tolerant { + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + + my $drive = shift; + if (! $drive) { + my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); + my $prefix = pop(@flags); + if (! $prefix || $prefix eq 'cygdrive') { + $drive = '/cygdrive/c'; + } elsif ($prefix eq '/') { + $drive = '/c'; + } else { + $drive = "$prefix/c"; + } + } + my $mntopts = Cygwin::mount_flags($drive); + if ($mntopts and ($mntopts =~ /,managed/)) { + return 0; + } + eval { require Win32API::File; } or return 1; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm new file mode 100755 index 00000000000..54ff667c52f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm @@ -0,0 +1,79 @@ +package File::Spec::Epoc; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Epoc - methods for Epoc file specs + +=head1 SYNOPSIS + + require File::Spec::Epoc; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This package is still work in progress ;-) + +=cut + +sub case_tolerant { + return 1; +} + +=pod + +=over 4 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=back + +=cut + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + $path =~ s|/+|/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + return $path; +} + +=pod + +=head1 AUTHOR + +o.flebbe@gmx.de + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm new file mode 100755 index 00000000000..e7becc7cfae --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm @@ -0,0 +1,110 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw( + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path +); + +@EXPORT_OK = qw( + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant +); + +%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); + +foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = File::Spec->can($meth); + no strict 'refs'; + *{$meth} = sub {&$sub('File::Spec', @_)}; +} + + +1; +__END__ + +=head1 NAME + +File::Spec::Functions - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec::Functions; + $x = catfile('a','b'); + +=head1 DESCRIPTION + +This module exports convenience functions for all of the class methods +provided by File::Spec. + +For a reference of available functions, please consult L<File::Spec::Unix>, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L<File::Spec::Mac>, +L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. + +=head2 Exports + +The following functions are exported by default. + + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path + + +The following functions are exported only by request. + + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant + +All the functions may be imported using the C<:ALL> tag. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker + +=cut + diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm new file mode 100755 index 00000000000..8b47470d6b3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm @@ -0,0 +1,781 @@ +package File::Spec::Mac; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +@ISA = qw(File::Spec::Unix); + +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::Files }; +} + +sub case_tolerant { 1 } + + +=head1 NAME + +File::Spec::Mac - File::Spec for Mac OS (Classic) + +=head1 SYNOPSIS + + require File::Spec::Mac; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item canonpath + +On Mac OS, there's nothing to be done. Returns what it's given. + +=cut + +sub canonpath { + my ($self,$path) = @_; + return $path; +} + +=item catdir() + +Concatenate two or more directory names to form a path separated by colons +(":") ending with a directory. Resulting paths are B<relative> by default, +but can be forced to be absolute (but avoid this, see below). Automatically +puts a trailing ":" on the end of the complete path, because that's what's +done in MacPerl's environment and helps to distinguish a file path from a +directory path. + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting +path is relative by default and I<not> absolute. This decision was made due +to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths +on all other operating systems, it will now also follow this convention on Mac +OS. Note that this may break some existing scripts. + +The intended purpose of this routine is to concatenate I<directory names>. +But because of the nature of Macintosh paths, some additional possibilities +are allowed to make using this routine give reasonable results for some +common situations. In other words, you are also allowed to concatenate +I<paths> instead of directory names (strictly speaking, a string like ":a" +is a path, but not a name, since it contains a punctuation character ":"). + +So, beside calls like + + catdir("a") = ":a:" + catdir("a","b") = ":a:b:" + catdir() = "" (special case) + +calls like the following + + catdir(":a:") = ":a:" + catdir(":a","b") = ":a:b:" + catdir(":a:","b") = ":a:b:" + catdir(":a:",":b:") = ":a:b:" + catdir(":") = ":" + +are allowed. + +Here are the rules that are used in C<catdir()>; note that we try to be as +compatible as possible to Unix: + +=over 2 + +=item 1. + +The resulting path is relative by default, i.e. the resulting path will have a +leading colon. + +=item 2. + +A trailing colon is added automatically to the resulting path, to denote a +directory. + +=item 3. + +Generally, each argument has one leading ":" and one trailing ":" +removed (if any). They are then joined together by a ":". Special +treatment applies for arguments denoting updir paths like "::lib:", +see (4), or arguments consisting solely of colons ("colon paths"), +see (5). + +=item 4. + +When an updir path like ":::lib::" is passed as argument, the number +of directories to climb up is handled correctly, not removing leading +or trailing colons when necessary. E.g. + + catdir(":::a","::b","c") = ":::a::b:c:" + catdir(":::a::","::b","c") = ":::a:::b:c:" + +=item 5. + +Adding a colon ":" or empty string "" to a path at I<any> position +doesn't alter the path, i.e. these arguments are ignored. (When a "" +is passed as the first argument, it has a special meaning, see +(6)). This way, a colon ":" is handled like a "." (curdir) on Unix, +while an empty string "" is generally ignored (see +C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".." +(updir), and a ":::" is handled like a "../.." etc. E.g. + + catdir("a",":",":","b") = ":a:b:" + catdir("a",":","::",":b") = ":a::b:" + +=item 6. + +If the first argument is an empty string "" or is a volume name, i.e. matches +the pattern /^[^:]+:/, the resulting path is B<absolute>. + +=item 7. + +Passing an empty string "" as the first argument to C<catdir()> is +like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e. + + catdir("","a","b") is the same as + + catdir(rootdir(),"a","b"). + +This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and +C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup +volume, which is the closest in concept to Unix' "/". This should help +to run existing scripts originally written for Unix. + +=item 8. + +For absolute paths, some cleanup is done, to ensure that the volume +name isn't immediately followed by updirs. This is invalid, because +this would go beyond "root". Generally, these cases are handled like +their Unix counterparts: + + Unix: + Unix->catdir("","") = "/" + Unix->catdir("",".") = "/" + Unix->catdir("","..") = "/" # can't go beyond root + Unix->catdir("",".","..","..","a") = "/a" + Mac: + Mac->catdir("","") = rootdir() # (e.g. "HD:") + Mac->catdir("",":") = rootdir() + Mac->catdir("","::") = rootdir() # can't go beyond root + Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:") + +However, this approach is limited to the first arguments following +"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more +arguments that move up the directory tree, an invalid path going +beyond root can be created. + +=back + +As you've seen, you can force C<catdir()> to create an absolute path +by passing either an empty string or a path that begins with a volume +name as the first argument. However, you are strongly encouraged not +to do so, since this is done only for backward compatibility. Newer +versions of File::Spec come with a method called C<catpath()> (see +below), that is designed to offer a portable solution for the creation +of absolute paths. It takes volume, directory and file portions and +returns an entire path. While C<catdir()> is still suitable for the +concatenation of I<directory names>, you are encouraged to use +C<catpath()> to concatenate I<volume names> and I<directory +paths>. E.g. + + $dir = File::Spec->catdir("tmp","sources"); + $abs_path = File::Spec->catpath("MacintoshHD:", $dir,""); + +yields + + "MacintoshHD:tmp:sources:" . + +=cut + +sub catdir { + my $self = shift; + return '' unless @_; + my @args = @_; + my $first_arg; + my $relative; + + # take care of the first argument + + if ($args[0] eq '') { # absolute path, rootdir + shift @args; + $relative = 0; + $first_arg = $self->rootdir; + + } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name + $relative = 0; + $first_arg = shift @args; + # add a trailing ':' if need be (may be it's a path like HD:dir) + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + + } else { # relative path + $relative = 1; + if ( $args[0] =~ /^::+\Z(?!\n)/ ) { + # updir colon path ('::', ':::' etc.), don't shift + $first_arg = ':'; + } elsif ($args[0] eq ':') { + $first_arg = shift @args; + } else { + # add a trailing ':' if need be + $first_arg = shift @args; + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + } + } + + # For all other arguments, + # (a) ignore arguments that equal ':' or '', + # (b) handle updir paths specially: + # '::' -> concatenate '::' + # '::' . '::' -> concatenate ':::' etc. + # (c) add a trailing ':' if need be + + my $result = $first_arg; + while (@args) { + my $arg = shift @args; + unless (($arg eq '') || ($arg eq ':')) { + if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::' + my $updir_count = length($arg) - 1; + while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path + $arg = shift @args; + $updir_count += (length($arg) - 1); + } + $arg = (':' x $updir_count); + } else { + $arg =~ s/^://s; # remove a leading ':' if any + $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':' + } + $result .= $arg; + }#unless + } + + if ( ($relative) && ($result !~ /^:/) ) { + # add a leading colon if need be + $result = ":$result"; + } + + unless ($relative) { + # remove updirs immediately following the volume name + $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/; + } + + return $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename. Resulting paths are B<relative> +by default, but can be forced to be absolute (but avoid this). + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the +resulting path is relative by default and I<not> absolute. This +decision was made due to portability reasons. Since +C<File::Spec-E<gt>catfile()> returns relative paths on all other +operating systems, it will now also follow this convention on Mac OS. +Note that this may break some existing scripts. + +The last argument is always considered to be the file portion. Since +C<catfile()> uses C<catdir()> (see above) for the concatenation of the +directory portions (if any), the following with regard to relative and +absolute paths is true: + + catfile("") = "" + catfile("file") = "file" + +but + + catfile("","") = rootdir() # (e.g. "HD:") + catfile("","file") = rootdir() . file # (e.g. "HD:file") + catfile("HD:","file") = "HD:file" + +This means that C<catdir()> is called only when there are two or more +arguments, as one might expect. + +Note that the leading ":" is removed from the filename, so that + + catfile("a","b","file") = ":a:b:file" and + + catfile("a","b",":file") = ":a:b:file" + +give the same answer. + +To concatenate I<volume names>, I<directory paths> and I<filenames>, +you are encouraged to use C<catpath()> (see below). + +=cut + +sub catfile { + my $self = shift; + return '' unless @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $file =~ s/^://s; + return $dir.$file; +} + +=item curdir + +Returns a string representing the current directory. On Mac OS, this is ":". + +=cut + +sub curdir { + return ":"; +} + +=item devnull + +Returns a string representing the null device. On Mac OS, this is "Dev:Null". + +=cut + +sub devnull { + return "Dev:Null"; +} + +=item rootdir + +Returns a string representing the root directory. Under MacPerl, +returns the name of the startup volume, since that's the closest in +concept, although other volumes aren't rooted there. The name has a +trailing ":", because that's the correct specification for a volume +name on Mac OS. + +If Mac::Files could not be loaded, the empty string is returned. + +=cut + +sub rootdir { +# +# There's no real root directory on Mac OS. The name of the startup +# volume is returned, since that's the closest in concept. +# + return '' unless $macfiles; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*\Z(?!\n)/:/s; + return $system; +} + +=item tmpdir + +Returns the contents of $ENV{TMPDIR}, if that directory exits or the +current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will +contain a path like "MacintoshHD:Temporary Items:", which is a hidden +directory on your startup volume. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} ); +} + +=item updir + +Returns a string representing the parent directory. On Mac OS, this is "::". + +=cut + +sub updir { + return "::"; +} + +=item file_name_is_absolute + +Takes as argument a path and returns true, if it is an absolute path. +If the path has a leading ":", it's a relative path. Otherwise, it's an +absolute path, unless the path doesn't contain any colons, i.e. it's a name +like "a". In this particular case, the path is considered to be relative +(i.e. it is considered to be a filename). Use ":" in the appropriate place +in the path if you want to distinguish unambiguously. As a special case, +the filename '' is always considered to be absolute. Note that with version +1.2 of File::Spec::Mac, this does no longer consult the local filesystem. + +E.g. + + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) + + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + if ($file =~ /:/) { + return (! ($file =~ m/^:/s) ); + } elsif ( $file eq '' ) { + return 1 ; + } else { + return 0; # i.e. a file like "a" + } +} + +=item path + +Returns the null list for the MacPerl application, since the concept is +usually meaningless under Mac OS. But if you're using the MacPerl tool under +MPW, it gives back $ENV{Commands} suitably split, as is done in +:lib:ExtUtils:MM_Mac.pm. + +=cut + +sub path { +# +# The concept is meaningless under the MacPerl application. +# Under MPW, it has a meaning. +# + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. + +On Mac OS, assumes that the last part of the path is a filename unless +$no_file is true or a trailing separator ":" is present. + +The volume portion is always returned with a trailing ":". The directory portion +is always returned with a leading (to denote a relative path) and a trailing ":" +(to denote a directory). The file portion is always returned I<without> a leading ":". +Empty portions are returned as empty string ''. + +The results can be passed to C<catpath()> to get back a path equivalent to +(usually identical to) the original path. + + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file); + + if ( $nofile ) { + ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s; + } + else { + $path =~ + m|^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + |xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + $volume = '' unless defined($volume); + $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir" + if ($directory) { + # Make sure non-empty directories begin and end in ':' + $directory .= ':' unless (substr($directory,-1) eq ':'); + $directory = ":$directory" unless (substr($directory,0,1) eq ':'); + } else { + $directory = ''; + } + $file = '' unless defined($file); + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of C<catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories should be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. Consider using C<splitpath()> otherwise. + +Unlike just splitting the directories on the separator, empty directory names +(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing +colon to distinguish a directory path from a file path, a single trailing colon +will be ignored, i.e. there's no empty directory name after it. + +Hence, on Mac OS, both + + File::Spec->splitdir( ":a:b::c:" ); and + File::Spec->splitdir( ":a:b::c" ); + +yield: + + ( "a", "b", "::", "c") + +while + + File::Spec->splitdir( ":a:b::c::" ); + +yields: + + ( "a", "b", "::", "c", "::") + + +=cut + +sub splitdir { + my ($self, $path) = @_; + my @result = (); + my ($head, $sep, $tail, $volume, $directories); + + return @result if ( (!defined($path)) || ($path eq '') ); + return (':') if ($path eq ':'); + + ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; + + # deprecated, but handle it correctly + if ($volume) { + push (@result, $volume); + $sep .= ':'; + } + + while ($sep || $directories) { + if (length($sep) > 1) { + my $updir_count = length($sep) - 1; + for (my $i=0; $i<$updir_count; $i++) { + # push '::' updir_count times; + # simulate Unix '..' updirs + push (@result, '::'); + } + } + $sep = ''; + if ($directories) { + ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s; + push (@result, $head); + $directories = $tail; + } + } + return @result; +} + + +=item catpath + + $path = File::Spec->catpath($volume,$directory,$file); + +Takes volume, directory and file portions and returns an entire path. On Mac OS, +$volume, $directory and $file are concatenated. A ':' is inserted if need be. You +may pass an empty string for each portion. If all portions are empty, the empty +string is returned. If $volume is empty, the result will be a relative path, +beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any) +is removed form $file and the remainder is returned. If $file is empty, the +resulting path will have a trailing ':'. + + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( (! $volume) && (! $directory) ) { + $file =~ s/^:// if $file; + return $file ; + } + + # We look for a volume in $volume, then in $directory, but not both + + my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1); + + $volume = $dir_volume unless length $volume; + my $path = $volume; # may be '' + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + + if ($directory) { + $directory = $dir_dirs if $volume; + $directory =~ s/^://; # remove leading ':' if any + $path .= $directory; + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + } + + if ($file) { + $file =~ s/^://; # remove leading ':' if any + $path .= $file; + } + + return $path; +} + +=item abs2rel + +Takes a destination path and an optional base path and returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then the current working directory is used. +If $base is relative, then it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +If $path and $base appear to be on two different volumes, we will not +attempt to resolve the two paths, and we will instead simply return +$path. Note that previous versions of this module ignored the volume +of $base, which resulted in garbage results part of the time. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is relative, it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +Based on code written by Shigio Yamaguchi. + + +=cut + +# maybe this should be done in canonpath() ? +sub _resolve_updirs { + my $path = shift @_; + my $proceed; + + # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file" + do { + $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + + return $path; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + $base = _resolve_updirs( $base ); # resolve updirs in $base + } + else { + $base = _resolve_updirs( $base ); + } + + # Split up paths - ignore $base's file + my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path ); + my ( $base_vol, $base_dirs ) = $self->splitpath( $base ); + + return $path unless lc( $path_vol ) eq lc( $base_vol ); + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_dirs ); + my @basechunks = $self->splitdir( $base_dirs ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @pathchunks now has the directories to descend in to. + # ensure relative path, even if @pathchunks is empty + $path_dirs = $self->catdir( ':', @pathchunks ); + + # @basechunks now contains the number of directories to climb out of. + $base_dirs = (':' x @basechunks) . ':' ; + + return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path: + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then $base is set to the current working +directory. If $base is relative, then it is converted to absolute form +using C<rel2abs()>. This means that it is taken to be relative to the +current working directory. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is already absolute, it is returned and $base is ignored. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base) = @_; + + if ( ! $self->file_name_is_absolute($path) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute($base) ) { + $base = $self->rel2abs($base) ; + } + + # Split up paths + + # igonore $path's volume + my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; + + # ignore $base's file part + my ( $base_vol, $base_dirs ) = $self->splitpath($base) ; + + # Glom them together + $path_dirs = ':' if ($path_dirs eq ''); + $base_dirs =~ s/:$//; # remove trailing ':', if any + $base_dirs = $base_dirs . $path_dirs; + + $path = $self->catpath( $base_vol, $base_dirs, $path_file ); + } + return $path; +} + + +=back + +=head1 AUTHORS + +See the authors list in I<File::Spec>. Mac OS support by Paul Schinder +<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm new file mode 100755 index 00000000000..a8fa63e3c16 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm @@ -0,0 +1,274 @@ +package File::Spec::OS2; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +@ISA = qw(File::Spec::Unix); + +sub devnull { + return "/dev/nul"; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); +} + +sub path { + my $path = $ENV{PATH}; + $path =~ s:\\:/:g; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +sub _cwd { + # In OS/2 the "require Cwd" is unnecessary bloat. + return Cwd::sys_cwd(); +} + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy + $tmpdir = $_[0]->_tmpdir( @d, '/tmp', '/' ); +} + +sub catdir { + my $self = shift; + my @args = @_; + foreach (@args) { + tr[\\][/]; + # append a backslash to each argument unless it has one there + $_ .= "/" unless m{/$}; + } + return $self->canonpath(join('', @args)); +} + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + $path =~ s/^([a-z]:)/\l$1/s; + $path =~ s|\\|/|g; + $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx + $path =~ s|/\Z(?!\n)|| + unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx + $path =~ s{^/\.\.$}{/}; # /.. -> / + 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx + return $path; +} + + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +sub splitdir { + my ($self,$directories) = @_ ; + split m|[\\/]|, $directories, -1; +} + + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '/' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; + my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; + return $path unless $path_volume eq $base_volume; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '/', @pathchunks ); + $base_directories = CORE::join( '/', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories/$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + return $self->canonpath( + $self->catpath( "", $path_directories, $path_file ) + ) ; +} + + +sub rel2abs { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +1; +__END__ + +=head1 NAME + +File::Spec::OS2 - methods for OS/2 file specs + +=head1 SYNOPSIS + + require File::Spec::OS2; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +Amongst the changes made for OS/2 are... + +=over 4 + +=item tmpdir + +Modifies the list of places temp directory information is looked for. + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / + +=item splitpath + +Volumes can be drive letters or UNC sharenames (\\server\share). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm new file mode 100755 index 00000000000..8fd2320a392 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm @@ -0,0 +1,521 @@ +package File::Spec::Unix; + +use strict; +use vars qw($VERSION); + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +=head1 NAME + +File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules + +=head1 SYNOPSIS + + require File::Spec::Unix; # Done automatically by File::Spec + +=head1 DESCRIPTION + +Methods for manipulating file specifications. Other File::Spec +modules, such as File::Spec::Mac, inherit from File::Spec::Unix and +override specific methods. + +=head1 METHODS + +=over 2 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminates successive slashes and successive "/.". + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=cut + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + # Handle POSIX-style node names beginning with double slash (qnx, nto) + # (POSIX says: "a pathname that begins with two successive slashes + # may be interpreted in an implementation-defined manner, although + # more than two leading slashes shall be treated as a single slash.") + my $node = ''; + my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; + + + if ( $double_slashes_special + && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { + $node = $1; + } + # This used to be + # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); + # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail + # (Mainly because trailing "" directories didn't get stripped). + # Why would cygwin avoid collapsing multiple slashes into one? --jhi + $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx + $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx + $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return "$node$path"; +} + +=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 { + my $self = shift; + + $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' +} + +=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 = $self->canonpath(pop @_); + return $file unless @_; + my $dir = $self->catdir(@_); + $dir .= "/" unless substr($dir,-1) eq "/"; + return $dir.$file; +} + +=item curdir + +Returns a string representation of the current directory. "." on UNIX. + +=cut + +sub curdir { '.' } + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull { '/dev/null' } + +=item rootdir + +Returns a string representation of the root directory. "/" on UNIX. + +=cut + +sub rootdir { '/' } + +=item tmpdir + +Returns a string representation of the first writable directory from +the following list or the current directory if none from the list are +writable: + + $ENV{TMPDIR} + /tmp + +Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +my $tmpdir; +sub _tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + my @dirlist = @_; + { + no strict 'refs'; + if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + } + foreach (@dirlist) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = $self->curdir unless defined $tmpdir; + $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + return $tmpdir; +} + +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); +} + +=item updir + +Returns a string representation of the parent directory. ".." on UNIX. + +=cut + +sub updir { '..' } + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + +=cut + +sub no_upwards { + my $self = shift; + return grep(!/^\.{1,2}\z/s, @_); +} + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +is not or is significant when comparing file specifications. + +=cut + +sub case_tolerant { 0 } + +=item file_name_is_absolute + +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, OS/2 or Mac +OS (Classic). It does consult the working environment for VMS (see +L<File::Spec::VMS/file_name_is_absolute>). + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. + +=cut + +sub path { + return () unless exists $ENV{PATH}; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +=item join + +join is the same as catfile. + +=cut + +sub join { + my $self = shift; + return $self->catfile(@_); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless $no_file is true or a +trailing separator or /. or /.. is present. On Unix this means that $no_file +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSs. + +On Unix, + + File::Spec->splitdir( "/a/b//c/" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + return split m|/|, $_[1], -1; # Preserve trailing fields +} + + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and directory and file are concatenated. A '/' is +inserted if needed (though if the directory portion doesn't start with +'/' it is not added). On other OSs, $volume is significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; +} + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + ($path, $base) = map $self->canonpath($_), $path, $base; + + if (grep $self->file_name_is_absolute($_), $path, $base) { + ($path, $base) = map $self->rel2abs($_), $path, $base; + } + else { + # save a couple of cwd()s if both paths are relative + ($path, $base) = map $self->catdir('/', $_), $path, $base; + } + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + my $path_directories = ($self->splitpath($path, 1))[1]; + my $base_directories = ($self->splitpath($base, 1))[1]; + + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + if ($base_directories eq $self->rootdir) { + shift @pathchunks; + return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); + } + + while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { + shift @pathchunks ; + shift @basechunks ; + } + return $self->curdir unless @pathchunks || @basechunks; + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. + my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} + +sub _same { + $_[1] eq $_[2]; +} + +=item rel2abs() + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores +the $base filename. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +# Internal routine to File::Spec, no point in making this public since +# it is the standard Cwd interface. Most of the platform-specific +# File::Spec subclasses use this. +sub _cwd { + require Cwd; + Cwd::getcwd(); +} + + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + pop @dirs if @dirs && $dirs[-1] eq ''; + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm new file mode 100755 index 00000000000..34b592abbfe --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm @@ -0,0 +1,1165 @@ +package File::Spec::VMS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +@ISA = qw(File::Spec::Unix); + +use File::Basename; +use VMS::Filespec; + +=head1 NAME + +File::Spec::VMS - methods for VMS file specs + +=head1 SYNOPSIS + + require File::Spec::VMS; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +The mode of operation of these routines depend on the VMS features that +are controlled by the DECC features C<DECC$FILENAME_REPORT_UNIX> and +C<DECC$EFS_CHARSET>. + +Perl needs to be at least at 5.10 for these feature settings to work. +Use of them on older perl versions on VMS will result in unpredictable +operations. + +The default and traditional mode of these routines have been to expect VMS +syntax on input and to return VMS syntax on output, even when Unix syntax was +given on input. + +The default and traditional mode is also incompatible with the VMS +C<EFS>, Extended File system character set, and with running Perl scripts +under <GNV>, Gnu is not VMS, an optional Unix like runtime environment on VMS. + +If the C<DECC$EFS_CHARSET> feature is enabled, These routines will now accept +either VMS or UNIX syntax. If the input parameters are clearly VMS syntax, +the return value will be in VMS syntax. If the input parameters are clearly +in Unix syntax, the output will be in Unix syntax. + +This corresponds to the way that the VMS C library routines have always +handled filenames, and what a programmer who has not specifically read this +pod before would also expect. + +If the C<DECC$FILENAME_REPORT_UNIX> feature is enabled, then if the output +syntax can not be determined from the input syntax, the output syntax will be +UNIX. If the feature is not enabled, VMS output will be the default. + +=over 4 + +=cut + +# Need to look up the feature settings. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. + +my $use_feature; +BEGIN { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_feature = 1; + } +} + +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _unix_rpt { + my $unix_rpt; + if ($use_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + } + return $unix_rpt; +} + +# Need to look up the EFS character set mode. This may become a dynamic +# mode in the future. +sub _efs { + my $efs; + if ($use_feature) { + $efs = VMS::Feature::current("efs_charset"); + } else { + my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; + $efs = $env_efs =~ /^[ET1]/i; + } + return $efs; +} + +=item canonpath (override) + +Removes redundant portions of file specifications according to the syntax +detected. + +=cut + + +sub canonpath { + my($self,$path) = @_; + + return undef unless defined $path; + + my $efs = $self->_efs; + + if ($path =~ m|/|) { # Fake Unix + my $pathify = $path =~ m|/\Z(?!\n)|; + $path = $self->SUPER::canonpath($path); + + # Do not convert to VMS when EFS character sets are in use + return $path if $efs; + + if ($pathify) { return vmspath($path); } + else { return vmsify($path); } + } + else { + +#FIXME - efs parsing has different rules. Characters in a VMS filespec +# are only delimiters if not preceded by '^'; + + $path =~ tr/<>/[]/; # < and > ==> [ and ] + $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ + $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $path =~ s/\[000000\./\[/g; # [000000. ==> [ + $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ] + $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar + 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); + # That loop does the following + # with any amount of dashes: + # .-.-. ==> .--. + # [-.-. ==> [--. + # .-.-] ==> .--] + # [-.-] ==> [--] + 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + # That loop does the following + # with any amount (minimum 2) + # of dashes: + # .foo.--. ==> .-. + # .foo.--] ==> .-] + # [foo.--. ==> [-. + # [foo.--] ==> [-] + # + # And then, the remaining cases + $path =~ s/\[\.-/[-/; # [.- ==> [- + $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . + $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000] + $path =~ s/\[\]// unless $path eq '[]'; # [] ==> + return $path; + } +} + +=item catdir (override) + +Concatenates a list of file specifications, and returns the result as a +directory specification. No check is made for "impossible" +cases (e.g. elements other than the first being absolute filespecs). + +=cut + +sub catdir { + my $self = shift; + my $dir = pop; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + + my @dirs = grep {defined() && length()} @_; + if ($efs) { + # Legacy mode removes blank entries. + # But that breaks existing generic perl code that + # uses a blank path at the beginning of the array + # to indicate an absolute path. + # So put it back if found. + if (@_) { + if ($_[0] eq '') { + unshift @dirs, ''; + } + } + } + + my $rslt; + if (@dirs) { + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + + if ($efs) { + # Extended character set in use, go into DWIM mode. + + # Now we need to identify what the directory is in + # of the specification in order to merge them. + my $path_unix = 0; + $path_unix = 1 if ($path =~ m#/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + my $dir_unix = 0; + $dir_unix = 1 if ($dir =~ m#/#); + $dir_unix = 1 if ($dir =~ /^\.\.?$/); + my $dir_vms = 0; + $dir_vms = 1 if ($dir =~ m#[\[<\]]#); + $dir_vms = 1 if ($dir =~ /^--?$/); + + my $unix_mode = 0; + if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) { + # Ambiguous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt); + $unix_mode = 1 if ($path_unix || $dir_unix); + } + + if ($unix_mode) { + + # Fix up mixed syntax imput as good as possible - GIGO + $path = unixify($path) if $path_vms; + $dir = unixify($dir) if $dir_vms; + + $rslt = $path; + # Append a path delimiter + $rslt .= '/' unless ($rslt =~ m#/$#); + + $rslt .= $dir; + return $self->SUPER::canonpath($rslt); + } else { + + #with <> posible instead of [. + # Normalize the brackets + # Fixme - need to not switch when preceded by ^. + $path =~ s/</\[/g; + $path =~ s/>/\]/g; + $dir =~ s/</\[/g; + $dir =~ s/>/\]/g; + + # Fix up mixed syntax imput as good as possible - GIGO + $path = vmsify($path) if $path_unix; + $dir = vmsify($dir) if $dir_unix; + + #Possible path values: foo: [.foo] [foo] foo, and $(foo) + #or starting with '-', or foo.dir + #If path is foo, it needs to be converted to [.foo] + + # Fix up a bare path name. + unless ($path_vms) { + $path =~ s/\.dir\Z(?!\n)//i; + if (($path ne '') && ($path !~ /^-/)) { + # Non blank and not prefixed with '-', add a dot + $path = '[.' . $path; + } else { + # Just start a directory. + $path = '[' . $path; + } + } else { + $path =~ s/\]$//; + } + + #Possible dir values: [.dir] dir and $(foo) + + # No punctuation may have a trailing .dir + unless ($dir_vms) { + $dir =~ s/\.dir\Z(?!\n)//i; + } else { + + #strip off the brackets + $dir =~ s/^\[//; + $dir =~ s/\]$//; + } + + #strip off the leading dot if present. + $dir =~ s/^\.//; + + # Now put the specifications together. + if ($dir ne '') { + # Add a separator unless this is an absolute path + $path .= '.' if ($path ne '['); + $rslt = $path . $dir . ']'; + } else { + $rslt = $path . ']'; + } + } + + } else { + # Traditional ODS-2 mode. + $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; + + $sdir = $self->eliminate_macros($sdir) + unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + + # Special case for VMS absolute directory specs: these will have + # had device prepended during trip through Unix syntax in + # eliminate_macros(), since Unix syntax has no way to express + # "absolute from the top of this device's directory tree". + if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } + } + } else { + # Single directory, just make sure it is in directory format + # Return an empty string on null input, and pass through macros. + + if (not defined $dir or not length $dir) { $rslt = ''; } + elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { + $rslt = $dir; + } else { + my $unix_mode = 0; + + if ($efs) { + my $dir_unix = 0; + $dir_unix = 1 if ($dir =~ m#/#); + $dir_unix = 1 if ($dir =~ /^\.\.?$/); + my $dir_vms = 0; + $dir_vms = 1 if ($dir =~ m#[\[<\]]#); + $dir_vms = 1 if ($dir =~ /^--?$/); + + if ($dir_vms == $dir_unix) { + # Ambiguous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 if $dir_unix; + } + } + + if ($unix_mode) { + return $dir; + } else { + # For VMS, force it to be in directory format + $rslt = vmspath($dir); + } + } + } + return $self->canonpath($rslt); +} + +=item catfile (override) + +Concatenates a list of directory specifications with a filename specification +to build a path. + +=cut + +sub catfile { + my $self = shift; + my $tfile = pop(); + my $file = $self->canonpath($tfile); + my @files = grep {defined() && length()} @_; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + # Assume VMS mode + my $unix_mode = 0; + my $file_unix = 0; + my $file_vms = 0; + if ($efs) { + + # Now we need to identify format the file is in + # of the specification in order to merge them. + $file_unix = 1 if ($tfile =~ m#/#); + $file_unix = 1 if ($tfile =~ /^\.\.?$/); + $file_vms = 1 if ($tfile =~ m#[\[<\]]#); + $file_vms = 1 if ($tfile =~ /^--?$/); + + # We may know for sure what the format is. + if (($file_unix != $file_vms)) { + $unix_mode = 1 if ($file_unix && $unix_rpt); + } + } + + my $rslt; + if (@files) { + # concatenate the directories. + my $path; + if (@files == 1) { + $path = $files[0]; + } else { + if ($file_vms) { + # We need to make sure this is in VMS mode to avoid doing + # both a vmsify and unixfy on the same path, as that may + # lose significant data. + my $i = @files - 1; + my $tdir = $files[$i]; + my $tdir_vms = 0; + my $tdir_unix = 0; + $tdir_vms = 1 if ($tdir =~ m#[\[<\]]#); + $tdir_unix = 1 if ($tdir =~ m#/#); + $tdir_unix = 1 if ($tdir =~ /^\.\.?$/); + + if (!$tdir_vms) { + if ($tdir_unix) { + $tdir = vmspath($tdir); + } else { + $tdir =~ s/\.dir\Z(?!\n)//i; + $tdir = '[.' . $tdir . ']'; + } + $files[$i] = $tdir; + } + } + $path = $self->catdir(@files); + } + my $spath = $path; + + # Some thing building a VMS path in pieces may try to pass a + # directory name in filename format, so normalize it. + $spath =~ s/\.dir\Z(?!\n)//i; + + # if the spath ends with a directory delimiter and the file is bare, + # then just concat them. + # FIX-ME: In VMS format "[]<>:" are not delimiters if preceded by '^' + # Quite a bit of Perl does not know that yet. + if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } else { + if ($efs) { + + # Now we need to identify what the directory is in + # of the specification in order to merge them. + my $spath_unix = 0; + $spath_unix = 1 if ($spath =~ m#/#); + $spath_unix = 1 if ($spath =~ /^\.\.?$/); + my $spath_vms = 0; + $spath_vms = 1 if ($spath =~ m#[\[<\]]#); + $spath_vms = 1 if ($spath =~ /^--?$/); + + # Assume VMS mode + if (($spath_unix == $spath_vms) && + ($file_unix == $file_vms)) { + # Ambigous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 + if (($spath_unix || $file_unix) && $unix_rpt); + } + + if (!$unix_mode) { + if ($spath_vms) { + $spath = '[' . $spath . ']' if $spath =~ /^-/; + $rslt = vmspath($spath); + } else { + $rslt = '[.' . $spath . ']'; + } + $file = vmsify($file) if ($file_unix); + } else { + $spath = unixify($spath) if ($spath_vms); + $rslt = $spath; + $file = unixify($file) if ($file_vms); + + # Unix merge may need a directory delimitor. + # A null path indicates root on Unix. + $rslt .= '/' unless ($rslt =~ m#/$#); + } + + $rslt .= $file; + $rslt =~ s/\]\[//; + + } else { + # Traditional VMS Perl mode expects that this is done. + # Note for future maintainers: + # This is left here for compatibility with perl scripts + # that have come to expect this behavior, even though + # usually the Perl scripts ported to VMS have to be + # patched because of it changing Unix syntax file + # to VMS format. + + $rslt = $self->eliminate_macros($spath); + + + $rslt = vmsify($rslt.((defined $rslt) && + ($rslt ne '') ? '/' : '').unixify($file)); + } + } + } + else { + # Only passed a single file? + my $xfile = $file; + + # Traditional VMS perl expects this conversion. + $xfile = vmsify($file) unless ($efs); + + $rslt = (defined($file) && length($file)) ? $xfile : ''; + } + return $self->canonpath($rslt) unless $unix_rpt; + + # In Unix report mode, do not strip off redundent path information. + return $rslt; +} + + +=item curdir (override) + +Returns a string representation of the current directory: '[]' or '.' + +=cut + +sub curdir { + my $self = shift @_; + return '.' if ($self->_unix_rpt); + return '[]'; +} + +=item devnull (override) + +Returns a string representation of the null device: '_NLA0:' or '/dev/null' + +=cut + +sub devnull { + my $self = shift @_; + return '/dev/null' if ($self->_unix_rpt); + return "_NLA0:"; +} + +=item rootdir (override) + +Returns a string representation of the root directory: 'SYS$DISK:[000000]' +or '/' + +=cut + +sub rootdir { + my $self = shift @_; + if ($self->_unix_rpt) { + # Root may exist, try it first. + my $try = '/'; + my ($dev1, $ino1) = stat('/'); + my ($dev2, $ino2) = stat('.'); + + # Perl falls back to '.' if it can not determine '/' + if (($dev1 != $dev2) || ($ino1 != $ino2)) { + return $try; + } + # Fall back to UNIX format sys$disk. + return '/sys$disk/'; + } + return 'SYS$DISK:[000000]'; +} + +=item tmpdir (override) + +Returns a string representation of the first writable directory +from the following list or '' if none are writable: + + /tmp if C<DECC$FILENAME_REPORT_UNIX> is enabled. + sys$scratch: + $ENV{TMPDIR} + +Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +my $tmpdir; +sub tmpdir { + my $self = shift @_; + return $tmpdir if defined $tmpdir; + if ($self->_unix_rpt) { + $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); + return $tmpdir; + } + + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); +} + +=item updir (override) + +Returns a string representation of the parent directory: '[-]' or '..' + +=cut + +sub updir { + my $self = shift @_; + return '..' if ($self->_unix_rpt); + return '[-]'; +} + +=item case_tolerant (override) + +VMS file specification syntax is case-tolerant. + +=cut + +sub case_tolerant { + return 1; +} + +=item path (override) + +Translate logical name DCL$PATH as a searchlist, rather than trying +to C<split> string value of C<$ENV{'PATH'}>. + +=cut + +sub path { + my (@dirs,$dir,$i); + while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } + return @dirs; +} + +=item file_name_is_absolute (override) + +Checks for VMS directory spec as well as Unix separators. + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + # If it's a logical name, expand it. + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; + return scalar($file =~ m!^/!s || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /:[^<\[]/); +} + +=item splitpath (override) + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Passing a true value for C<$no_file> indicates that the path being +split only contains directory components, even on systems where you +can usually (when not supporting a foreign syntax) tell the difference +between directories and files at a glance. + +=cut + +sub splitpath { + my($self,$path, $nofile) = @_; + my($dev,$dir,$file) = ('','',''); + my $efs = $self->_efs; + my $vmsify_path = vmsify($path); + if ($efs) { + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + if (!$path_vms) { + return $self->SUPER::splitpath($path, $nofile); + } + $vmsify_path = $path; + } + + if ( $nofile ) { + #vmsify('d1/d2/d3') returns '[.d1.d2]d3' + #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' + if( $vmsify_path =~ /(.*)\](.+)/ ){ + $vmsify_path = $1.'.'.$2.']'; + } + $vmsify_path =~ /(.+:)?(.*)/s; + $dir = defined $2 ? $2 : ''; # dir can be '0' + return ($1 || '',$dir,$file); + } + else { + $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); + } +} + +=item splitdir (override) + +Split a directory specification into the components. + +=cut + +sub splitdir { + my($self,$dirspec) = @_; + my @dirs = (); + return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); + + my $efs = $self->_efs; + + my $dir_unix = 0; + $dir_unix = 1 if ($dirspec =~ m#/#); + $dir_unix = 1 if ($dirspec =~ /^\.\.?$/); + + # Unix filespecs in EFS mode handled by Unix routines. + if ($efs && $dir_unix) { + return $self->SUPER::splitdir($dirspec); + } + + # FIX ME, only split for VMS delimiters not prefixed with '^'. + + $dirspec =~ tr/<>/[]/; # < and > ==> [ and ] + $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ + $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [ + $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ] + $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar + while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} + # That loop does the following + # with any amount of dashes: + # .--. ==> .-.-. + # [--. ==> [-.-. + # .--] ==> .-.-] + # [--] ==> [-.-] + $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal + $dirspec =~ s/^(\[|<)\./$1/; + @dirs = split /(?<!\^)\./, vmspath($dirspec); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec. + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + my $unix_mode = 0; + my $dir_unix = 0; + $dir_unix = 1 if ($dir =~ m#/#); + $dir_unix = 1 if ($dir =~ /^\.\.?$/); + my $dir_vms = 0; + $dir_vms = 1 if ($dir =~ m#[\[<\]]#); + $dir_vms = 1 if ($dir =~ /^--?$/); + + if ($efs && (length($dev) == 0)) { + if ($dir_unix == $dir_vms) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $dir_unix; + } + } + + # We look for a volume in $dev, then in $dir, but not both + # but only if using VMS syntax. + if (!$unix_mode) { + $dir = vmspath($dir) if $dir_unix; + my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); + $dev = $dir_volume unless length $dev; + $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : + $dir_dir; + } + if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } + if (length($dev) or length($dir)) { + if ($efs) { + if ($unix_mode) { + $dir .= '/' unless ($dir =~ m#/$#); + } else { + $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/)); + $dir = "[$dir]" unless $dir =~ /^[\[<]/; + } + } else { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); + } + } + "$dev$dir$file"; +} + +=item abs2rel (override) + +Attempt to convert a file specification to a relative specification. +On a system with volumes, like VMS, this may not be possible. + +=cut + +sub abs2rel { + my $self = shift; + my($path,$base) = @_; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + if (!$efs) { + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if grep m{/}, @_; + } + + # We need to identify what the directory is in + # of the specification in order to process them + my $path_unix = 0; + $path_unix = 1 if ($path =~ m#/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + + my $unix_mode = 0; + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $path_unix; + } + + my $base_unix = 0; + my $base_vms = 0; + + if (defined $base) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + + if ($path_vms == $path_unix) { + if ($base_vms == $base_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $base_unix; + } + } else { + $unix_mode = 0 if $base_vms; + } + } + + if ($efs) { + if ($unix_mode) { + # We are UNIX mode. + $base = unixpath($base) if $base_vms; + $base = unixify($path) if $path_vms; + + # Here VMS is different, and in order to do this right + # we have to take the realpath for both the path and the base + # so that we can remove the common components. + + if ($path =~ m#^/#) { + if (defined $base) { + + # For the shorterm, if the starting directories are + # common, remove them. + my $bq = qq($base); + $bq =~ s/\$/\\\$/; + $path =~ s/^$bq//i; + } + return $path; + } + + return File::Spec::Unix::abs2rel( $self, $path, $base ); + + } else { + $base = vmspath($base) if $base_unix; + $path = vmsify($path) if $path_unix; + } + } + + unless (defined $base and length $base) { + $base = $self->_cwd(); + if ($efs) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base = vmspath($base) if $base_unix; + } + } + + for ($path, $base) { $_ = $self->canonpath($_) } + + # Are we even starting $path on the same (node::)device as $base? Note that + # logical paths or nodename differences may be on the "same device" + # but the comparison that ignores device differences so as to concatenate + # [---] up directory specs is not even a good idea in cases where there is + # a logical path difference between $path and $base nodename and/or device. + # Hence we fall back to returning the absolute $path spec + # if there is a case blind device (or node) difference of any sort + # and we do not even try to call $parse() or consult %ENV for $trnlnm() + # (this module needs to run on non VMS platforms after all). + + my ($path_volume, $path_directories, $path_file) = $self->splitpath($path); + my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); + return $path unless lc($path_volume) eq lc($base_volume); + + for ($path, $base) { $_ = $self->rel2abs($_) } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my $pathchunks = @pathchunks; + unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; + my @basechunks = $self->splitdir( $base_directories ); + my $basechunks = @basechunks; + unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @basechunks now contains the directories to climb out of, + # @pathchunks now has the directories to descend in to. + if ((@basechunks > 0) || ($basechunks != $pathchunks)) { + $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + } + else { + $path_directories = join '.', @pathchunks; + } + $path_directories = '['.$path_directories.']'; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +Return an absolute file specification from a relative one. + +=cut + +sub rel2abs { + my $self = shift ; + my ($path,$base ) = @_; + return undef unless defined $path; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + # We need to identify what the directory is in + # of the specification in order to process them + my $path_unix = 0; + $path_unix = 1 if ($path =~ m#/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + + my $unix_mode = 0; + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $path_unix; + } + + my $base_unix = 0; + my $base_vms = 0; + + if (defined $base) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + + # If we could not determine the path mode, see if we can find out + # from the base. + if ($path_vms == $path_unix) { + if ($base_vms != $base_unix) { + $unix_mode = $base_unix; + } + } + } + + if (!$efs) { + # Legacy behavior, convert to VMS syntax. + $unix_mode = 0; + if (defined $base) { + $base = vmspath($base) if $base =~ m/\//; + } + + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + } + + # Clean up and split up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + if ($efs) { + # base may have changed, so need to look up format again. + if ($unix_mode) { + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + $base = unixpath($base) if $base_vms; + $base .= '/' unless ($base =~ m#/$#); + } else { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base = vmspath($base) if $base_unix; + } + } + + # Split up paths + my ( $path_directories, $path_file ) = + ($self->splitpath( $path ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base ) ; + + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; + my $sep = '' ; + + if ($efs) { + # Merge the paths assuming that the base is absolute. + $base_directories = $self->catdir('', + $base_directories, + $path_directories); + } else { + # Legacy behavior assumes VMS only paths + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + } + + $path_file = '' if ($path_file eq '.') && $unix_mode; + + $path = $self->catpath( $base_volume, $base_directories, $path_file ); + } + + return $self->canonpath( $path ) ; +} + + +# eliminate_macros() and fixpath() are MakeMaker-specific methods +# which are used inside catfile() and catdir(). MakeMaker has its own +# copies as of 6.06_03 which are the canonical ones. We leave these +# here, in peace, so that File::Spec continues to work with MakeMakers +# prior to 6.06_03. +# +# Please consider these two methods deprecated. Do not patch them, +# patch the ones in ExtUtils::MM_VMS instead. +# +# Update: MakeMaker 6.48 is still using these routines on VMS. +# so they need to be kept up to date with ExtUtils::MM_VMS. +# +# The traditional VMS mode using ODS-2 disks depends on these routines +# being here. These routines should not be called in when the +# C<DECC$EFS_CHARSET> or C<DECC$FILENAME_REPORT_UNIX> modes are enabled. + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless (defined $path) && ($path ne ''); + $self = {} unless ref $self; + + if ($path =~ /\s/) { + return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; + } + + my $npath = unixify($path); + # sometimes unixify will return a string with an off-by-one trailing null + $npath =~ s{\0$}{}; + + my($complex) = 0; + my($head,$macro,$tail); + + # perform m##g in scalar context so it acts as an iterator + while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { + if (defined $self->{$2}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; +} + +# Deprecated. See the note above for eliminate_macros(). + +# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros +# in any directory specification, in order to avoid juxtaposing two +# VMS-syntax directories when MM[SK] is run. Also expands expressions which +# are all macro, so that we can tell how long the expansion is, and avoid +# overrunning DCL's command buffer when MM[KS] is running. + +# fixpath() checks to see whether the result matches the name of a +# directory in the current default directory and returns a directory or +# file specification accordingly. C<$is_dir> can be set to true to +# force fixpath() to consider the path to be a directory or false to force +# it to be a file. + +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {}, $self unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ /\s/) { + return join ' ', + map { $self->fixpath($_,$force_path) } + split /\s+/, $path; + } + + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$1/; + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + $fixedpath; +} + + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +An explanation of VMS file specs can be found at +L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm new file mode 100755 index 00000000000..93301ac7357 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm @@ -0,0 +1,444 @@ +package File::Spec::Win32; + +use strict; + +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +@ISA = qw(File::Spec::Unix); + +# Some regexes we use for path splitting +my $DRIVE_RX = '[a-zA-Z]:'; +my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; +my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; + + +=head1 NAME + +File::Spec::Win32 - methods for Win32 file specs + +=head1 SYNOPSIS + + require File::Spec::Win32; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over 4 + +=item devnull + +Returns a string representation of the null device. + +=cut + +sub devnull { + return "nul"; +} + +sub rootdir { '\\' } + + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + SYS:/temp + C:\system\temp + C:/temp + /tmp + / + +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). + +Since Perl 5.8.0, if running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), + 'SYS:/temp', + 'C:\system\temp', + 'C:/temp', + '/tmp', + '/' ); +} + +=item case_tolerant + +MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. +See http://cygwin.com/ml/cygwin/2007-07/msg00891.html +Default: 1 + +=cut + +sub case_tolerant { + eval { require Win32API::File; } or return 1; + my $drive = shift || "C:"; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } +} + +=item file_name_is_absolute + +As of right now, this returns 2 if the path is absolute with a +volume, 1 if it's absolute with no volume, 0 otherwise. + +=cut + +sub file_name_is_absolute { + + my ($self,$file) = @_; + + if ($file =~ m{^($VOL_RX)}o) { + my $vol = $1; + return ($vol =~ m{^$UNC_RX}o ? 2 + : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 + : 0); + } + return $file =~ m{^[\\/]} ? 1 : 0; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + shift; + + # Legacy / compatibility support + # + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catfile('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); +} + +sub catdir { + shift; + + # Legacy / compatibility support + # + return "" + unless @_; + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catdir('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); +} + +sub path { + my @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + unshift(@path, "."); + return @path; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". +On Win32 makes + + dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even + dir1\dir2\dir3\...\dir4 -> \dir\dir4 + +=cut + +sub canonpath { + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, '' ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L</catpath> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^ ( $VOL_RX ? ) (.*) }sox; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( $VOL_RX ? ) + ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }sox; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L<catdir()|File::Spec/catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\Z(?!\n)| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + my $v; + $volume .= $v + if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + +sub _same { + lc($_[1]) eq lc($_[2]); +} + +sub rel2abs { + my ($self,$path,$base ) = @_; + + my $is_abs = $self->file_name_is_absolute($path); + + # Check for volume (should probably document the '2' thing...) + return $self->canonpath( $path ) if $is_abs == 2; + + if ($is_abs) { + # It's missing a volume, add one + my $vol = ($self->splitpath( $self->_cwd() ))[0]; + return $self->canonpath( $vol . $path ); + } + + if ( !defined( $base ) || $base eq '' ) { + require Cwd ; + $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; + $base = $self->_cwd() unless defined $base ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + + return $self->canonpath( $path ) ; +} + +=back + +=head2 Note For File::Spec::Win32 Maintainers + +Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. + +=head1 COPYRIGHT + +Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + + +sub _canon_cat # @path -> path +{ + my ($first, @rest) = @_; + + my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter + ? ucfirst( $1 ).( $2 ? "\\" : "" ) + : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) + (?: [\\/] ([^\\/]+) )? + [\\/]? }{}xs # UNC volume + ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" + : $first =~ s{ \A [\\/] }{}x # root dir + ? "\\" + : ""; + my $path = join "\\", $first, @rest; + + $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy + + # xx/././yy --> xx/yy + $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + \. + (?:\\\.)* # and more + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}gx; + + # XXX I do not know whether more dots are supported by the OS supporting + # this ... annotation (NetWare or symbian but not MSWin32). + # Then .... could easily become ../../.. etc: + # Replace \.\.\. by (\.\.\.+) and substitute with + # { $1 . ".." . "\\.." x (length($2)-2) }gex + # ... --> ../.. + $path =~ s{ (\A|\\) # at begin or after a slash + \.\.\. + (?=\\|\z) # at end or followed by slash + }{$1..\\..}gx; + # xx\yy\..\zz --> xx\zz + while ( $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + [^\\]+ # rip this 'yy' off + \\\.\. + (?<!\A\.\.\\\.\.) # do *not* replace ^..\.. + (?<!\\\.\.\\\.\.) # do *not* replace \..\.. + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}sx ) {} + + $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # <vol>\.. --> <vol>\ + $path =~ s{ \A # at begin + \.\. + (?:\\\.\.)* # and more + (?:\\|\z) # at end or followed by slash + }{}x; + + return $1 # \\HOST\SHARE\ --> \\HOST\SHARE + if $path eq "" + and $volume =~ m#\A(\\\\.*)\\\z#s; + } + return $path ne "" || $volume ? $volume.$path : "."; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Temp.pm b/Master/tlpkg/tlperl/lib/File/Temp.pm new file mode 100755 index 00000000000..a2d4ae0759f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Temp.pm @@ -0,0 +1,2452 @@ +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: + +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C<stat> reliable? By default all the +return values from C<stat> are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If C<unlink0> fails +then the C<stat> comparison should be modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); + + binmode( $fh, ":utf8" ); + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + +Object interface: + + require File::Temp; + use File::Temp (); + use File::Temp qw/ :seekable /; + + $fh = File::Temp->new(); + $fname = $fh->filename; + + $fh = File::Temp->new(TEMPLATE => $template); + $fname = $fh->filename; + + $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); + print $tmp "Some data\n"; + print "Filename is $tmp\n"; + $tmp->seek( 0, SEEK_END ); + +The following interfaces are provided for compatibility with +existing APIs. They should not be used in new code. + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=head1 DESCRIPTION + +C<File::Temp> can be used to create and open temporary files in a safe +way. There is both a function interface and an object-oriented +interface. The File::Temp constructor or the tempfile() function can +be used to return the name and the open filehandle of a temporary +file. The tempdir() function can be used to create a temporary +directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L<POSIX|POSIX> +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +Filehandles returned by these functions support the seekable methods. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.004 so give them what they want :-) +use 5.004; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use IO::Seekable; # For SEEK_* +use Errno; +require VMS::Stdio if $^O eq 'VMS'; + +# pre-emptively load Carp::Heavy. If we don't when we run out of file +# handles and attempt to call croak() we get an error message telling +# us that Carp::Heavy won't load rather than an error telling us we +# have run out of file handles. We either preload croak() or we +# switch the calls to croak from _gettemp() to use die. +eval { require Carp::Heavy; }; + +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + +### For the OO interface +use base qw/ IO::Handle IO::Seekable /; +use overload '""' => "STRINGIFY", fallback => 1; + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); + +$DEBUG = 0; +$KEEP_ALL = 0; + +# We are exporting functions + +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + cleanup + SEEK_SET + SEEK_CUR + SEEK_END + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp','seekable'); + +# Version number + +$VERSION = '0.22'; + +# This is a list of characters that can be used in random filenames + +my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z + a b c d e f g h i j k l m n o p q r s t u v w x y z + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 1000; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; +my $LOCKFLAG; + +unless ($^O eq 'MacOS') { + for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # e.g. CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } + # Special case O_EXLOCK + $LOCKFLAG = eval { + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + &Fcntl::O_EXLOCK(); + }; +} + +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +unless ($^O eq 'MacOS') { + for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + local($@); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # e.g. CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } +} + +# Private hash tracking which files have been created by each process id via the OO interface +my %FILES_CREATED_BY_OBJECT; + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix +# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true. + +# Optionally a reference to a scalar can be passed into the function +# On error this will be used to store the reason for the error +# "ErrStr" => \$errstr + +# "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# stored in an error string and returned to give the reason whilst debugging +# This routine is not called by any external function +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # the internal error string - expect it to be overridden + # Need this in case the caller decides not to supply us a value + # need an anonymous scalar + my $tempErrStr; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + "unlink_on_close" => 0, + "use_exlock" => 1, + "ErrStr" => \$tempErrStr, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Make sure the error string is set to undef + ${$options{ErrStr}} = undef; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + ${$options{ErrStr}} = "The template must end with at least ". + MINX . " 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry (i.e. the directory template) that means + # we are in the current directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-e $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) does not exist"; + return (); + } + unless (-d $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; + return (); + } + + # Check the stickiness of the directory and chown giveaway if required + # If the directory is world writable the sticky bit + # must be set + + if (File::Temp->safe_level == MEDIUM) { + my $safeerr; + unless (_is_safe($parent,\$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + my $safeerr; + unless (_is_verysafe($parent, \$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } + + + # Now try MAX_TRIES time to open the file + for (my $i = 0; $i < MAX_TRIES; $i++) { + + # Try to open the file if requested + if ($options{"open"}) { + my $fh; + + # If we are running before perl5.6.0 we can not auto-vivify + if ($] < 5.006) { + $fh = &Symbol::gensym; + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + + # Attempt to open the file + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock}); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { + + # in case of odd umask force rw + chmod(0600, $path); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Open the temp directory + if (mkdir( $path, 0700)) { + # in case of odd umask + chmod(0700, $path); + + return undef, $path; + } else { + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" + . MAX_TRIES . ") to open temp file/dir"; + + return (); + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + my $end = ( $] >= 5.006 ? "\\z" : "\\Z" ); + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; + } else { + $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; + } + return $path; +} + +# Internal routine to force a temp file to be writable after +# it is created so that we can unlink it. Windows seems to occassionally +# force a file to be readonly when written to certain temp locations +sub _force_writable { + my $file = shift; + chmod 0600, $file; +} + + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Optionally: reference to scalar to contain error message +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + my $err_ref = shift; + + # Stat path + my @info = stat($path); + unless (scalar(@info)) { + $$err_ref = "stat(path) returned no values"; + return 0; + } + ; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the effective uid from the $> variable + # UID is in [4] + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'", + File::Temp->top_system_uid()); + + $$err_ref = "Directory owned neither by root nor the current user" + if ref($err_ref); + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + # Must be a directory + unless (-d $path) { + $$err_ref = "Path ($path) is not a directory" + if ref($err_ref); + return 0; + } + # Must have sticky bit set + unless (-k $path) { + $$err_ref = "Sticky bit not set on $path when dir is group|world writable" + if ref($err_ref); + return 0; + } + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +# Takes optional second arg as scalar ref to error reason + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + print "_is_verysafe testing $path\n" if $DEBUG; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + my $err_ref = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + local($@); + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir,$err_ref); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. + +sub _can_unlink_opened_file { + + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { + return 0; + } else { + return 1; + } + +} + +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') { + return 0; + } else { + return 1; + } + +} + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opened file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred to since all the magic is done with an END block + +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories They will + # only exist in this block. + + # This means we only have to set up a single END block to remove + # all files. + + # in order to prevent child processes inadvertently deleting the parent + # temp files we use a hash to store the temp files and directories + # created by a particular process id. + + # %files_to_unlink contains values that are references to an array of + # array references containing the filehandle and filename associated with + # the temp file. + my (%files_to_unlink, %dirs_to_unlink); + + # Set up an end block to use these arrays + END { + local($., $@, $!, $^E, $?); + cleanup(); + } + + # Cleanup function. Always triggered on END but can be invoked + # manually. + sub cleanup { + if (!$KEEP_ALL) { + # Files + my @files = (exists $files_to_unlink{$$} ? + @{ $files_to_unlink{$$} } : () ); + foreach my $file (@files) { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + _force_writable( $file->[1] ); # for windows + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + my @dirs = (exists $dirs_to_unlink{$$} ? + @{ $dirs_to_unlink{$$} } : () ); + foreach my $dir (@dirs) { + if (-d $dir) { + # Some versions of rmtree will abort if you attempt to remove + # the directory you are sitting in. We protect that and turn it + # into a warning. We do this because this occurs during + # cleanup and so can not be caught by the user. + eval { rmtree($dir, $DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + } + + # clear the arrays + @{ $files_to_unlink{$$} } = () + if exists $files_to_unlink{$$}; + @{ $dirs_to_unlink{$$} } = () + if exists $dirs_to_unlink{$$}; + } + } + + + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so store it + # first on VMS turn []foo into [.foo] for rmtree + $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; + $dirs_to_unlink{$$} = [] + unless exists $dirs_to_unlink{$$}; + push (@{ $dirs_to_unlink{$$} }, $fname); + + } else { + carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; + } + + } else { + + if (-f $fname) { + + # file exists so store handle and name for later removal + $files_to_unlink{$$} = [] + unless exists $files_to_unlink{$$}; + push(@{ $files_to_unlink{$$} }, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; + } + + } + + } + + +} + +=head1 OBJECT-ORIENTED INTERFACE + +This is the primary interface for interacting with +C<File::Temp>. Using the OO interface a temporary file can be created +when the object is constructed and the file can be removed when the +object is no longer required. + +Note that there is no method to obtain the filehandle from the +C<File::Temp> object. The object itself acts as a filehandle. Also, +the object is configured such that it stringifies to the name of the +temporary file, and can be compared to a filename directly. The object +isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are +available. + +=over 4 + +=item B<new> + +Create a temporary file object. + + my $tmp = File::Temp->new(); + +by default the object is constructed as if C<tempfile> +was called without options, but with the additional behaviour +that the temporary file is removed by the object destructor +if UNLINK is set to true (the default). + +Supported arguments are the same as for C<tempfile>: UNLINK +(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename +template is specified using the TEMPLATE option. The OPEN option +is not supported (the file is always opened). + + $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', + DIR => 'mydir', + SUFFIX => '.dat'); + +Arguments are case insensitive. + +Can call croak() if an error occurs. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + # read arguments and convert keys to upper case + my %args = @_; + %args = map { uc($_), $args{$_} } keys %args; + + # see if they are unlinking (defaulting to yes) + my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); + delete $args{UNLINK}; + + # template (store it in an array so that it will + # disappear from the arg list of tempfile) + my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); + delete $args{TEMPLATE}; + + # Protect OPEN + delete $args{OPEN}; + + # Open the file and retain file handle and file name + my ($fh, $path) = tempfile( @template, %args ); + + print "Tmp: $fh - $path\n" if $DEBUG; + + # Store the filename in the scalar slot + ${*$fh} = $path; + + # Cache the filename by pid so that the destructor can decide whether to remove it + $FILES_CREATED_BY_OBJECT{$$}{$path} = 1; + + # Store unlink information in hash slot (plus other constructor info) + %{*$fh} = %args; + + # create the object + bless $fh, $class; + + # final method-based configuration + $fh->unlink_on_destroy( $unlink ); + + return $fh; +} + +=item B<newdir> + +Create a temporary directory using an object oriented interface. + + $dir = File::Temp->newdir(); + +By default the directory is deleted when the object goes out of scope. + +Supports the same options as the C<tempdir> function. Note that directories +created with this method default to CLEANUP => 1. + + $dir = File::Temp->newdir( $template, %options ); + +=cut + +sub newdir { + my $self = shift; + + # need to handle args as in tempdir because we have to force CLEANUP + # default without passing CLEANUP to tempdir + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + my %options = @_; + my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 ); + + delete $options{CLEANUP}; + + my $tempdir; + if (defined $template) { + $tempdir = tempdir( $template, %options ); + } else { + $tempdir = tempdir( %options ); + } + return bless { DIRNAME => $tempdir, + CLEANUP => $cleanup, + LAUNCHPID => $$, + }, "File::Temp::Dir"; +} + +=item B<filename> + +Return the name of the temporary file associated with this object +(if the object was created using the "new" constructor). + + $filename = $tmp->filename; + +This method is called automatically when the object is used as +a string. + +=cut + +sub filename { + my $self = shift; + return ${*$self}; +} + +sub STRINGIFY { + my $self = shift; + return $self->filename; +} + +=item B<dirname> + +Return the name of the temporary directory associated with this +object (if the object was created using the "newdir" constructor). + + $dirname = $tmpdir->dirname; + +This method is called automatically when the object is used in string context. + +=item B<unlink_on_destroy> + +Control whether the file is unlinked when the object goes out of scope. +The file is removed if this value is true and $KEEP_ALL is not. + + $fh->unlink_on_destroy( 1 ); + +Default is for the file to be removed. + +=cut + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + ${*$self}{UNLINK} = shift; + } + return ${*$self}{UNLINK}; +} + +=item B<DESTROY> + +When the object goes out of scope, the destructor is called. This +destructor will attempt to unlink the file (using C<unlink1>) +if the constructor was called with UNLINK set to 1 (the default state +if UNLINK is not specified). + +No error is given if the unlink fails. + +If the object has been passed to a child process during a fork, the +file will be deleted when the object goes out of scope in the parent. + +For a temporary directory object the directory will be removed +unless the CLEANUP argument was used in the constructor (and set to +false) or C<unlink_on_destroy> was modified after creation. + +If the global variable $KEEP_ALL is true, the file or directory +will not be removed. + +=cut + +sub DESTROY { + local($., $@, $!, $^E, $?); + my $self = shift; + + # Make sure we always remove the file from the global hash + # on destruction. This prevents the hash from growing uncontrollably + # and post-destruction there is no reason to know about the file. + my $file = $self->filename; + my $was_created_by_proc; + if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) { + $was_created_by_proc = 1; + delete $FILES_CREATED_BY_OBJECT{$$}{$file}; + } + + if (${*$self}{UNLINK} && !$KEEP_ALL) { + print "# ---------> Unlinking $self\n" if $DEBUG; + + # only delete if this process created it + return unless $was_created_by_proc; + + # The unlink1 may fail if the file has been closed + # by the caller. This leaves us with the decision + # of whether to refuse to remove the file or simply + # do an unlink without test. Seems to be silly + # to do this when we are trying to be careful + # about security + _force_writable( $file ); # for windows + unlink1( $self, $file ) + or unlink($file); + } +} + +=back + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B<tempfile> + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L<File::Spec>. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +at the end of the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + + ($fh, $filename) = tempfile($template, TMPDIR => 1); + +Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file +into the same temporary directory as would be used if no template was +specified at all. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits (dependent on +$KEEP_ALL). Default is for the file to be removed if a file handle is +requested and to be kept if the filename is requested. In a scalar +context (where no filename is returned) the file is always deleted +either (depending on the operating system) on exit or when it is +closed (unless $KEEP_ALL is true when the temp file is created). + +Use the object-oriented interface if fine-grained control of when +a file is removed is required. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L<File::Spec>) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( DIR => $dir ); + +If called in scalar context, only the filehandle is returned and the +file will automatically be deleted when closed on operating systems +that support this (see the description of tmpfile() elsewhere in this +document). This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition by fumbling +with the filename. On systems that can not unlink an open file or can +not mark a file as temporary when it is opened (for example, Windows +NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when +the program ends (equivalent to setting UNLINK to 1). The C<UNLINK> +flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +If the operating system supports it (for example BSD derived systems), the +filehandle will be opened with O_EXLOCK (open with exclusive file lock). +This can sometimes cause problems if the intention is to pass the filename +to another system that expects to take an exclusive lock itself (such as +DBD::SQLite) whilst ensuring that the tempfile is not reused. In this +situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK +will be true (this retains compatibility with earlier releases). + + ($fh, $filename) = tempfile($template, EXLOCK => 0); + +Options can be combined as required. + +Will croak() if there is an error. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file + "TMPDIR" => 0, # Place tempfile in tempdir if template specified + "EXLOCK" => 1, # Open file with O_EXLOCK + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + # End up with current directory if neither DIR not TMPDIR are set + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + $template = File::Spec->catfile(File::Spec->tmpdir, $template ); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it (which may be + # important if they want a child process to use the file) + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + + # Create the file + my ($fh, $path, $errstr); + croak "Error in tempfile() using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "unlink_on_close" => $unlink_on_close, + "suffixlen" => length($options{'SUFFIX'}), + "ErrStr" => \$errstr, + "use_exlock" => $options{EXLOCK}, + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B<tempdir> + +This is the recommended interface for creation of temporary +directories. By default the directory will not be removed on exit +(that is, it won't be temporary; this behaviour can not be changed +because of issues with backwards compatibility). To enable removal +either use the CLEANUP option which will trigger removal on program +exit, or consider using the "newdir" method in the object interface which +will allow the directory to be cleaned up when the object goes out of +scope. + +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L<File::Spec|File::Spec>). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, create the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C<TMPDIR> option is ignored if C<DIR> is set +explicitly. Additionally, C<TMPDIR> is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L<File::Path|File::Path> module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +Will croak() if there is an error. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + + my $errstr; + croak "Error in tempdir() using $template: $errstr" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B<mkstemp> + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced +with unique alphanumeric combinations. + +Will croak() if there is an error. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path, $errstr); + croak "Error in mkstemp using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B<mkstemps> + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C<testXXXXXX> and suffix of C<.dat> +would generate a file similar to F<testhGji_w.dat>. + +Returns just the filehandle alone when called in scalar context. + +Will croak() if there is an error. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path, $errstr); + croak "Error in mkstemps using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B<mkdtemp> + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. + +Directory must be removed by the caller. + +Will croak() if there is an error. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + my ($junk, $tmpdir, $errstr); + croak "Error creating temp directory from template $template\: $errstr" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + return $tmpdir; + +} + +=item B<mktemp> + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +Will croak() if there is an error. + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk, $errstr); + croak "Error getting name to temp file from template $template: $errstr" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L<POSIX> +using the mkstemp() from this module. + +Unlike the L<POSIX|POSIX> implementations, the directory used +for the temporary file is not specified in a system include +file (C<P_tmpdir>) but simply depends on the choice of tmpdir() +returned by L<File::Spec|File::Spec>. On some implementations this +location can be set using the C<TMPDIR> environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B<tmpnam> + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L<File::Spec/tmpdir> for information on the choice of temporary +directory for a particular operating system. + +Will croak() if there is an error. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B<tmpfile> + +Returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +Will croak() if there is an error. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in a list context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + # This will fail on NFS + unlink0($fh, $file) + or return undef; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B<tempnam> + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C<sysopen> +with C<O_CREAT | O_EXCL> if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +Will croak() if there is an error. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B<unlink0> + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) + or die "Error unlinking file $path safely"; + +Returns false on error but croaks() if there is a security +anomaly. The filehandle is not closed since on some occasions this is +not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C<dev> and C<rdev> fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C<stat(FH)> being more accurate than +C<stat(filename)>, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C<unlink0> it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +This function is disabled if the global variable $KEEP_ALL is true +and an unlink on open file is supported. If the unlink is to be deferred +to the END block, the file is still registered for removal. + +This function should not be called if you are using the object oriented +interface since the it will interfere with the object destructor deleting +the file. + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + + # return early (Without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + my @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=item B<cmpstat> + +Compare C<stat> of filehandle with C<stat> of provided filename. This +can be used to check that the filename and filehandle initially point +to the same file and that the number of links to the file is 1 (all +fields returned by stat() are compared). + + cmpstat($fh, $path) + or die "Error comparing handle with file"; + +Returns false if the stat information differs or if the link count is +greater than 1. Calls croak if there is a security anomaly. + +On certain platforms, for example Windows, not all the fields returned by stat() +can be compared. For example, the C<dev> and C<rdev> fields seem to be +different in Windows. Also, it seems that the size of the file +returned by stat() does not always agree, with C<stat(FH)> being more +accurate than C<stat(filename)>, presumably because of caching issues +even when using autoflush (this is usually overcome by waiting a while +after writing to the tempfile before attempting to C<unlink0> it). + +Not exported by default. + +=cut + +sub cmpstat { + + croak 'Usage: cmpstat(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Comparing stat\n" + if $DEBUG; + + # Stat the filehandle - which may be closed if someone has manually + # closed the file. Can not turn off warnings without using $^W + # unless we upgrade to 5.006 minimum requirement + my @fh; + { + local ($^W) = 0; + @fh = stat $fh; + } + return unless @fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh" if $^W; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f $path) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); + } elsif ($^O eq 'mpeix') { + @okstat = (0..4,8..10); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + return 1; +} + +=item B<unlink1> + +Similar to C<unlink0> except after file comparison using cmpstat, the +filehandle is closed prior to attempting to unlink the file. This +allows the file to be removed without using an END block, but does +mean that the post-unlink comparison of the filehandle state provided +by C<unlink0> is not available. + + unlink1($fh, $path) + or die "Error closing and unlinking file"; + +Usually called from the object destructor when using the OO interface. + +Not exported by default. + +This function is disabled if the global variable $KEEP_ALL is true. + +Can call croak() if there is a security anomaly during the stat() +comparison. + +=cut + +sub unlink1 { + croak 'Usage: unlink1(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # Close the file + close( $fh ) or return 0; + + # Make sure the file is writable (for windows) + _force_writable( $path ); + + # return early (without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # remove the file + return unlink($path); +} + +=item B<cleanup> + +Calling this function will cause any temp files or temp directories +that are registered for removal to be removed. This happens automatically +when the process exits but can be triggered manually if the caller is sure +that none of the temp files are required. This method can be registered as +an Apache callback. + +On OSes where temp files are automatically removed when the temp file +is closed, calling this function will have no effect other than to remove +temporary directories (which may include temporary files). + + File::Temp::cleanup(); + +Not exported by default. + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B<safe_level> + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and is +writable, that temporary files are opened only if they do not already +exist, and that possible race conditions are avoided. Finally the +L<unlink0|"unlink0"> function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L<POSIX|POSIX> +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L<POSIX|POSIX> +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L<Fcntl|Fcntl> that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C<safe_level>. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Dont allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than +simply by root. + +This is required since on many unix systems C</tmp> is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C<safe_level> is set to MEDIUM or higher. + +=cut + +{ + my $TopSystemUID = 10; + $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=item B<$KEEP_ALL> + +Controls whether temporary files and directories should be retained +regardless of any instructions in the program to remove them +automatically. This is useful for debugging but should not be used in +production code. + + $File::Temp::KEEP_ALL = 1; + +Default is for files to be removed as requested by the caller. + +In some cases, files will only be retained if this variable is true +when the file is created. This means that you can not create a temporary +file, set this variable and expect the temp file to still be around +when the program exits. + +=item B<$DEBUG> + +Controls whether debugging messages should be enabled. + + $File::Temp::DEBUG = 1; + +Default is for debugging mode to be disabled. + +=back + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + +=head2 Forking + +In some cases files created by File::Temp are removed from within an +END block. Since END blocks are triggered when a child process exits +(unless C<POSIX::_exit()> is used by the child) File::Temp takes care +to only remove those temp files created by a particular process ID. This +means that a child will not attempt to remove temp files created by the +parent process. + +If you are forking many processes in parallel that are all creating +temporary files, you may need to reset the random number seed using +srand(EXPR) in each child else all the children will attempt to walk +through the same set of random file names and may well cause +themselves to give up if they exceed the number of retry attempts. + +=head2 Directory removal + +Note that if you have chdir'ed into the temporary directory and it is +subsequently cleaned up (either in the END block or as part of object +destruction), then you will get a warning from File::Path::rmtree(). + +=head2 BINMODE + +The file returned by File::Temp will have been opened in binary mode +if such a mode is available. If that is not correct, use the C<binmode()> +function to change the mode of the filehandle. + +Note that you can modify the encoding of a file opened by File::Temp +also by using C<binmode()>. + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. The module was shipped +as a standard part of perl from v5.6.1. + +=head1 SEE ALSO + +L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> + +See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for +different implementations of temporary file handling. + +See L<File::Tempdir> for an alternative object-oriented wrapper for +the C<tempdir> function. + +=head1 AUTHOR + +Tim Jenness E<lt>tjenness@cpan.orgE<gt> + +Copyright (C) 2007-2009 Tim Jenness. +Copyright (C) 1999-2007 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 + +package File::Temp::Dir; + +use File::Path qw/ rmtree /; +use strict; +use overload '""' => "STRINGIFY", fallback => 1; + +# private class specifically to support tempdir objects +# created by File::Temp->newdir + +# ostensibly the same method interface as File::Temp but without +# inheriting all the IO::Seekable methods and other cruft + +# Read-only - returns the name of the temp directory + +sub dirname { + my $self = shift; + return $self->{DIRNAME}; +} + +sub STRINGIFY { + my $self = shift; + return $self->dirname; +} + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + $self->{CLEANUP} = shift; + } + return $self->{CLEANUP}; +} + +sub DESTROY { + my $self = shift; + local($., $@, $!, $^E, $?); + if ($self->unlink_on_destroy && + $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { + if (-d $self->{DIRNAME}) { + # Some versions of rmtree will abort if you attempt to remove + # the directory you are sitting in. We protect that and turn it + # into a warning. We do this because this occurs during object + # destruction and so can not be caught by the user. + eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + } +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/File/Which.pm b/Master/tlpkg/tlperl/lib/File/Which.pm new file mode 100755 index 00000000000..69e336b03bd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Which.pm @@ -0,0 +1,254 @@ +package File::Which; + +use 5.004; +use strict; +use Exporter (); +use File::Spec (); + +use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK}; +BEGIN { + $VERSION = '1.09'; + @ISA = 'Exporter'; + @EXPORT = 'which'; + @EXPORT_OK = 'where'; +} + +use constant IS_VMS => ($^O eq 'VMS'); +use constant IS_MAC => ($^O eq 'MacOS'); +use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2'); + +# For Win32 systems, stores the extensions used for +# executable files +# For others, the empty string is used +# because 'perl' . '' eq 'perl' => easier +my @PATHEXT = (''); +if ( IS_DOS ) { + # WinNT. PATHEXT might be set on Cygwin, but not used. + if ( $ENV{PATHEXT} ) { + push @PATHEXT, split ';', $ENV{PATHEXT}; + } else { + # Win9X or other: doesn't have PATHEXT, so needs hardcoded. + push @PATHEXT, qw{.com .exe .bat}; + } +} elsif ( IS_VMS ) { + push @PATHEXT, qw{.exe .com}; +} + +sub which { + my ($exec) = @_; + + return undef unless $exec; + + my $all = wantarray; + my @results = (); + + # check for aliases first + if ( IS_VMS ) { + my $symbol = `SHOW SYMBOL $exec`; + chomp($symbol); + unless ( $? ) { + return $symbol unless $all; + push @results, $symbol; + } + } + if ( IS_MAC ) { + my @aliases = split /\,/, $ENV{Aliases}; + foreach my $alias ( @aliases ) { + # This has not been tested!! + # PPT which says MPW-Perl cannot resolve `Alias $alias`, + # let's just hope it's fixed + if ( lc($alias) eq lc($exec) ) { + chomp(my $file = `Alias $alias`); + last unless $file; # if it failed, just go on the normal way + return $file unless $all; + push @results, $file; + # we can stop this loop as if it finds more aliases matching, + # it'll just be the same result anyway + last; + } + } + } + + my @path = File::Spec->path; + if ( IS_DOS or IS_VMS or IS_MAC ) { + unshift @path, File::Spec->curdir; + } + + foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) { + for my $ext ( @PATHEXT ) { + my $file = $base.$ext; + + # We don't want dirs (as they are -x) + next if -d $file; + + if ( + # Executable, normal case + -x _ + or ( + # MacOS doesn't mark as executable so we check -e + IS_MAC + || + ( + IS_DOS + and + grep { + $file =~ /$_\z/i + } @PATHEXT[1..$#PATHEXT] + ) + # DOSish systems don't pass -x on + # non-exe/bat/com files. so we check -e. + # However, we don't want to pass -e on files + # that aren't in PATHEXT, like README. + and -e _ + ) + ) { + return $file unless $all; + push @results, $file; + } + } + } + + if ( $all ) { + return @results; + } else { + return undef; + } +} + +sub where { + # force wantarray + my @res = which($_[0]); + return @res; +} + +1; + +__END__ + +=pod + +=head1 NAME + +File::Which - Portable implementation of the `which' utility + +=head1 SYNOPSIS + + use File::Which; # exports which() + use File::Which qw(which where); # exports which() and where() + + my $exe_path = which('perldoc'); + + my @paths = where('perl'); + - Or - + my @paths = which('perl'); # an array forces search for all of them + +=head1 DESCRIPTION + +C<File::Which> was created to be able to get the paths to executable programs +on systems under which the `which' program wasn't implemented in the shell. + +C<File::Which> searches the directories of the user's C<PATH> (as returned by +C<File::Spec-E<gt>path()>), looking for executable files having the name +specified as a parameter to C<which()>. Under Win32 systems, which do not have a +notion of directly executable files, but uses special extensions such as C<.exe> +and C<.bat> to identify them, C<File::Which> takes extra steps to assure that +you will find the correct file (so for example, you might be searching for +C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.) + +=head1 Steps Used on Win32, DOS, OS2 and VMS + +=head2 Windows NT + +Windows NT has a special environment variable called C<PATHEXT>, which is used +by the shell to look for executable files. Usually, it will contain a list in +the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an +environment variable, it parses the list and uses it as the different +extensions. + +=head2 Windows 9x and other ancient Win/DOS/OS2 + +This set of operating systems don't have the C<PATHEXT> variable, and usually +you will find executable files there with the extensions C<.exe>, C<.bat> and +(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running +under Win32 but does not find a C<PATHEXT> variable. + +=head2 VMS + +Same case as Windows 9x: uses C<.exe> and C<.com> (in that order). + +=head1 Functions + +=head2 which($short_exe_name) + +Exported by default. + +C<$short_exe_name> is the name used in the shell to call the program (for +example, C<perl>). + +If it finds an executable with the name you specified, C<which()> will return +the absolute path leading to this executable (for example, F</usr/bin/perl> or +F<C:\Perl\Bin\perl.exe>). + +If it does I<not> find the executable, it returns C<undef>. + +If C<which()> is called in list context, it will return I<all> the +matches. + +=head2 where($short_exe_name) + +Not exported by default. + +Same as C<which($short_exe_name)> in array context. Same as the +C<`where'> utility, will return an array containing all the path names +matching C<$short_exe_name>. + +=head1 BUGS AND CAVEATS + +Not tested on VMS or MacOS, although there is platform specific code +for those. Anyone who haves a second would be very kind to send me a +report of how it went. + +File::Spec adds the current directory to the front of PATH if on +Win32, VMS or MacOS. I have no knowledge of those so don't know if the +current directory is searced first or not. Could someone please tell +me? + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which> + +For other issues, contact the maintainer. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt> + +Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet +(for the mod_perl site) and Win32-awareness by me, with slight modifications +by Stas Bekman, then extracted to create C<File::Which>. + +Version 0.04 had some significant platform-related changes, taken from +the Perl Power Tools C<`which'> implementation by Abigail with +enhancements from Peter Prymmer. See +L<http://www.perl.com/language/ppt/src/which/index.html> for more +information. + +=head1 COPYRIGHT + +Copyright 2002 Per Einar Ellefsen. + +Some parts copyright 2009 Adam Kennedy. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Spec>, L<which(1)>, Perl Power Tools: +L<http://www.perl.com/language/ppt/index.html>. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/chmod.pm b/Master/tlpkg/tlperl/lib/File/chmod.pm new file mode 100755 index 00000000000..ed49239b265 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/chmod.pm @@ -0,0 +1,647 @@ +package File::chmod; + +use Carp; +use strict; +use vars qw( + $VERSION @ISA @EXPORT @EXPORT_OK $DEBUG + $UMASK $MASK $VAL $W $MODE +); + +require Exporter; + +@ISA = qw( Exporter ); +@EXPORT = qw( chmod getchmod ); +@EXPORT_OK = qw( symchmod lschmod getsymchmod getlschmod getmod ); + +$VERSION = '0.32'; +$DEBUG = 1; +$UMASK = 1; +$MASK = umask; + +my ($SYM,$LS) = (1,2); +my %ERROR = ( + EDETMOD => "use of determine_mode is deprecated", + ENEXLOC => "cannot set group execute on locked file", + ENLOCEX => "cannot set file locking on group executable file", + ENSGLOC => "cannot set-gid on locked file", + ENLOCSG => "cannot set file locking on set-gid file", + ENEXUID => "execute bit must be on for set-uid", + ENEXGID => "execute bit must be on for set-gid", + ENULSID => "set-id has no effect for 'others'", + ENULSBG => "sticky bit has no effect for 'group'", + ENULSBO => "sticky bit has no effect for 'others'", +); + + +sub getmod { + my @return = map { (stat)[2] & 07777 } @_; + return wantarray ? @return : $return[0]; +} + + +sub chmod { + my $mode = shift; + my $how = mode($mode); + + return symchmod($mode,@_) if $how == $SYM; + return lschmod($mode,@_) if $how == $LS; + return CORE::chmod($mode,@_); +} + + +sub getchmod { + my $mode = shift; + my $how = mode($mode); + + return getsymchmod($mode,@_) if $how == $SYM; + return getlschmod($mode,@_) if $how == $LS; + return wantarray ? (($mode) x @_) : $mode; +} + + +sub symchmod { + my $mode = shift; + my @return = getsymchmod($mode,@_); + my $ret = 0; + for (@_){ $ret++ if CORE::chmod(shift(@return),$_) } + return $ret; +} + + +sub getsymchmod { + my $mode = shift; + my @return; + + croak "symchmod received non-symbolic mode: $mode" if mode($mode) != $SYM; + + for (@_){ + local $VAL = getmod($_); + + for my $this (split /,/, $mode){ + local $W = 0; + my $or; + + for (split //, $this){ + if (not defined $or and /[augo]/){ + /a/ and $W |= 7, next; + /u/ and $W |= 1, next; + /g/ and $W |= 2, next; + /o/ and $W |= 4, next; + } + + if (/[-+=]/){ + $W ||= 7; + $or = (/[=+]/ ? 1 : 0); + clear() if /=/; + next; + } + + croak "Bad mode $this" if not defined $or; + croak "Unknown mode: $mode" if !/[ugorwxslt]/; + + /u/ and $or ? u_or() : u_not(); + /g/ and $or ? g_or() : g_not(); + /o/ and $or ? o_or() : o_not(); + /r/ and $or ? r_or() : r_not(); + /w/ and $or ? w_or() : w_not(); + /x/ and $or ? x_or() : x_not(); + /s/ and $or ? s_or() : s_not(); + /l/ and $or ? l_or() : l_not(); + /t/ and $or ? t_or() : t_not(); + } + } + $VAL &= ~$MASK if $UMASK; + push @return, $VAL; + } + return wantarray ? @return : $return[0]; +} + + +sub lschmod { + my $mode = shift; + return CORE::chmod(getlschmod($mode,@_),@_); +} + + +sub getlschmod { + my $mode = shift; + my $VAL = 0; + + croak "lschmod received non-ls mode: $mode" if mode($mode) != $LS; + + my ($u,$g,$o) = ($mode =~ /^.(...)(...)(...)$/); + + for ($u){ + $VAL |= 0400 if /r/; + $VAL |= 0200 if /w/; + $VAL |= 0100 if /[xs]/; + $VAL |= 04000 if /[sS]/; + } + + for ($g){ + $VAL |= 0040 if /r/; + $VAL |= 0020 if /w/; + $VAL |= 0010 if /[xs]/; + $VAL |= 02000 if /[sS]/; + } + + for ($o){ + $VAL |= 0004 if /r/; + $VAL |= 0002 if /w/; + $VAL |= 0001 if /[xt]/; + $VAL |= 01000 if /[Tt]/; + } + + return wantarray ? (($VAL) x @_) : $VAL; +} + + +sub mode { + my $mode = shift; + return 0 if $mode !~ /\D/; + return $SYM if $mode =~ /[augo=+,]/; + return $LS if $mode =~ /^.([r-][w-][xSs-]){2}[r-][w-][xTt-]$/; + return $SYM; +} + + +sub determine_mode { + warn $ERROR{EDECMOD}; + mode(@_); +} + + +sub clear { + $W & 1 and $VAL &= 02077; + $W & 2 and $VAL &= 05707; + $W & 4 and $VAL &= 07770; +} + + +sub u_or { + my $val = $VAL; + $W & 2 and ($VAL |= (($val & 0700)>>3 | ($val & 04000)>>1)); + $W & 4 and ($VAL |= (($val & 0700)>>6)); +} + + +sub u_not { + my $val = $VAL; + $W & 1 and $VAL &= ~(($val & 0700) | ($val & 05000)); + $W & 2 and $VAL &= ~(($val & 0700)>>3 | ($val & 04000)>>1); + $W & 4 and $VAL &= ~(($val & 0700)>>6); +} + + +sub g_or { + my $val = $VAL; + $W & 1 and $VAL |= (($val & 070)<<3 | ($val & 02000)<<1); + $W & 4 and $VAL |= ($val & 070)>>3; +} + + +sub g_not { + my $val = $VAL; + $W & 1 and $VAL &= ~(($val & 070)<<3 | ($val & 02000)<<1); + $W & 2 and $VAL &= ~(($val & 070) | ($val & 02000)); + $W & 4 and $VAL &= ~(($val & 070)>>3); +} + + +sub o_or { + my $val = $VAL; + $W & 1 and $VAL |= (($val & 07)<<6); + $W & 2 and $VAL |= (($val & 07)<<3); +} + + +sub o_not { + my $val = $VAL; + $W & 1 and $VAL &= ~(($val & 07)<<6); + $W & 2 and $VAL &= ~(($val & 07)<<3); + $W & 4 and $VAL &= ~($val & 07); +} + + +sub r_or { + $W & 1 and $VAL |= 0400; + $W & 2 and $VAL |= 0040; + $W & 4 and $VAL |= 0004; +} + + +sub r_not { + $W & 1 and $VAL &= ~0400; + $W & 2 and $VAL &= ~0040; + $W & 4 and $VAL &= ~0004; +} + + +sub w_or { + $W & 1 and $VAL |= 0200; + $W & 2 and $VAL |= 0020; + $W & 4 and $VAL |= 0002; +} + + +sub w_not { + $W & 1 and $VAL &= ~0200; + $W & 2 and $VAL &= ~0020; + $W & 4 and $VAL &= ~0002; +} + + +sub x_or { + if ($VAL & 02000){ $DEBUG and warn($ERROR{ENEXLOC}), return } + $W & 1 and $VAL |= 0100; + $W & 2 and $VAL |= 0010; + $W & 4 and $VAL |= 0001; +} + + +sub x_not { + $W & 1 and $VAL &= ~0100; + $W & 2 and $VAL &= ~0010; + $W & 4 and $VAL &= ~0001; +} + + +sub s_or { + if ($VAL & 02000){ $DEBUG and warn($ERROR{ENSGLOC}), return } + if (not $VAL & 00100){ $DEBUG and warn($ERROR{ENEXUID}), return } + if (not $VAL & 00010){ $DEBUG and warn($ERROR{ENEXGID}), return } + $W & 1 and $VAL |= 04000; + $W & 2 and $VAL |= 02000; + $W & 4 and $DEBUG and warn $ERROR{ENULSID}; +} + + +sub s_not { + $W & 1 and $VAL &= ~04000; + $W & 2 and $VAL &= ~02000; + $W & 4 and $DEBUG and warn $ERROR{ENULSID}; +} + + +sub l_or { + if ($VAL & 02010){ $DEBUG and warn($ERROR{ENLOCSG}), return } + if ($VAL & 00010){ $DEBUG and warn($ERROR{ENLOCEX}), return } + $VAL |= 02000; +} + + +sub l_not { + $VAL &= ~02000 if not $VAL & 00010; +} + + +sub t_or { + $W & 1 and $VAL |= 01000; + $W & 2 and $DEBUG and warn $ERROR{ENULSBG}; + $W & 4 and $DEBUG and warn $ERROR{ENULSBO}; +} + + +sub t_not { + $W & 1 and $VAL &= ~01000; + $W & 2 and $DEBUG and warn $ERROR{ENULSBG}; + $W & 4 and $DEBUG and warn $ERROR{ENULSBO}; +} + + +1; + +__END__ + +=head1 NAME + +File::chmod - Implements symbolic and ls chmod modes + +=head1 VERSION + +This is File::chmod v0.32. + +=head1 SYNOPSIS + + use File::chmod; + + # chmod takes all three types + # these all do the same thing + chmod(0666,@files); + chmod("=rw",@files); + chmod("-rw-rw-rw-",@files); + + # or + + use File::chmod qw( symchmod lschmod ); + + chmod(0666,@files); # this is the normal chmod + symchmod("=rw",@files); # takes symbolic modes only + lschmod("-rw-rw-rw-",@files); # takes "ls" modes only + + # more functions, read on to understand + +=head1 DESCRIPTION + +File::chmod is a utility that allows you to bypass system calls or bit +processing of a file's permissions. It overloads the chmod() function +with its own that gets an octal mode, a symbolic mode (see below), or +an "ls" mode (see below). If you wish not to overload chmod(), you can +export symchmod() and lschmod(), which take, respectively, a symbolic +mode and an "ls" mode. + +Symbolic modes are thoroughly described in your chmod(1) man page, but +here are a few examples. + + # NEW: if $UMASK is true, symchmod() applies a bit-mask found in $MASK + + chmod("+x","file1","file2"); # overloaded chmod(), that is... + # turns on the execute bit for all users on those two files + + chmod("o=,g-w","file1","file2"); + # removes 'other' permissions, and the write bit for 'group' + + chmod("=u","file1","file2"); + # sets all bits to those in 'user' + +"ls" modes are the type produced on the left-hand side of an C<ls -l> on a +directory. Examples are: + + chmod("-rwxr-xr-x","file1","file2"); + # the 0755 setting; user has read-write-execute, group and others + # have read-execute priveleges + + chmod("-rwsrws---","file1","file2"); + # sets read-write-execute for user and group, none for others + # also sets set-uid and set-gid bits + +The regular chmod() and lschmod() are absolute; that is, they are not +appending to or subtracting from the current file mode. They set it, +regardless of what it had been before. symchmod() is useful for allowing +the modifying of a file's permissions without having to run a system call +or determining the file's permissions, and then combining that with whatever +bits are appropriate. It also operates separately on each file. + +An added feature to version 0.30 is the $UMASK variable, explained below; if +symchmod() is called and this variable is true, then the function uses the +(also new) $MASK variable (which defaults to umask()) as a mask against the +new mode. This is documented below more clearly. + +=head2 Functions + +Exported by default: + +=over 4 + +=item chmod(MODE,FILES) + +Takes an octal, symbolic, or "ls" mode, and then chmods each file +appropriately. + +=item getchmod(MODE,FILES) + +Returns a list of modified permissions, without chmodding files. +Accepts any of the three kinds of modes. + + @newmodes = getchmod("+x","file1","file2"); + # @newmodes holds the octal permissons of the files' + # modes, if they were to be sent through chmod("+x"...) + +=back + +Exported by request: + +=over 4 + +=item symchmod(MODE,FILES) + +Takes a symbolic permissions mode, and chmods each file. + +=item lschmod(MODE,FILES) + +Takes an "ls" permissions mode, and chmods each file. + +=item getsymchmod(MODE,FILES) + +Returns a list of modified permissions, without chmodding files. +Accepts only symbolic permisson modes. + +=item getlschmod(MODE,FILES) + +Returns a list of modified permissions, without chmodding files. +Accepts only "ls" permisson modes. + +=item getmod(FILES) + +Returns a list of the current mode of each file. + +=back + +=head2 Variables + +=over 4 + +=item $File::chmod::DEBUG + +If set to a true value, it will report warnings, similar to those produced +by chmod() on your system. Otherwise, the functions will not report errors. +Example: a file can not have file-locking and the set-gid bits on at the +same time. If $File::chmod::DEBUG is true, the function will report an +error. If not, you are not warned of the conflict. It is set to 1 as +default. + +=item $File::chmod::MASK + +Contains the umask to apply to new file modes when using getsymchmod(). This +defaults to the return value of umask() at compile time. Is only applied if +$UMASK is true. + +=item $File::chmod::UMASK + +This is a boolean which tells getsymchmod() whether or not to apply the umask +found in $MASK. It defaults to true. + +=back + +=head1 REVISIONS + +I<Note: this section was started with version 0.30.> + +This is an in-depth look at the changes being made from version to version. + +=head2 0.31 to 0.32 + +=over 4 + +=item B<license added> + +I added a license to this module so that it can be used places without asking +my permission. Sorry, Adam. + +=back + +=head2 0.30 to 0.31 + +=over 4 + +=item B<fixed getsymchmod() bug> + +Whoa. getsymchmod() was doing some crazy ish. That's about all I can say. +I did a great deal of debugging, and fixed it up. It ALL had to do with two +things: + + $or = (/+=/ ? 1 : 0); # should have been /[+=]/ + + /u/ && $ok ? u_or() : u_not(); # should have been /u/ and $ok + +=item B<fixed getmod() bug> + +I was using map() incorrectly in getmod(). Fixed that. + +=item B<condensed lschmod()> + +I shorted it up, getting rid a variable. + +=back + +=head2 0.21 to 0.30 + +=over 4 + +=item B<added umask() honoring for symchmod()> + +The symchmod() function now honors the $UMASK and $MASK variables. $UMASK is +a boolean which indicates whether or not to honor the $MASK variable. $MASK +holds a umask, and it defaults to umask(). $UMASK defaults to true. These +variables are NOT exported. They must explictly set (i.e. $File::chmod::UMASK += 0). + +=item B<function name changes> + +Renamed internal function determine_mode() to mode(). However, if you happen +to be using determine_mode() somewhere, mode() will be called, but you'll also +get a warning about deprecation. + +Renamed internal functions {or,not}_{l,s,t} to {l,s,t}_{or,not}. This is to +keep in standard with the OTHER 6 pairs of bitwise functions, such as r_or() +and g_not(). I don't know WHY the others had 'not' or 'or' in the front. + +=item B<fixed debugging bugs> + +Certain calls to warn() were not guarded by the $DEBUG variable, and now they +are. Also, for some reason, I left a debugging check (that didn't check to +see if $DEBUG was true) in getsymchmod(), line 118. It printed "ENTERING /g/". +It's gone now. + +=item B<fixed set-uid and set-gid bug> + +Heh, it seems that in the previous version of File::chmod, the following code +went along broken: + + # or_s sub, File/chmod.pm, v0.21, line 330 + ($VAL & 00100) && do { + $DEBUG && warn("execute bit must be on for set-uid"); 1; + } && next; + +Aside from me using '&&' more than enough (changed in the new code), this is +broken. This is now fixed. + +=item B<fixed file lock/set-gid bug> + +The not_l() function (now renamed to l_not()) used to take the file mode and +bit-wise NOT it with ~02000. However, it did not check if the file was locked +vs. set-gid. Now, the function is C<$VAL &= ~02000 if not $VAL & 00010;>. + +=item B<removed useless data structures> + +I do not know why I had the $S variable, or %r, %w, and %x hashes. In fact, +$S was declared in C<use vars qw( ... );>, but never given a value, and the +%r, %w, and %x hashes had a 'full' key which never got used. And the hashes +themselves weren't really needed anyway. Here is a list of the variables no +longer in use, and what they have been replaced with (if any): + + $S nothing + $U, $G, $O $W + %r, %w, %x octal numbers + @files @_ (I had @files = @_; in nearly EVERY sub) + $c $_ + +=item B<compacted code> + +The first version of File::chmod that was published was 0.13, and it was +written in approximately 10 days, being given the off-and-on treatment I end +up having to give several projects, due to more pressing matters. Well, since +then, most of the code has stayed the same, although bugs were worked out. +Well, I got rid of a lot of slow, clunky, and redundant sections of code in +this version. Sections include the processing of each character of the mode +in getsymchmod(), the getmod() subroutine, um, nearly ALL of the getsymchmod() +function, now that I look at it. + +Here's part of the getsymchmod() rewrite: + + for ($c){ + if (/u/){ + u_or() if $MODE eq "+" or $MODE eq "="; + u_not() if $MODE eq "-"; + } + ... + } + + # changed to + + /u/ && $or ? u_or() : u_and(); + # note: operating on $_, $c isn't used anymore + # note: $or holds 1 if the $MODE was + or =, 0 if $MODE was - + # note: previous was redundant. didn't need $MODE eq "-" check + # because u_or() and u_not() both go to the next character + +=back + +=head1 PORTING + +This is only good on Unix-like boxes. I would like people to help me work on +File::chmod for any OS that deserves it. If you would like to help, please +email me (address below) with the OS and any information you might have on how +chmod() should work on it; if you don't have any specific information, but +would still like to help, hey, that's good too. I have the following +information (from L</perlport>): + +=over 4 + +=item Win32 + +Only good for changing "owner" read-write access, "group", and "other" bits +are meaningless. I<NOTE: Win32::File and Win32::FileSecurity already do +this. I do not currently see a need to port File::chmod.> + +=item MacOS + +Only limited meaning. Disabling/enabling write permission is mapped to +locking/unlocking the file. + +=item RISC OS + +Only good for changing "owner" and "other" read-write access. + +=back + +=head1 AUTHOR + +Jeff C<japhy> Pinyan, F<japhy.734+CPAN@gmail.com>, CPAN ID: PINYAN + +=head1 SEE ALSO + + Stat::lsMode (by Mark-James Dominus, CPAN ID: MJD) + chmod(1) manpage + perldoc -f chmod + perldoc -f stat + +=head1 COPYRIGHT AND LICENCE + +Copyright (C) 2007 by Jeff Pinyan + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.8 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/pushd.pm b/Master/tlpkg/tlperl/lib/File/pushd.pm new file mode 100755 index 00000000000..0c3666d3d9d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/pushd.pm @@ -0,0 +1,229 @@ +package File::pushd; + +$VERSION = '1.00'; +@EXPORT = qw( pushd tempd ); +@ISA = qw( Exporter ); + +use 5.004; +use strict; +#use warnings; +use Exporter; +use Carp; +use Cwd qw( cwd abs_path ); +use File::Path qw( rmtree ); +use File::Temp qw(); +use File::Spec; + +use overload + q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) }, + fallback => 1; + +#--------------------------------------------------------------------------# +# pushd() +#--------------------------------------------------------------------------# + +sub pushd { + my ($target_dir) = @_; + + my $orig = cwd; + + my $dest; + eval { $dest = $target_dir ? abs_path( $target_dir ) : $orig }; + + croak "Can't locate directory $target_dir: $@" if $@; + + if ($dest ne $orig) { + chdir $dest or croak "Can't chdir to $dest\: $!"; + } + + my $self = bless { + _pushd => $dest, + _original => $orig + }, __PACKAGE__; + + return $self; +} + +#--------------------------------------------------------------------------# +# tempd() +#--------------------------------------------------------------------------# + +sub tempd { + my $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ) ); + $dir->{_tempd} = 1; + return $dir; +} + +#--------------------------------------------------------------------------# +# preserve() +#--------------------------------------------------------------------------# + +sub preserve { + my $self = shift; + return 1 if ! $self->{"_tempd"}; + if ( @_ == 0 ) { + return $self->{_preserve} = 1; + } + else { + return $self->{_preserve} = $_[0] ? 1 : 0; + } +} + +#--------------------------------------------------------------------------# +# DESTROY() +# Revert to original directory as object is destroyed and cleanup +# if necessary +#--------------------------------------------------------------------------# + +sub DESTROY { + my ($self) = @_; + my $orig = $self->{_original}; + chdir $orig if $orig; # should always be so, but just in case... + if ( $self->{_tempd} && + !$self->{_preserve} ) { + eval { rmtree( $self->{_pushd} ) }; + carp $@ if $@; + } +} + +1; #this line is important and will help the module return a true value +__END__ + +=begin wikidoc + += NAME + +File::pushd - change directory temporarily for a limited scope + += VERSION + +This documentation describes version %%VERSION%%. + += SYNOPSIS + + use File::pushd; + + chdir $ENV{HOME}; + + # change directory again for a limited scope + { + my $dir = pushd( '/tmp' ); + # working directory changed to /tmp + } + # working directory has reverted to $ENV{HOME} + + # tempd() is equivalent to pushd( File::Temp::tempdir ) + { + my $dir = tempd(); + } + + # object stringifies naturally as an absolute path + { + my $dir = pushd( '/tmp' ); + my $filename = File::Spec->catfile( $dir, "somefile.txt" ); + # gives /tmp/somefile.txt + } + += DESCRIPTION + +File::pushd does a temporary {chdir} that is easily and automatically +reverted, similar to {pushd} in some Unix command shells. It works by +creating an object that caches the original working directory. When the object +is destroyed, the destructor calls {chdir} to revert to the original working +directory. By storing the object in a lexical variable with a limited scope, +this happens automatically at the end of the scope. + +This is very handy when working with temporary directories for tasks like +testing; a function is provided to streamline getting a temporary +directory from [File::Temp]. + +For convenience, the object stringifies as the canonical form of the absolute +pathname of the directory entered. + += USAGE + + use File::pushd; + +Using File::pushd automatically imports the {pushd} and {tempd} functions. + +== pushd + + { + my $dir = pushd( $target_directory ); + } + +Caches the current working directory, calls {chdir} to change to the target +directory, and returns a File::pushd object. When the object is +destroyed, the working directory reverts to the original directory. + +The provided target directory can be a relative or absolute path. If +called with no arguments, it uses the current directory as its target and +returns to the current directory when the object is destroyed. + +== tempd + + { + my $dir = tempd(); + } + +This function is like {pushd} but automatically creates and calls {chdir} to +a temporary directory created by [File::Temp]. Unlike normal [File::Temp] +cleanup which happens at the end of the program, this temporary directory is +removed when the object is destroyed. (But also see {preserve}.) A warning +will be issued if the directory cannot be removed. + +== preserve + + { + my $dir = tempd(); + $dir->preserve; # mark to preserve at end of scope + $dir->preserve(0); # mark to delete at end of scope + } + +Controls whether a temporary directory will be cleaned up when the object is +destroyed. With no arguments, {preserve} sets the directory to be preserved. +With an argument, the directory will be preserved if the argument is true, or +marked for cleanup if the argument is false. Only {tempd} objects may be +marked for cleanup. (Target directories to {pushd} are always preserved.) +{preserve} returns true if the directory will be preserved, and false +otherwise. + += SEE ALSO + +* [File::chdir] + += BUGS + +Please report any bugs or feature using the CPAN Request Tracker. +Bugs can be submitted through the web interface at +[http://rt.cpan.org/Dist/Display.html?Queue=File-pushd] + +When submitting a bug or request, please include a test-file or a patch to an +existing test-file that illustrates the bug or desired feature. + += AUTHOR + +David A. Golden (DAGOLDEN) + += COPYRIGHT AND LICENSE + +Copyright (c) 2005, 2006, 2007 by David A. Golden + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at +[http://www.apache.org/licenses/LICENSE-2.0] + +Files produced as output though the use of this software, including +generated copies of boilerplate templates provided with this software, +shall not be considered Derivative Works, but shall be considered the +original work of the Licensor. + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +=end wikidoc + diff --git a/Master/tlpkg/tlperl/lib/File/pushd.pod b/Master/tlpkg/tlperl/lib/File/pushd.pod new file mode 100755 index 00000000000..068fa4b1e77 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/pushd.pod @@ -0,0 +1,145 @@ +# Generated by Pod::WikiDoc version 0.17 + +=pod + +=head1 NAME + +File::pushd - change directory temporarily for a limited scope + +=head1 VERSION + +This documentation describes version 1.00. + +=head1 SYNOPSIS + + use File::pushd; + + chdir $ENV{HOME}; + + # change directory again for a limited scope + { + my $dir = pushd( '/tmp' ); + # working directory changed to /tmp + } + # working directory has reverted to $ENV{HOME} + + # tempd() is equivalent to pushd( File::Temp::tempdir ) + { + my $dir = tempd(); + } + + # object stringifies naturally as an absolute path + { + my $dir = pushd( '/tmp' ); + my $filename = File::Spec->catfile( $dir, "somefile.txt" ); + # gives /tmp/somefile.txt + } + +=head1 DESCRIPTION + +File::pushd does a temporary C<<< chdir >>> that is easily and automatically +reverted, similar to C<<< pushd >>> in some Unix command shells. It works by +creating an object that caches the original working directory. When the object +is destroyed, the destructor calls C<<< chdir >>> to revert to the original working +directory. By storing the object in a lexical variable with a limited scope, +this happens automatically at the end of the scope. + +This is very handy when working with temporary directories for tasks like +testing; a function is provided to streamline getting a temporary +directory from L<File::Temp>. + +For convenience, the object stringifies as the canonical form of the absolute +pathname of the directory entered. + +=head1 USAGE + + use File::pushd; + +Using File::pushd automatically imports the C<<< pushd >>> and C<<< tempd >>> functions. + +=head2 pushd + + { + my $dir = pushd( $target_directory ); + } + +Caches the current working directory, calls C<<< chdir >>> to change to the target +directory, and returns a File::pushd object. When the object is +destroyed, the working directory reverts to the original directory. + +The provided target directory can be a relative or absolute path. If +called with no arguments, it uses the current directory as its target and +returns to the current directory when the object is destroyed. + +=head2 tempd + + { + my $dir = tempd(); + } + +This function is like C<<< pushd >>> but automatically creates and calls C<<< chdir >>> to +a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp> +cleanup which happens at the end of the program, this temporary directory is +removed when the object is destroyed. (But also see C<<< preserve >>>.) A warning +will be issued if the directory cannot be removed. + +=head2 preserve + + { + my $dir = tempd(); + $dir->preserve; # mark to preserve at end of scope + $dir->preserve(0); # mark to delete at end of scope + } + +Controls whether a temporary directory will be cleaned up when the object is +destroyed. With no arguments, C<<< preserve >>> sets the directory to be preserved. +With an argument, the directory will be preserved if the argument is true, or +marked for cleanup if the argument is false. Only C<<< tempd >>> objects may be +marked for cleanup. (Target directories to C<<< pushd >>> are always preserved.) +C<<< preserve >>> returns true if the directory will be preserved, and false +otherwise. + +=head1 SEE ALSO + +=over + +=item * + +L<File::chdir> + +=back + +=head1 BUGS + +Please report any bugs or feature using the CPAN Request Tracker. +Bugs can be submitted through the web interface at +L<http://rt.cpan.org/Dist/Display.html?Queue=File-pushd> + +When submitting a bug or request, please include a test-file or a patch to an +existing test-file that illustrates the bug or desired feature. + +=head1 AUTHOR + +David A. Golden (DAGOLDEN) + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005, 2006, 2007 by David A. Golden + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at +L<http://www.apache.org/licenses/LICENSE-2.0> + +Files produced as output though the use of this software, including +generated copies of boilerplate templates provided with this software, +shall not be considered Derivative Works, but shall be considered the +original work of the Licensor. + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + + diff --git a/Master/tlpkg/tlperl/lib/File/stat.pm b/Master/tlpkg/tlperl/lib/File/stat.pm new file mode 100755 index 00000000000..d84500c1ace --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/stat.pm @@ -0,0 +1,139 @@ +package File::stat; +use 5.006; + +use strict; +use warnings; + +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); + +our $VERSION = '1.01'; + +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 |