diff options
Diffstat (limited to 'Master/tlpkg/installer/perllib/File')
19 files changed, 0 insertions, 9327 deletions
diff --git a/Master/tlpkg/installer/perllib/File/Basename.pm b/Master/tlpkg/installer/perllib/File/Basename.pm deleted file mode 100644 index 837b753972a..00000000000 --- a/Master/tlpkg/installer/perllib/File/Basename.pm +++ /dev/null @@ -1,398 +0,0 @@ -=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.74"; - -fileparse_set_fstype($^O); - - -=over 4 - -=item C<fileparse> - - my($filename, $directories, $suffix) = fileparse($path); - my($filename, $directories, $suffix) = fileparse($path, @suffixes); - my $filename = fileparse($path, @suffixes); - -The C<fileparse()> routine divides a file path into its $directories, $filename -and (optionally) the filename $suffix. - -$directories contains everything up to and including the last -directory separator in the $path including the volume (if applicable). -The remainder of the $path is the $filename. - - # On Unix returns ("baz", "/foo/bar/", "") - fileparse("/foo/bar/baz"); - - # On Windows returns ("baz", "C:\foo\bar\", "") - fileparse("C:\foo\bar\baz"); - - # On Unix returns ("", "/foo/bar/baz/", "") - fileparse("/foo/bar/baz/"); - -If @suffixes are given each element is a pattern (either a string or a -C<qr//>) matched against the end of the $filename. The matching -portion is removed and becomes the $suffix. - - # On Unix returns ("baz", "/foo/bar", ".txt") - fileparse("/foo/bar/baz", qr/\.[^.]*/); - -If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern -matching for suffix removal is performed case-insensitively, since -those systems are not case-sensitive when opening existing files. - -You are guaranteed that C<$directories . $filename . $suffix> will -denote the same location as the original $path. - -=cut - - -sub fileparse { - my($fullname,@suffices) = @_; - - unless (defined $fullname) { - require Carp; - Carp::croak("fileparse(): need a valid pathname"); - } - - my $orig_type = ''; - my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); - - my($taint) = substr($fullname,0,0); # Is $fullname tainted? - - if ($type eq "VMS" and $fullname =~ m{/} ) { - # We're doing Unix emulation - $orig_type = $type; - $type = 'Unix'; - } - - my($dirpath, $basename); - - if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) { - ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); - $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; - } - elsif ($type eq "OS2") { - ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); - $dirpath = './' unless $dirpath; # Can't be 0 - $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; - } - elsif ($type eq "MacOS") { - ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); - $dirpath = ':' unless $dirpath; - } - elsif ($type eq "AmigaOS") { - ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); - $dirpath = './' unless $dirpath; - } - elsif ($type eq 'VMS' ) { - ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); - $dirpath ||= ''; # should always be defined - } - else { # Default to Unix semantics. - ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); - if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { - # dev:[000000] is top of VMS tree, similar to Unix '/' - # so strip it off and treat the rest as "normal" - my $devspec = $1; - my $remainder = $3; - ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); - $dirpath ||= ''; # should always be defined - $dirpath = $devspec.$dirpath; - } - $dirpath = './' unless $dirpath; - } - - - my $tail = ''; - my $suffix = ''; - if (@suffices) { - foreach $suffix (@suffices) { - my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; - if ($basename =~ s/$pat//s) { - $taint .= substr($suffix,0,0); - $tail = $1 . $tail; - } - } - } - - # Ensure taint is propgated from the path to its pieces. - $tail .= $taint; - wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) - : ($basename .= $taint); -} - - - -=item C<basename> - - my $filename = basename($path); - my $filename = basename($path, @suffixes); - -This function is provided for compatibility with the Unix shell command -C<basename(1)>. It does B<NOT> always return the file name portion of a -path as you might expect. To be safe, if you want the file name portion of -a path use C<fileparse()>. - -C<basename()> returns the last level of a filepath even if the last -level is clearly directory. In effect, it is acting like C<pop()> for -paths. This differs from C<fileparse()>'s behaviour. - - # Both return "bar" - basename("/foo/bar"); - basename("/foo/bar/"); - -@suffixes work as in C<fileparse()> except all regex metacharacters are -quoted. - - # These two function calls are equivalent. - my $filename = basename("/foo/bar/baz.txt", ".txt"); - my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/); - -Also note that in order to be compatible with the shell command, -C<basename()> does not strip off a suffix if it is identical to the -remaining characters in the filename. - -=cut - - -sub basename { - my($path) = shift; - - # From BSD basename(1) - # The basename utility deletes any prefix ending with the last slash `/' - # character present in string (after first stripping trailing slashes) - _strip_trailing_sep($path); - - my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) ); - - # From BSD basename(1) - # The suffix is not stripped if it is identical to the remaining - # characters in string. - if( length $suffix and !length $basename ) { - $basename = $suffix; - } - - # Ensure that basename '/' == '/' - if( !length $basename ) { - $basename = $dirname; - } - - return $basename; -} - - - -=item C<dirname> - -This function is provided for compatibility with the Unix shell -command C<dirname(1)> and has inherited some of its quirks. In spite of -its name it does B<NOT> always return the directory name as you might -expect. To be safe, if you want the directory name of a path use -C<fileparse()>. - -Only on VMS (where there is no ambiguity between the file and directory -portions of a path) and AmigaOS (possibly due to an implementation quirk in -this module) does C<dirname()> work like C<fileparse($path)>, returning just the -$directories. - - # On VMS and AmigaOS - my $directories = dirname($path); - -When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function -which is subtly different from how C<fileparse()> works. It returns all but -the last level of a file path even if the last level is clearly a directory. -In effect, it is not returning the directory portion but simply the path one -level up acting like C<chop()> for file paths. - -Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on -its returned path. - - # returns /foo/bar. fileparse() would return /foo/bar/ - dirname("/foo/bar/baz"); - - # also returns /foo/bar despite the fact that baz is clearly a - # directory. fileparse() would return /foo/bar/baz/ - dirname("/foo/bar/baz/"); - - # returns '.'. fileparse() would return 'foo/' - dirname("foo/"); - -Under VMS, if there is no directory information in the $path, then the -current default device and directory is used. - -=cut - - -sub dirname { - my $path = shift; - - my($type) = $Fileparse_fstype; - - if( $type eq 'VMS' and $path =~ m{/} ) { - # Parse as Unix - local($File::Basename::Fileparse_fstype) = ''; - return dirname($path); - } - - my($basename, $dirname) = fileparse($path); - - if ($type eq 'VMS') { - $dirname ||= $ENV{DEFAULT}; - } - elsif ($type eq 'MacOS') { - if( !length($basename) && $dirname !~ /^[^:]+:\z/) { - _strip_trailing_sep($dirname); - ($basename,$dirname) = fileparse $dirname; - } - $dirname .= ":" unless $dirname =~ /:\z/; - } - elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { - _strip_trailing_sep($dirname); - unless( length($basename) ) { - ($basename,$dirname) = fileparse $dirname; - _strip_trailing_sep($dirname); - } - } - elsif ($type eq 'AmigaOS') { - if ( $dirname =~ /:\z/) { return $dirname } - chop $dirname; - $dirname =~ s#[^:/]+\z## unless length($basename); - } - else { - _strip_trailing_sep($dirname); - unless( length($basename) ) { - ($basename,$dirname) = fileparse $dirname; - _strip_trailing_sep($dirname); - } - } - - $dirname; -} - - -# Strip the trailing path separator. -sub _strip_trailing_sep { - my $type = $Fileparse_fstype; - - if ($type eq 'MacOS') { - $_[0] =~ s/([^:]):\z/$1/s; - } - elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { - $_[0] =~ s/([^:])[\\\/]*\z/$1/; - } - else { - $_[0] =~ s{(.)/*\z}{$1}s; - } -} - - -=item C<fileparse_set_fstype> - - my $type = fileparse_set_fstype(); - my $previous_type = fileparse_set_fstype($type); - -Normally File::Basename will assume a file path type native to your current -operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...). -With this function you can override that assumption. - -Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS", -"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility), -"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is -given "Unix" will be assumed. - -If you've selected VMS syntax, and the file specification you pass to -one of these routines contains a "/", they assume you are using Unix -emulation and apply the Unix syntax rules instead, for that function -call only. - -=back - -=cut - - -BEGIN { - -my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc); -my @Types = (@Ignore_Case, qw(Unix)); - -sub fileparse_set_fstype { - my $old = $Fileparse_fstype; - - if (@_) { - my $new_type = shift; - - $Fileparse_fstype = 'Unix'; # default - foreach my $type (@Types) { - $Fileparse_fstype = $type if $new_type =~ /^$type/i; - } - - $Fileparse_igncase = - (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0; - } - - return $old; -} - -} - - -1; - - -=head1 SEE ALSO - -L<dirname(1)>, L<basename(1)>, L<File::Spec> diff --git a/Master/tlpkg/installer/perllib/File/CheckTree.pm b/Master/tlpkg/installer/perllib/File/CheckTree.pm deleted file mode 100644 index 20ffd68124d..00000000000 --- a/Master/tlpkg/installer/perllib/File/CheckTree.pm +++ /dev/null @@ -1,229 +0,0 @@ -package File::CheckTree; - -use 5.006; -use Cwd; -use Exporter; -use File::Spec; -use warnings; -use strict; - -our $VERSION = '4.3'; -our @ISA = qw(Exporter); -our @EXPORT = qw(validate); - -=head1 NAME - -validate - run many filetest checks on a tree - -=head1 SYNOPSIS - - use File::CheckTree; - - $num_warnings = validate( q{ - /vmunix -e || die - /boot -e || die - /bin cd - csh -ex - csh !-ug - sh -ex - sh !-ug - /usr -d || warn "What happened to $file?\n" - }); - -=head1 DESCRIPTION - -The validate() routine takes a single multiline string consisting of -directives, each containing a filename plus a file test to try on it. -(The file test may also be a "cd", causing subsequent relative filenames -to be interpreted relative to that directory.) After the file test -you may put C<|| die> to make it a fatal error if the file test fails. -The default is C<|| warn>. The file test may optionally have a "!' prepended -to test for the opposite condition. If you do a cd and then list some -relative filenames, you may want to indent them slightly for readability. -If you supply your own die() or warn() message, you can use $file to -interpolate the filename. - -Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. -Only the first failed test of the bunch will produce a warning. - -The routine returns the number of warnings issued. - -=head1 AUTHOR - -File::CheckTree was derived from lib/validate.pl which was -written by Larry Wall. -Revised by Paul Grassie <F<grassie@perl.com>> in 2002. - -=head1 HISTORY - -File::CheckTree used to not display fatal error messages. -It used to count only those warnings produced by a generic C<|| warn> -(and not those in which the user supplied the message). In addition, -the validate() routine would leave the user program in whatever -directory was last entered through the use of "cd" directives. -These bugs were fixed during the development of perl 5.8. -The first fixed version of File::CheckTree was 4.2. - -=cut - -my $Warnings; - -sub validate { - my ($starting_dir, $file, $test, $cwd, $oldwarnings); - - $starting_dir = cwd; - - $cwd = ""; - $Warnings = 0; - - foreach my $check (split /\n/, $_[0]) { - my ($testlist, @testlist); - - # skip blanks/comments - next if $check =~ /^\s*#/ || $check =~ /^\s*$/; - - # Todo: - # should probably check for invalid directives and die - # but earlier versions of File::CheckTree did not do this either - - # split a line like "/foo -r || die" - # so that $file is "/foo", $test is "-rwx || die" - ($file, $test) = split(' ', $check, 2); # special whitespace split - - # change a $test like "!-ug || die" to "!-Z || die", - # capturing the bundled tests (e.g. "ug") in $2 - if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) { - $testlist = $2; - # split bundled tests, e.g. "ug" to 'u', 'g' - @testlist = split(//, $testlist); - } - else { - # put in placeholder Z for stand-alone test - @testlist = ('Z'); - } - - # will compare these two later to stop on 1st warning w/in a bundle - $oldwarnings = $Warnings; - - foreach my $one (@testlist) { - # examples of $test: "!-Z || die" or "-w || warn" - my $this = $test; - - # expand relative $file to full pathname if preceded by cd directive - $file = File::Spec->catfile($cwd, $file) - if $cwd && !File::Spec->file_name_is_absolute($file); - - # put filename in after the test operator - $this =~ s/(-\w\b)/$1 "\$file"/g; - - # change the "-Z" representing a bundle with the $one test - $this =~ s/-Z/-$one/; - - # if it's a "cd" directive... - if ($this =~ /^cd\b/) { - # add "|| die ..." - $this .= ' || die "cannot cd to $file\n"'; - # expand "cd" directive with directory name - $this =~ s/\bcd\b/chdir(\$cwd = '$file')/; - } - else { - # add "|| warn" as a default disposition - $this .= ' || warn' unless $this =~ /\|\|/; - - # change a generic ".. || die" or ".. || warn" - # to call valmess instead of die/warn directly - # valmess will look up the error message from %Val_Message - $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $ - /$1 || valmess('$3', '$2', \$file)/x; - } - - { - # count warnings, either from valmess or '-r || warn "my msg"' - # also, call any pre-existing signal handler for __WARN__ - my $orig_sigwarn = $SIG{__WARN__}; - local $SIG{__WARN__} = sub { - ++$Warnings; - if ( $orig_sigwarn ) { - $orig_sigwarn->(@_); - } - else { - warn "@_"; - } - }; - - # do the test - eval $this; - - # re-raise an exception caused by a "... || die" test - if ($@) { - # in case of any cd directives, return from whence we came - if ($starting_dir ne cwd) { - chdir($starting_dir) || die "$starting_dir: $!"; - } - die $@ if $@; - } - } - - # stop on 1st warning within a bundle of tests - last if $Warnings > $oldwarnings; - } - } - - # in case of any cd directives, return from whence we came - if ($starting_dir ne cwd) { - chdir($starting_dir) || die "chdir $starting_dir: $!"; - } - - return $Warnings; -} - -my %Val_Message = ( - 'r' => "is not readable by uid $>.", - 'w' => "is not writable by uid $>.", - 'x' => "is not executable by uid $>.", - 'o' => "is not owned by uid $>.", - 'R' => "is not readable by you.", - 'W' => "is not writable by you.", - 'X' => "is not executable by you.", - 'O' => "is not owned by you.", - 'e' => "does not exist.", - 'z' => "does not have zero size.", - 's' => "does not have non-zero size.", - 'f' => "is not a plain file.", - 'd' => "is not a directory.", - 'l' => "is not a symbolic link.", - 'p' => "is not a named pipe (FIFO).", - 'S' => "is not a socket.", - 'b' => "is not a block special file.", - 'c' => "is not a character special file.", - 'u' => "does not have the setuid bit set.", - 'g' => "does not have the setgid bit set.", - 'k' => "does not have the sticky bit set.", - 'T' => "is not a text file.", - 'B' => "is not a binary file." -); - -sub valmess { - my ($disposition, $test, $file) = @_; - my $ferror; - - if ($test =~ / ^ (!?) -(\w) \s* $ /x) { - my ($neg, $ftype) = ($1, $2); - - $ferror = "$file $Val_Message{$ftype}"; - - if ($neg eq '!') { - $ferror =~ s/ is not / should not be / || - $ferror =~ s/ does not / should not / || - $ferror =~ s/ not / /; - } - } - else { - $ferror = "Can't do $test $file.\n"; - } - - die "$ferror\n" if $disposition eq 'die'; - warn "$ferror\n"; -} - -1; diff --git a/Master/tlpkg/installer/perllib/File/Compare.pm b/Master/tlpkg/installer/perllib/File/Compare.pm deleted file mode 100644 index 0b73d7c7657..00000000000 --- a/Master/tlpkg/installer/perllib/File/Compare.pm +++ /dev/null @@ -1,178 +0,0 @@ -package File::Compare; - -use 5.006; -use strict; -use warnings; -our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); - -require Exporter; -use Carp; - -$VERSION = '1.1003'; -@ISA = qw(Exporter); -@EXPORT = qw(compare); -@EXPORT_OK = qw(cmp compare_text); - -$Too_Big = 1024 * 1024 * 2; - -sub compare { - croak("Usage: compare( file1, file2 [, buffersize]) ") - unless(@_ == 2 || @_ == 3); - - my ($from,$to,$size) = @_; - my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); - - my ($fromsize,$closefrom,$closeto); - local (*FROM, *TO); - - croak("from undefined") unless (defined $from); - croak("to undefined") unless (defined $to); - - if (ref($from) && - (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { - *FROM = *$from; - } elsif (ref(\$from) eq 'GLOB') { - *FROM = $from; - } else { - open(FROM,"<$from") or goto fail_open1; - unless ($text_mode) { - binmode FROM; - $fromsize = -s FROM; - } - $closefrom = 1; - } - - if (ref($to) && - (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { - *TO = *$to; - } elsif (ref(\$to) eq 'GLOB') { - *TO = $to; - } else { - open(TO,"<$to") or goto fail_open2; - binmode TO unless $text_mode; - $closeto = 1; - } - - if (!$text_mode && $closefrom && $closeto) { - # If both are opened files we know they differ if their size differ - goto fail_inner if $fromsize != -s TO; - } - - if ($text_mode) { - local $/ = "\n"; - my ($fline,$tline); - while (defined($fline = <FROM>)) { - goto fail_inner unless defined($tline = <TO>); - if (ref $size) { - # $size contains ref to comparison function - goto fail_inner if &$size($fline, $tline); - } else { - goto fail_inner if $fline ne $tline; - } - } - goto fail_inner if defined($tline = <TO>); - } - else { - unless (defined($size) && $size > 0) { - $size = $fromsize || -s TO || 0; - $size = 1024 if $size < 512; - $size = $Too_Big if $size > $Too_Big; - } - - my ($fr,$tr,$fbuf,$tbuf); - $fbuf = $tbuf = ''; - while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { - unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) { - goto fail_inner; - } - } - goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0; - } - - close(TO) || goto fail_open2 if $closeto; - close(FROM) || goto fail_open1 if $closefrom; - - return 0; - - # All of these contortions try to preserve error messages... - fail_inner: - close(TO) || goto fail_open2 if $closeto; - close(FROM) || goto fail_open1 if $closefrom; - - return 1; - - fail_open2: - if ($closefrom) { - my $status = $!; - $! = 0; - close FROM; - $! = $status unless $!; - } - fail_open1: - return -1; -} - -sub cmp; -*cmp = \&compare; - -sub compare_text { - my ($from,$to,$cmp) = @_; - croak("Usage: compare_text( file1, file2 [, cmp-function])") - unless @_ == 2 || @_ == 3; - croak("Third arg to compare_text() function must be a code reference") - if @_ == 3 && ref($cmp) ne 'CODE'; - - # Using a negative buffer size puts compare into text_mode too - $cmp = -1 unless defined $cmp; - compare($from, $to, $cmp); -} - -1; - -__END__ - -=head1 NAME - -File::Compare - Compare files or filehandles - -=head1 SYNOPSIS - - use File::Compare; - - if (compare("file1","file2") == 0) { - print "They're equal\n"; - } - -=head1 DESCRIPTION - -The File::Compare::compare function compares the contents of two -sources, each of which can be a file or a file handle. It is exported -from File::Compare by default. - -File::Compare::cmp is a synonym for File::Compare::compare. It is -exported from File::Compare only by request. - -File::Compare::compare_text does a line by line comparison of the two -files. It stops as soon as a difference is detected. compare_text() -accepts an optional third argument: This must be a CODE reference to -a line comparison function, which returns 0 when both lines are considered -equal. For example: - - compare_text($file1, $file2) - -is basically equivalent to - - compare_text($file1, $file2, sub {$_[0] ne $_[1]} ) - -=head1 RETURN - -File::Compare::compare and its sibling functions return 0 if the files -are equal, 1 if the files are unequal, or -1 if an error was encountered. - -=head1 AUTHOR - -File::Compare was written by Nick Ing-Simmons. -Its original documentation was written by Chip Salzenberg. - -=cut - diff --git a/Master/tlpkg/installer/perllib/File/Copy.pm b/Master/tlpkg/installer/perllib/File/Copy.pm deleted file mode 100644 index 52ba7c6d81a..00000000000 --- a/Master/tlpkg/installer/perllib/File/Copy.pm +++ /dev/null @@ -1,459 +0,0 @@ -# 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 Carp; -use File::Spec; -use Config; -our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); -sub copy; -sub syscopy; -sub cp; -sub mv; - -# Note that this module implements only *part* of the API defined by -# the File/Copy.pm module of the File-Tools-2.0 package. However, that -# package has not yet been updated to work with Perl 5.004, and so it -# would be a Bad Thing for the CPAN module to grab it and replace this -# module. Therefore, we set this module's version higher than 2.0. -$VERSION = '2.09'; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(copy move); -@EXPORT_OK = qw(cp mv); - -$Too_Big = 1024 * 1024 * 2; - -my $macfiles; -if ($^O eq 'MacOS') { - $macfiles = eval { require Mac::MoreFiles }; - warn 'Mac::MoreFiles could not be loaded; using non-native syscopy' - if $@ && $^W; -} - -sub _catname { - my($from, $to) = @_; - if (not defined &basename) { - require File::Basename; - import File::Basename 'basename'; - } - - if ($^O eq 'MacOS') { - # a partial dir name that's valid only in the cwd (e.g. 'tmp') - $to = ':' . $to if $to !~ /:/; - } - - return File::Spec->catfile($to, basename($from)); -} - -sub copy { - croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") - unless(@_ == 2 || @_ == 3); - - my $from = shift; - my $to = shift; - - my $from_a_handle = (ref($from) - ? (ref($from) eq 'GLOB' - || UNIVERSAL::isa($from, 'GLOB') - || UNIVERSAL::isa($from, 'IO::Handle')) - : (ref(\$from) eq 'GLOB')); - my $to_a_handle = (ref($to) - ? (ref($to) eq 'GLOB' - || UNIVERSAL::isa($to, 'GLOB') - || UNIVERSAL::isa($to, 'IO::Handle')) - : (ref(\$to) eq 'GLOB')); - - if ($from eq $to) { # works for references, too - carp("'$from' and '$to' are identical (not copied)"); - # The "copy" was a success as the source and destination contain - # the same data. - return 1; - } - - if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && - !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) { - my @fs = stat($from); - if (@fs) { - my @ts = stat($to); - if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { - carp("'$from' and '$to' are identical (not copied)"); - return 0; - } - } - } - - if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { - $to = _catname($from, $to); - } - - if (defined &syscopy && !$Syscopy_is_copy - && !$to_a_handle - && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles - && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. - && !($from_a_handle && $^O eq 'MSWin32') - && !($from_a_handle && $^O eq 'MacOS') - && !($from_a_handle && $^O eq 'NetWare') - ) - { - return syscopy($from, $to); - } - - my $closefrom = 0; - my $closeto = 0; - my ($size, $status, $r, $buf); - local($\) = ''; - - my $from_h; - if ($from_a_handle) { - $from_h = $from; - } else { - $from = _protect($from) if $from =~ /^\s/s; - $from_h = \do { local *FH }; - open($from_h, "< $from\0") or goto fail_open1; - binmode $from_h or die "($!,$^E)"; - $closefrom = 1; - } - - my $to_h; - if ($to_a_handle) { - $to_h = $to; - } else { - $to = _protect($to) if $to =~ /^\s/s; - $to_h = \do { local *FH }; - open($to_h,"> $to\0") or goto fail_open2; - binmode $to_h or die "($!,$^E)"; - $closeto = 1; - } - - if (@_) { - $size = shift(@_) + 0; - croak("Bad buffer size for copy: $size\n") unless ($size > 0); - } else { - $size = tied(*$from_h) ? 0 : -s $from_h || 0; - $size = 1024 if ($size < 512); - $size = $Too_Big if ($size > $Too_Big); - } - - $! = 0; - for (;;) { - my ($r, $w, $t); - defined($r = sysread($from_h, $buf, $size)) - or goto fail_inner; - last unless $r; - for ($w = 0; $w < $r; $w += $t) { - $t = syswrite($to_h, $buf, $r - $w, $w) - or goto fail_inner; - } - } - - close($to_h) || goto fail_open2 if $closeto; - close($from_h) || goto fail_open1 if $closefrom; - - # Use this idiom to avoid uninitialized value warning. - return 1; - - # All of these contortions try to preserve error messages... - fail_inner: - if ($closeto) { - $status = $!; - $! = 0; - close $to_h; - $! = $status unless $!; - } - fail_open2: - if ($closefrom) { - $status = $!; - $! = 0; - close $from_h; - $! = $status unless $!; - } - fail_open1: - return 0; -} - -sub move { - croak("Usage: move(FROM, TO) ") unless @_ == 2; - - my($from,$to) = @_; - - my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); - - if (-d $to && ! -d $from) { - $to = _catname($from, $to); - } - - ($tosz1,$tomt1) = (stat($to))[7,9]; - $fromsz = -s $from; - if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { - # will not rename with overwrite - unlink $to; - } - return 1 if rename $from, $to; - - # Did rename return an error even though it succeeded, because $to - # is on a remote NFS file system, and NFS lost the server's ack? - return 1 if defined($fromsz) && !-e $from && # $from disappeared - (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there - ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed - $tosz2 == $fromsz; # it's all there - - ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something - - { - local $@; - eval { - local $SIG{__DIE__}; - copy($from,$to) or die; - my($atime, $mtime) = (stat($from))[8,9]; - utime($atime, $mtime, $to); - unlink($from) or die; - }; - return 1 unless $@; - } - ($sts,$ossts) = ($! + 0, $^E + 0); - - ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; - unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; - ($!,$^E) = ($sts,$ossts); - return 0; -} - -*cp = \© -*mv = \&move; - - -if ($^O eq 'MacOS') { - *_protect = sub { MacPerl::MakeFSSpec($_[0]) }; -} else { - *_protect = sub { "./$_[0]" }; -} - -# &syscopy is an XSUB under OS/2 -unless (defined &syscopy) { - if ($^O eq 'VMS') { - *syscopy = \&rmscopy; - } elsif ($^O eq 'mpeix') { - *syscopy = sub { - return 0 unless @_ == 2; - # Use the MPE cp program in order to - # preserve MPE file attributes. - return system('/bin/cp', '-f', $_[0], $_[1]) == 0; - }; - } elsif ($^O eq 'MSWin32') { - *syscopy = sub { - return 0 unless @_ == 2; - return Win32::CopyFile(@_, 1); - }; - } elsif ($macfiles) { - *syscopy = sub { - my($from, $to) = @_; - my($dir, $toname); - - return 0 unless -e $from; - - if ($to =~ /(.*:)([^:]+):?$/) { - ($dir, $toname) = ($1, $2); - } else { - ($dir, $toname) = (":", $to); - } - - unlink($to); - Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1); - }; - } else { - $Syscopy_is_copy = 1; - *syscopy = \© - } -} - -1; - -__END__ - -=head1 NAME - -File::Copy - Copy files or filehandles - -=head1 SYNOPSIS - - use File::Copy; - - copy("file1","file2") or die "Copy failed: $!"; - copy("Copy.pm",\*STDOUT); - move("/dev1/fileA","/dev2/fileB"); - - use File::Copy "cp"; - - $n = FileHandle->new("/a/file","r"); - cp($n,"x"); - -=head1 DESCRIPTION - -The File::Copy module provides two basic functions, C<copy> and -C<move>, which are useful for getting the contents of a file from -one place to another. - -=over 4 - -=item * - -The C<copy> function takes two -parameters: a file to copy from and a file to copy to. Either -argument may be a string, a FileHandle reference or a FileHandle -glob. Obviously, if the first argument is a filehandle of some -sort, it will be read from, and if it is a file I<name> it will -be opened for reading. Likewise, the second argument will be -written to (and created if need be). Trying to copy a file on top -of itself is a fatal error. - -B<Note that passing in -files as handles instead of names may lead to loss of information -on some operating systems; it is recommended that you use file -names whenever possible.> Files are opened in binary mode where -applicable. To get a consistent behaviour when copying from a -filehandle to a file, use C<binmode> on the filehandle. - -An optional third parameter can be used to specify the buffer -size used for copying. This is the number of bytes from the -first file, that wil be held in memory at any given time, before -being written to the second file. The default buffer size depends -upon the file, but will generally be the whole file (up to 2Mb), or -1k for filehandles that do not reference files (eg. sockets). - -You may use the syntax C<use File::Copy "cp"> to get at the -"cp" alias for this function. The syntax is I<exactly> the same. - -=item * - -The C<move> function also takes two parameters: the current name -and the intended name of the file to be moved. If the destination -already exists and is a directory, and the source is not a -directory, then the source file will be renamed into the directory -specified by the destination. - -If possible, move() will simply rename the file. Otherwise, it copies -the file to the new location and deletes the original. If an error occurs -during this copy-and-delete process, you may be left with a (possibly partial) -copy of the file under the destination name. - -You may use the "mv" alias for this function in the same way that -you may use the "cp" alias for C<copy>. - -=back - -File::Copy also provides the C<syscopy> routine, which copies the -file specified in the first parameter to the file specified in the -second parameter, preserving OS-specific attributes and file -structure. For Unix systems, this is equivalent to the simple -C<copy> routine, which doesn't preserve OS-specific attributes. For -VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 -systems, this calls the C<syscopy> XSUB directly. For Win32 systems, -this calls C<Win32::CopyFile>. - -On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>, -if available. - -=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) - -If both arguments to C<copy> are not file handles, -then C<copy> will perform a "system copy" of -the input file to a new output file, in order to preserve file -attributes, indexed file structure, I<etc.> The buffer size -parameter is ignored. If either argument to C<copy> is a -handle to an opened file, then data is copied using Perl -operators, and no effort is made to preserve file attributes -or record structure. - -The system copy routine may also be called directly under VMS and OS/2 -as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which -is the routine that does the actual work for syscopy). - -=over 4 - -=item rmscopy($from,$to[,$date_flag]) - -The first and second arguments may be strings, typeglobs, typeglob -references, or objects inheriting from IO::Handle; -they are used in all cases to obtain the -I<filespec> of the input and output files, respectively. The -name and type of the input file are used as defaults for the -output file, if necessary. - -A new version of the output file is always created, which -inherits the structure and RMS attributes of the input file, -except for owner and protections (and possibly timestamps; -see below). All data from the input file is copied to the -output file; if either of the first two parameters to C<rmscopy> -is a file handle, its position is unchanged. (Note that this -means a file handle pointing to the output file will be -associated with an old version of that file after C<rmscopy> -returns, not the newly created version.) - -The third parameter is an integer flag, which tells C<rmscopy> -how to handle timestamps. If it is E<lt> 0, none of the input file's -timestamps are propagated to the output file. If it is E<gt> 0, then -it is interpreted as a bitmask: if bit 0 (the LSB) is set, then -timestamps other than the revision date are propagated; if bit 1 -is set, the revision date is propagated. If the third parameter -to C<rmscopy> is 0, then it behaves much like the DCL COPY command: -if the name or type of the output file was explicitly specified, -then no timestamps are propagated, but if they were taken implicitly -from the input filespec, then all timestamps other than the -revision date are propagated. If this parameter is not supplied, -it defaults to 0. - -Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, -it sets C<$!>, deletes the output file, and returns 0. - -=back - -=head1 RETURN - -All functions return 1 on success, 0 on failure. -$! will be set if an error was encountered. - -=head1 NOTES - -=over 4 - -=item * - -On Mac OS (Classic), the path separator is ':', not '/', and the -current directory is denoted as ':', not '.'. You should be careful -about specifying relative pathnames. While a full path always begins -with a volume name, a relative pathname should always begin with a -':'. If specifying a volume name only, a trailing ':' is required. - -E.g. - - copy("file1", "tmp"); # creates the file 'tmp' in the current directory - copy("file1", ":tmp:"); # creates :tmp:file1 - copy("file1", ":tmp"); # same as above - copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do - # that, since it may cause confusion, see example #1) - copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume - copy("file1", ":tmp:file1"); # ok, partial path - copy("file1", "DataHD:"); # creates DataHD:file1 - - move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one - # volume to another - -=back - -=head1 AUTHOR - -File::Copy was written by Aaron Sherman I<E<lt>ajs@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/installer/perllib/File/DosGlob.pm b/Master/tlpkg/installer/perllib/File/DosGlob.pm deleted file mode 100644 index a1c27d5c32a..00000000000 --- a/Master/tlpkg/installer/perllib/File/DosGlob.pm +++ /dev/null @@ -1,571 +0,0 @@ -#!perl -w - -# use strict fails -#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. - -# -# Documentation at the __END__ -# - -package File::DosGlob; - -our $VERSION = '1.00'; -use strict; -use warnings; - -sub doglob { - my $cond = shift; - my @retval = (); - #print "doglob: ", join('|', @_), "\n"; - OUTER: - for my $pat (@_) { - my @matched = (); - my @globdirs = (); - my $head = '.'; - my $sepchr = '/'; - my $tail; - next OUTER unless defined $pat and $pat ne ''; - # if arg is within quotes strip em and do no globbing - if ($pat =~ /^"(.*)"\z/s) { - $pat = $1; - if ($cond eq 'd') { push(@retval, $pat) if -d $pat } - else { push(@retval, $pat) if -e $pat } - next OUTER; - } - # wildcards with a drive prefix such as h:*.pm must be changed - # to h:./*.pm to expand correctly - if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { - substr($_,0,2) = $1 . "./"; - } - if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { - ($head, $sepchr, $tail) = ($1,$2,$3); - #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $pat), next OUTER if $tail eq ''; - if ($head =~ /[*?]/) { - @globdirs = doglob('d', $head); - push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), - next OUTER if @globdirs; - } - $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; - $pat = $tail; - } - # - # If file component has no wildcards, we can avoid opendir - unless ($pat =~ /[*?]/) { - $head = '' if $head eq '.'; - $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; - $head .= $pat; - if ($cond eq 'd') { push(@retval,$head) if -d $head } - else { push(@retval,$head) if -e $head } - next OUTER; - } - opendir(D, $head) or next OUTER; - my @leaves = readdir D; - closedir D; - $head = '' if $head eq '.'; - $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; - - # escape regex metachars but not glob chars - $pat =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex - $pat =~ s/\*/.*/g; - $pat =~ s/\?/.?/g; - - #print "regex: '$pat', head: '$head'\n"; - my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; - INNER: - for my $e (@leaves) { - next INNER if $e eq '.' or $e eq '..'; - next INNER if $cond eq 'd' and ! -d "$head$e"; - push(@matched, "$head$e"), next INNER if &$matchsub($e); - # - # [DOS compatibility special case] - # Failed, add a trailing dot and try again, but only - # if name does not have a dot in it *and* pattern - # has a dot *and* name is shorter than 9 chars. - # - if (index($e,'.') == -1 and length($e) < 9 - and index($pat,'\\.') != -1) { - push(@matched, "$head$e"), next INNER if &$matchsub("$e."); - } - } - push @retval, @matched if @matched; - } - return @retval; -} - - -# -# Do DOS-like globbing on Mac OS -# -sub doglob_Mac { - my $cond = shift; - my @retval = (); - - #print "doglob_Mac: ", join('|', @_), "\n"; - OUTER: - for my $arg (@_) { - local $_ = $arg; - my @matched = (); - my @globdirs = (); - my $head = ':'; - my $not_esc_head = $head; - my $sepchr = ':'; - next OUTER unless defined $_ and $_ ne ''; - # if arg is within quotes strip em and do no globbing - if (/^"(.*)"\z/s) { - $_ = $1; - # $_ may contain escaped metachars '\*', '\?' and '\' - my $not_esc_arg = $_; - $not_esc_arg =~ s/\\([*?\\])/$1/g; - if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } - else { push(@retval, $not_esc_arg) if -e $not_esc_arg } - next OUTER; - } - - if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy - my $tail; - ($head, $sepchr, $tail) = ($1,$2,$3); - #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $_), next OUTER if $tail eq ''; - # - # $head may contain escaped metachars '\*' and '\?' - - my $tmp_head = $head; - # if a '*' or '?' is preceded by an odd count of '\', temporary delete - # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as - # wildcards - $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; - - if ($tmp_head =~ /[*?]/) { # if there are wildcards ... - @globdirs = doglob_Mac('d', $head); - push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), - next OUTER if @globdirs; - } - - $head .= $sepchr; - $not_esc_head = $head; - # unescape $head for file operations - $not_esc_head =~ s/\\([*?\\])/$1/g; - $_ = $tail; - } - # - # If file component has no wildcards, we can avoid opendir - - my $tmp_tail = $_; - # if a '*' or '?' is preceded by an odd count of '\', temporary delete - # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as - # wildcards - $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; - - unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... - $not_esc_head = $head = '' if $head eq ':'; - my $not_esc_tail = $_; - # unescape $head and $tail for file operations - $not_esc_tail =~ s/\\([*?\\])/$1/g; - $head .= $_; - $not_esc_head .= $not_esc_tail; - if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } - else { push(@retval,$head) if -e $not_esc_head } - next OUTER; - } - #print "opendir($not_esc_head)\n"; - opendir(D, $not_esc_head) or next OUTER; - my @leaves = readdir D; - closedir D; - - # escape regex metachars but not '\' and glob chars '*', '?' - $_ =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex, - # but only if they are not escaped - $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; - - #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; - warn($@), next OUTER if $@; - INNER: - for my $e (@leaves) { - next INNER if $e eq '.' or $e eq '..'; - next INNER if $cond eq 'd' and ! -d "$not_esc_head$e"; - - if (&$matchsub($e)) { - my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? - "$e" : "$not_esc_head$e"; - # - # On Mac OS, the two glob metachars '*' and '?' and the escape - # char '\' are valid characters for file and directory names. - # We have to escape and treat them specially. - $leave =~ s|([*?\\])|\\$1|g; - push(@matched, $leave); - next INNER; - } - } - push @retval, @matched if @matched; - } - return @retval; -} - -# -# _expand_volume() will only be used on Mac OS (Classic): -# Takes an array of original patterns as argument and returns an array of -# possibly modified patterns. Each original pattern is processed like -# that: -# + If there's a volume name in the pattern, we push a separate pattern -# for each mounted volume that matches (with '*', '?' and '\' escaped). -# + If there's no volume name in the original pattern, it is pushed -# unchanged. -# Note that the returned array of patterns may be empty. -# -sub _expand_volume { - - require MacPerl; # to be verbose - - my @pat = @_; - my @new_pat = (); - my @FSSpec_Vols = MacPerl::Volumes(); - my @mounted_volumes = (); - - foreach my $spec_vol (@FSSpec_Vols) { - # push all mounted volumes into array - push @mounted_volumes, MacPerl::MakePath($spec_vol); - } - #print "mounted volumes: |@mounted_volumes|\n"; - - while (@pat) { - my $pat = shift @pat; - if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? - my $vol_pat = $1; - my $tail = $2; - # - # escape regex metachars but not '\' and glob chars '*', '?' - $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex, - # but only if they are not escaped - $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; - #print "volume regex: '$vol_pat' \n"; - - foreach my $volume (@mounted_volumes) { - if ($volume =~ m|^$vol_pat\z|ios) { - # - # On Mac OS, the two glob metachars '*' and '?' and the - # escape char '\' are valid characters for volume names. - # We have to escape and treat them specially. - $volume =~ s|([*?\\])|\\$1|g; - push @new_pat, $volume . $tail; - } - } - } else { # no volume name in pattern, push original pattern - push @new_pat, $pat; - } - } - return @new_pat; -} - - -# -# _preprocess_pattern() will only be used on Mac OS (Classic): -# Resolves any updirs in the pattern. Removes a single trailing colon -# from the pattern, unless it's a volume name pattern like "*HD:" -# -sub _preprocess_pattern { - my @pat = @_; - - foreach my $p (@pat) { - my $proceed; - # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" - do { - $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); - } while ($proceed); - # remove a single trailing colon, e.g. ":*:" -> ":*" - $p =~ s/:([^:]+):\z/:$1/; - } - return @pat; -} - - -# -# _un_escape() will only be used on Mac OS (Classic): -# Unescapes a list of arguments which may contain escaped -# metachars '*', '?' and '\'. -# -sub _un_escape { - foreach (@_) { - s/\\([*?\\])/$1/g; - } - return @_; -} - -# -# this can be used to override CORE::glob in a specific -# package by saying C<use File::DosGlob 'glob';> in that -# namespace. -# - -# context (keyed by second cxix arg provided by core) -my %iter; -my %entries; - -sub glob { - my($pat,$cxix) = @_; - my @pat; - - # glob without args defaults to $_ - $pat = $_ unless defined $pat; - - # extract patterns - if ($pat =~ /\s/) { - require Text::ParseWords; - @pat = Text::ParseWords::parse_line('\s+',0,$pat); - } - else { - push @pat, $pat; - } - - # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3. - # abc3 will be the original {3} (and drop the {}). - # abc1 abc2 will be put in @appendpat. - # This was just the esiest way, not nearly the best. - REHASH: { - my @appendpat = (); - for (@pat) { - # There must be a "," I.E. abc{efg} is not what we want. - while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) { - my ($start, $match, $end) = ($1, $2, $3); - #print "Got: \n\t$start\n\t$match\n\t$end\n"; - my $tmp = "$start$match$end"; - while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) { - #print "Striped: $tmp\n"; - # these expanshions will be preformed by the original, - # when we call REHASH. - } - push @appendpat, ("$tmp"); - s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/; - if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) { - $match = $1; - #print "GOT: \n\t$start\n\t$match\n\t$end\n\n"; - $_ = "$start$match$end"; - } - } - #print "Sould have "GOT" vs "Got"!\n"; - #FIXME: There should be checking for this. - # How or what should be done about failure is beond me. - } - if ( $#appendpat != -1 - ) { - #print "LOOP\n"; - #FIXME: Max loop, no way! :") - for ( @appendpat ) { - push @pat, $_; - } - goto REHASH; - } - } - for ( @pat ) { - s/\\{/{/g; - s/\\}/}/g; - s/\\,/,/g; - } - #print join ("\n", @pat). "\n"; - - # assume global context if not provided one - $cxix = '_G_' unless defined $cxix; - $iter{$cxix} = 0 unless exists $iter{$cxix}; - - # if we're just beginning, do it all first - if ($iter{$cxix} == 0) { - if ($^O eq 'MacOS') { - # first, take care of updirs and trailing colons - @pat = _preprocess_pattern(@pat); - # expand volume names - @pat = _expand_volume(@pat); - $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@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/installer/perllib/File/Find.pm b/Master/tlpkg/installer/perllib/File/Find.pm deleted file mode 100644 index 497051e0635..00000000000 --- a/Master/tlpkg/installer/perllib/File/Find.pm +++ /dev/null @@ -1,1275 +0,0 @@ -package File::Find; -use 5.006; -use strict; -use warnings; -use warnings::register; -our $VERSION = '1.10'; -require Exporter; -require Cwd; - -# -# Modified to ensure sub-directory traversal order is not inverded by stack -# push and pops. That is remains in the same order as in the directory file, -# or user pre-processing (EG:sorted). -# - -=head1 NAME - -File::Find - Traverse a directory tree. - -=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 is 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. - -=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 - -Don't modify these variables. - -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 <follow> or <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. - -=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(); - 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 ../ - $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 _) { - _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/" ); - } - 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) { - 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)) . ':'; - } - else { - $tmp = join('/',('..') x ($CdLvl-$Level)); - } - die "Can't cd to $dir_name" . $tmp - 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/"; - } - 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) { - 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 ($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 _) { - 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' ) { - 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; - } - else { - return { wanted => $wanted }; - } -} - -sub find { - my $wanted = shift; - _find_opt(wrap_wanted($wanted), @_); -} - -sub finddepth { - my $wanted = wrap_wanted(shift); - $wanted->{bydepth} = 1; - _find_opt($wanted, @_); -} - -# 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/installer/perllib/File/Glob.pm b/Master/tlpkg/installer/perllib/File/Glob.pm deleted file mode 100644 index 133c650529b..00000000000 --- a/Master/tlpkg/installer/perllib/File/Glob.pm +++ /dev/null @@ -1,496 +0,0 @@ -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.05'; - -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/installer/perllib/File/Path.pm b/Master/tlpkg/installer/perllib/File/Path.pm deleted file mode 100644 index 2e41ff3f77f..00000000000 --- a/Master/tlpkg/installer/perllib/File/Path.pm +++ /dev/null @@ -1,285 +0,0 @@ -package File::Path; - -=head1 NAME - -File::Path - create or remove directory trees - -=head1 SYNOPSIS - - use File::Path; - - mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); - rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); - -=head1 DESCRIPTION - -The C<mkpath> function provides a convenient way to create directories, even -if your C<mkdir> kernel call won't create more than one level of directory at -a time. C<mkpath> takes three arguments: - -=over 4 - -=item * - -the name of the path to create, or a reference -to a list of paths to create, - -=item * - -a boolean value, which if TRUE will cause C<mkpath> -to print the name of each directory as it is created -(defaults to FALSE), and - -=item * - -the numeric mode to use when creating the directories -(defaults to 0777), to be modified by the current umask. - -=back - -It returns a list of all directories (including intermediates, determined -using the Unix '/' separator) created. - -If a system error prevents a directory from being created, then the -C<mkpath> function throws a fatal error with C<Carp::croak>. This error -can be trapped with an C<eval> block: - - eval { mkpath($dir) }; - if ($@) { - print "Couldn't create $dir: $@"; - } - -Similarly, the C<rmtree> function provides a convenient way to delete a -subtree from the directory structure, much like the Unix command C<rm -r>. -C<rmtree> takes three arguments: - -=over 4 - -=item * - -the root of the subtree to delete, or a reference to -a list of roots. All of the files and directories -below each root, as well as the roots themselves, -will be deleted. - -=item * - -a boolean value, which if TRUE will cause C<rmtree> to -print a message each time it examines a file, giving the -name of the file, and indicating whether it's using C<rmdir> -or C<unlink> to remove it, or that it's skipping it. -(defaults to FALSE) - -=item * - -a boolean value, which if TRUE will cause C<rmtree> to -skip any files to which you do not have delete access -(if running under VMS) or write access (if running -under another OS). This will change in the future when -a criterion for 'delete permission' under OSs other -than VMS is settled. (defaults to FALSE) - -=back - -It returns the number of files successfully deleted. Symlinks are -simply deleted and not followed. - -B<NOTE:> There are race conditions internal to the implementation of -C<rmtree> making it unsafe to use on directory trees which may be -altered or moved while C<rmtree> is running, and in particular on any -directory trees with any path components or subdirectories potentially -writable by untrusted users. - -Additionally, if the third parameter is not TRUE and C<rmtree> is -interrupted, it may leave files and directories with permissions altered -to allow deletion (and older versions of this module would even set -files and directories to world-read/writable!) - -Note also that the occurrence of errors in C<rmtree> can be determined I<only> -by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent -from the return value. - -=head1 DIAGNOSTICS - -=over 4 - -=item * - -On Windows, if C<mkpath> gives you the warning: B<No such file or -directory>, this may mean that you've exceeded your filesystem's -maximum path length. - -=back - -=head1 AUTHORS - -Tim Bunce <F<Tim.Bunce@ig.co.uk>> and -Charles Bailey <F<bailey@newman.upenn.edu>> - -=cut - -use 5.006; -use Carp; -use File::Basename (); -use Exporter (); -use strict; -use warnings; - -our $VERSION = "1.08"; -our @ISA = qw( Exporter ); -our @EXPORT = qw( mkpath rmtree ); - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -# These OSes complain if you want to remove a file that you have no -# write permission to: -my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || - $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); - -sub mkpath { - my($paths, $verbose, $mode) = @_; - # $paths -- either a path string or ref to list of paths - # $verbose -- optional print "mkdir $path" for each directory created - # $mode -- optional permissions, defaults to 0777 - local($")=$Is_MacOS ? ":" : "/"; - $mode = 0777 unless defined($mode); - $paths = [$paths] unless ref $paths; - my(@created,$path); - foreach $path (@$paths) { - $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT - # Logic wants Unix paths, so go with the flow. - if ($Is_VMS) { - next if $path eq '/'; - $path = VMS::Filespec::unixify($path); - if ($path =~ m:^(/[^/]+)/?\z:) { - $path = $1.'/000000'; - } - } - next if -d $path; - my $parent = File::Basename::dirname($path); - unless (-d $parent or $path eq $parent) { - push(@created,mkpath($parent, $verbose, $mode)); - } - print "mkdir $path\n" if $verbose; - unless (mkdir($path,$mode)) { - my $e = $!; - # allow for another process to have created it meanwhile - $! = $e, croak ("mkdir $path: $e") unless -d $path; - } - push(@created, $path); - } - @created; -} - -sub rmtree { - my($roots, $verbose, $safe) = @_; - my(@files); - my($count) = 0; - $verbose ||= 0; - $safe ||= 0; - - if ( defined($roots) && length($roots) ) { - $roots = [$roots] unless ref $roots; - } - else { - carp "No root path(s) specified\n"; - return 0; - } - - my($root); - foreach $root (@{$roots}) { - if ($Is_MacOS) { - $root = ":$root" if $root !~ /:/; - $root =~ s#([^:])\z#$1:#; - } else { - $root =~ s#/\z##; - } - (undef, undef, my $rp) = lstat $root or next; - $rp &= 07777; # don't forget setuid, setgid, sticky bits - if ( -d _ ) { - # notabene: 0700 is for making readable in the first place, - # it's also intended to change it to writable in case we have - # to recurse in which case we are better than rm -rf for - # subtrees with strange permissions - chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) - or carp "Can't make directory $root read+writeable: $!" - unless $safe; - - if (opendir my $d, $root) { - no strict 'refs'; - if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { - # Blindly untaint dir names - @files = map { /^(.*)$/s ; $1 } readdir $d; - } else { - @files = readdir $d; - } - closedir $d; - } - else { - carp "Can't read $root: $!"; - @files = (); - } - - # Deleting large numbers of files from VMS Files-11 filesystems - # is faster if done in reverse ASCIIbetical order - @files = reverse @files if $Is_VMS; - ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; - if ($Is_MacOS) { - @files = map("$root$_", @files); - } else { - @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); - } - $count += rmtree(\@files,$verbose,$safe); - if ($safe && - ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { - print "skipped $root\n" if $verbose; - next; - } - chmod $rp | 0700, $root - or carp "Can't make directory $root writeable: $!" - if $force_writeable; - print "rmdir $root\n" if $verbose; - if (rmdir $root) { - ++$count; - } - else { - carp "Can't remove directory $root: $!"; - chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) - or carp("and can't restore permissions to " - . sprintf("0%o",$rp) . "\n"); - } - } - else { - if ($safe && - ($Is_VMS ? !&VMS::Filespec::candelete($root) - : !(-l $root || -w $root))) - { - print "skipped $root\n" if $verbose; - next; - } - chmod $rp | 0600, $root - or carp "Can't make file $root writeable: $!" - if $force_writeable; - print "unlink $root\n" if $verbose; - # delete all versions under VMS - for (;;) { - unless (unlink $root) { - carp "Can't unlink file $root: $!"; - if ($force_writeable) { - chmod $rp, $root - or carp("and can't restore permissions to " - . sprintf("0%o",$rp) . "\n"); - } - last; - } - ++$count; - last unless $Is_VMS && lstat $root; - } - } - } - - $count; -} - -1; diff --git a/Master/tlpkg/installer/perllib/File/Spec.pm b/Master/tlpkg/installer/perllib/File/Spec.pm deleted file mode 100644 index 0c8cd21e057..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec.pm +++ /dev/null @@ -1,322 +0,0 @@ -package File::Spec; - -use strict; -use vars qw(@ISA $VERSION); - -$VERSION = '3.12'; -$VERSION = eval $VERSION; - -my %module = (MacOS => 'Mac', - MSWin32 => 'Win32', - os2 => 'OS2', - VMS => 'VMS', - epoc => 'Epoc', - NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. - symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. - dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. - cygwin => 'Cygwin'); - - -my $module = $module{$^O} || 'Unix'; - -require "File/Spec/$module.pm"; -@ISA = ("File::Spec::$module"); - -1; - -__END__ - -=head1 NAME - -File::Spec - portably perform operations on file names - -=head1 SYNOPSIS - - use File::Spec; - - $x=File::Spec->catfile('a', 'b', 'c'); - -which returns 'a/b/c' under Unix. Or: - - use File::Spec::Functions; - - $x = catfile('a', 'b', 'c'); - -=head1 DESCRIPTION - -This module is designed to support operations commonly performed on file -specifications (usually called "file names", but not to be confused with the -contents of a file, or Perl's file handles), such as concatenating several -directory and file names into a single path, or determining whether a path -is rooted. It is based on code directly taken from MakeMaker 5.17, code -written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya -Zakharevich, Paul Schinder, and others. - -Since these functions are different for most operating systems, each set of -OS specific routines is available in a separate module, including: - - File::Spec::Unix - File::Spec::Mac - File::Spec::OS2 - File::Spec::Win32 - File::Spec::VMS - -The module appropriate for the current OS is automatically loaded by -File::Spec. Since some modules (like VMS) make use of facilities available -only under that OS, it may not be possible to load all modules under all -operating systems. - -Since File::Spec is object oriented, subroutines should not be called directly, -as in: - - File::Spec::catfile('a','b'); - -but rather as class methods: - - File::Spec->catfile('a','b'); - -For simple uses, L<File::Spec::Functions> provides convenient functional -forms of these methods. - -=head1 METHODS - -=over 2 - -=item canonpath - -No physical check on the filesystem, but a logical cleanup of a -path. - - $cpath = File::Spec->canonpath( $path ) ; - -Note that this does *not* collapse F<x/../y> sections into F<y>. This -is by design. If F</foo> on your system is a symlink to F</bar/baz>, -then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive -F<../>-removal would give you. If you want to do this kind of -processing, you probably want C<Cwd>'s C<realpath()> function to -actually traverse the filesystem cleaning up paths like this. - -=item catdir - -Concatenate two or more directory names to form a complete path ending -with a directory. But remove the trailing slash from the resulting -string, because it doesn't look good, isn't necessary and confuses -OS/2. Of course, if this is the root directory, don't cut off the -trailing slash :-) - - $path = File::Spec->catdir( @directories ); - -=item catfile - -Concatenate one or more directory names and a filename to form a -complete path ending with a filename - - $path = File::Spec->catfile( @directories, $filename ); - -=item curdir - -Returns a string representation of the current directory. - - $curdir = File::Spec->curdir(); - -=item devnull - -Returns a string representation of the null device. - - $devnull = File::Spec->devnull(); - -=item rootdir - -Returns a string representation of the root directory. - - $rootdir = File::Spec->rootdir(); - -=item tmpdir - -Returns a string representation of the first writable directory from a -list of possible temporary directories. Returns the current directory -if no writable temporary directories are found. The list of directories -checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> -(unless taint is on) and F</tmp>. - - $tmpdir = File::Spec->tmpdir(); - -=item updir - -Returns a string representation of the parent directory. - - $updir = File::Spec->updir(); - -=item no_upwards - -Given a list of file names, strip out those that refer to a parent -directory. (Does not strip symlinks, only '.', '..', and equivalents.) - - @paths = File::Spec->no_upwards( @paths ); - -=item case_tolerant - -Returns a true or false value indicating, respectively, that alphabetic -case is not or is significant when comparing file specifications. - - $is_case_tolerant = File::Spec->case_tolerant(); - -=item file_name_is_absolute - -Takes as its argument a path, and returns true if it is an absolute path. - - $is_absolute = File::Spec->file_name_is_absolute( $path ); - -This does not consult the local filesystem on Unix, Win32, OS/2, or -Mac OS (Classic). It does consult the working environment for VMS -(see L<File::Spec::VMS/file_name_is_absolute>). - -=item path - -Takes no argument. Returns the environment variable C<PATH> (or the local -platform's equivalent) as a list. - - @PATH = File::Spec->path(); - -=item join - -join is the same as catfile. - -=item splitpath - -Splits a path in to volume, directory, and filename portions. On systems -with no concept of volume, returns '' for volume. - - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); - -For systems with no syntax differentiating filenames from directories, -assumes that the last file is a path unless C<$no_file> is true or a -trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> -true makes this return ( '', $path, '' ). - -The directory portion may or may not be returned with a trailing '/'. - -The results can be passed to L</catpath()> to get back a path equivalent to -(usually identical to) the original path. - -=item splitdir - -The opposite of L</catdir()>. - - @dirs = File::Spec->splitdir( $directories ); - -C<$directories> must be only the directory portion of the path on systems -that have the concept of a volume or that have path syntax that differentiates -files from directories. - -Unlike just splitting the directories on the separator, empty -directory names (C<''>) can be returned, because these are significant -on some OSes. - -=item catpath() - -Takes volume, directory and file portions and returns an entire path. Under -Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is -inserted if need be. On other OSes, C<$volume> is significant. - - $full_path = File::Spec->catpath( $volume, $directory, $file ); - -=item abs2rel - -Takes a destination path and an optional base path returns a relative path -from the base path to the destination path: - - $rel_path = File::Spec->abs2rel( $path ) ; - $rel_path = File::Spec->abs2rel( $path, $base ) ; - -If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is -relative, then it is converted to absolute form using -L</rel2abs()>. This means that it is taken to be relative to -L<cwd()|Cwd>. - -On systems with the concept of volume, if C<$path> and C<$base> appear to be -on two different volumes, we will not attempt to resolve the two -paths, and we will instead simply return C<$path>. Note that previous -versions of this module ignored the volume of C<$base>, which resulted in -garbage results part of the time. - -On systems that have a grammar that indicates filenames, this ignores the -C<$base> filename as well. Otherwise all path components are assumed to be -directories. - -If C<$path> is relative, it is converted to absolute form using L</rel2abs()>. -This means that it is taken to be relative to L<cwd()|Cwd>. - -No checks against the filesystem are made. On VMS, there is -interaction with the working environment, as logicals and -macros are expanded. - -Based on code written by Shigio Yamaguchi. - -=item rel2abs() - -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $path ) ; - $abs_path = File::Spec->rel2abs( $path, $base ) ; - -If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is relative, -then it is converted to absolute form using L</rel2abs()>. This means that it -is taken to be relative to L<cwd()|Cwd>. - -On systems with the concept of volume, if C<$path> and C<$base> appear to be -on two different volumes, we will not attempt to resolve the two -paths, and we will instead simply return C<$path>. Note that previous -versions of this module ignored the volume of C<$base>, which resulted in -garbage results part of the time. - -On systems that have a grammar that indicates filenames, this ignores the -C<$base> filename as well. Otherwise all path components are assumed to be -directories. - -If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>. - -No checks against the filesystem are made. On VMS, there is -interaction with the working environment, as logicals and -macros are expanded. - -Based on code written by Shigio Yamaguchi. - -=back - -For further information, please see L<File::Spec::Unix>, -L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or -L<File::Spec::VMS>. - -=head1 SEE ALSO - -L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, -L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, -L<ExtUtils::MakeMaker> - -=head1 AUTHOR - -Currently maintained by Ken Williams C<< <KWILLIAMS@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/installer/perllib/File/Spec/Cygwin.pm b/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm deleted file mode 100644 index 19a2937c6b9..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm +++ /dev/null @@ -1,93 +0,0 @@ -package File::Spec::Cygwin; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.1'; - -@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) = @_; - $path =~ s|\\|/|g; - return $self->SUPER::canonpath($path); -} - -=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 - 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", 'C:/temp' ); -} - -=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 - -1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm b/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm deleted file mode 100644 index a7168f9e494..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm +++ /dev/null @@ -1,77 +0,0 @@ -package File::Spec::Epoc; - -use strict; -use vars qw($VERSION @ISA); - -$VERSION = '1.1'; - -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) = @_; - - $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/installer/perllib/File/Spec/Functions.pm b/Master/tlpkg/installer/perllib/File/Spec/Functions.pm deleted file mode 100644 index 38c898c5d8f..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Functions.pm +++ /dev/null @@ -1,109 +0,0 @@ -package File::Spec::Functions; - -use File::Spec; -use strict; - -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); - -$VERSION = '1.3'; - -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/installer/perllib/File/Spec/Mac.pm b/Master/tlpkg/installer/perllib/File/Spec/Mac.pm deleted file mode 100644 index 8b51bd6c249..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Mac.pm +++ /dev/null @@ -1,780 +0,0 @@ -package File::Spec::Mac; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.4'; - -@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 ('') 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/installer/perllib/File/Spec/OS2.pm b/Master/tlpkg/installer/perllib/File/Spec/OS2.pm deleted file mode 100644 index ec308f3b6f3..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/OS2.pm +++ /dev/null @@ -1,272 +0,0 @@ -package File::Spec::OS2; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.2'; - -@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; - $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - '/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) = @_; - $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/installer/perllib/File/Spec/Unix.pm b/Master/tlpkg/installer/perllib/File/Spec/Unix.pm deleted file mode 100644 index 4a25fe632f2..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Unix.pm +++ /dev/null @@ -1,510 +0,0 @@ -package File::Spec::Unix; - -use strict; -use vars qw($VERSION); - -$VERSION = '1.5'; - -=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) = @_; - - # Handle POSIX-style node names beginning with double slash (qnx, nto) - # Handle network path names beginning with double slash (cygwin) - # (POSIX says: "a pathname that begins with two successive slashes - # may be interpreted in an implementation-defined manner, although - # more than two leading slashes shall be treated as a single slash.") - my $node = ''; - if ( $^O =~ m/^(?:qnx|nto|cygwin)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) { - $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|/+|/|g; # xx////xx -> xx/xx - $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx - $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx - $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx - $path =~ s|^/\.\.$|/|; # /.. -> / - $path =~ s|/\Z(?!\n)|| 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(?!\n)/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(?!\n) )? )? ) ([^/]*) |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) = @_; - - # 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 ) ; - } - - # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path); - my @basechunks = $self->splitdir( $base); - - while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { - shift @pathchunks ; - shift @basechunks ; - } - - $path = CORE::join( '/', @pathchunks ); - $base = CORE::join( '/', @basechunks ); - - # $base now contains the directories the resulting relative path - # must ascend out of before it can descend to $path_directory. So, - # replace all names with $parentDir - $base =~ s|[^/]+|..|g ; - - # Glue the two together, using a separator if necessary, and preventing an - # empty result. - if ( $path ne '' && $base ne '' ) { - $path = "$base/$path" ; - } else { - $path = "$base$path" ; - } - - return $self->canonpath( $path ) ; -} - -=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::cwd(); -} - - -# 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); - - 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/installer/perllib/File/Spec/VMS.pm b/Master/tlpkg/installer/perllib/File/Spec/VMS.pm deleted file mode 100644 index f8923f25fb2..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/VMS.pm +++ /dev/null @@ -1,521 +0,0 @@ -package File::Spec::VMS; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.4'; - -@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. - -=over 4 - -=item canonpath (override) - -Removes redundant portions of file specifications according to VMS syntax. - -=cut - -sub canonpath { - my($self,$path) = @_; - - if ($path =~ m|/|) { # Fake Unix - my $pathify = $path =~ m|/\Z(?!\n)|; - $path = $self->SUPER::canonpath($path); - if ($pathify) { return vmspath($path); } - else { return vmsify($path); } - } - else { - $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/\[\]//; # [] ==> - return $path; - } -} - -=item catdir (override) - -Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" -cases (e.g. elements other than the first being absolute filespecs). - -=cut - -sub catdir { - my ($self,@dirs) = @_; - my $dir = pop @dirs; - @dirs = grep($_,@dirs); - my $rslt; - if (@dirs) { - my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". - if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } - } - else { - if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } - } - return $self->canonpath($rslt); -} - -=item catfile (override) - -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. - -=cut - -sub catfile { - my ($self,@files) = @_; - my $file = $self->canonpath(pop @files); - @files = grep($_,@files); - my $rslt; - if (@files) { - my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); - my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; - if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { - $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } - } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); -} - - -=item curdir (override) - -Returns a string representation of the current directory: '[]' - -=cut - -sub curdir { - return '[]'; -} - -=item devnull (override) - -Returns a string representation of the null device: '_NLA0:' - -=cut - -sub devnull { - return "_NLA0:"; -} - -=item rootdir (override) - -Returns a string representation of the root directory: 'SYS$DISK:[000000]' - -=cut - -sub rootdir { - 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: - - 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 { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); -} - -=item updir (override) - -Returns a string representation of the parent directory: '[-]' - -=cut - -sub updir { - 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) - -Splits using VMS syntax. - -=cut - -sub splitpath { - my($self,$path) = @_; - my($dev,$dir,$file) = ('','',''); - - vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; - return ($1 || '',$2 || '',$3); -} - -=item splitdir (override) - -Split dirspec using VMS syntax. - -=cut - -sub splitdir { - my($self,$dirspec) = @_; - $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 - my(@dirs) = split('\.', vmspath($dirspec)); - $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; - @dirs; -} - - -=item catpath (override) - -Construct a complete filespec using VMS syntax - -=cut - -sub catpath { - my($self,$dev,$dir,$file) = @_; - - # We look for a volume in $dev, then in $dir, but not both - my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); - $dev = $dir_volume unless length $dev; - $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; - - if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } - else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } - if (length($dev) or length($dir)) { - $dir = "[$dir]" unless $dir =~ /[\[<\/]/; - $dir = vmspath($dir); - } - "$dev$dir$file"; -} - -=item abs2rel (override) - -Use VMS syntax when converting filespecs. - -=cut - -sub abs2rel { - my $self = shift; - return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) - if grep m{/}, @_; - - my($path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; - - 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 ); - unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; - my @basechunks = $self->splitdir( $base_directories ); - 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. - $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; - return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; -} - - -=item rel2abs (override) - -Use VMS syntax when converting filespecs. - -=cut - -sub rel2abs { - my $self = shift ; - my ($path,$base ) = @_; - return undef unless defined $path; - if ($path =~ m/\//) { - $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about - ? vmspath($path) # whether it's a directory - : vmsify($path) ); - } - $base = vmspath($base) if defined $base && $base =~ m/\//; - # Clean up and split up $path - if ( ! $self->file_name_is_absolute( $path ) ) { - # Figure out the effective $base and clean it up. - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd; - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } - else { - $base = $self->canonpath( $base ) ; - } - - # Split up paths - my ( $path_directories, $path_file ) = - ($self->splitpath( $path ))[1,2] ; - - my ( $base_volume, $base_directories ) = - $self->splitpath( $base ) ; - - $path_directories = '' if $path_directories eq '[]' || - $path_directories eq '<>'; - my $sep = '' ; - $sep = '.' - if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && - $path_directories =~ m{^[^.\[<]}s - ) ; - $base_directories = "$base_directories$sep$path_directories"; - $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; - - $path = $self->catpath( $base_volume, $base_directories, $path_file ); - } - - return $self->canonpath( $path ) ; -} - - -# 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. -sub eliminate_macros { - my($self,$path) = @_; - return '' unless $path; - $self = {} unless ref $self; - - if ($path =~ /\s/) { - return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; - } - - my($npath) = unixify($path); - my($complex) = 0; - my($head,$macro,$tail); - - # perform m##g in scalar context so it acts as an iterator - while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { - if ($self->{$2}) { - ($head,$macro,$tail) = ($1,$2,$3); - if (ref $self->{$macro}) { - if (ref $self->{$macro} eq 'ARRAY') { - $macro = join ' ', @{$self->{$macro}}; - } - else { - print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), - "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; - $macro = "\cB$macro\cB"; - $complex = 1; - } - } - else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } - $npath = "$head$macro$tail"; - } - } - if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } - $npath; -} - -# Deprecated. See the note above for eliminate_macros(). -sub fixpath { - my($self,$path,$force_path) = @_; - return '' unless $path; - $self = bless {} unless ref $self; - my($fixedpath,$prefix,$name); - - if ($path =~ /\s/) { - return join ' ', - map { $self->fixpath($_,$force_path) } - split /\s+/, $path; - } - - if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { - if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { - $fixedpath = vmspath($self->eliminate_macros($path)); - } - else { - $fixedpath = vmsify($self->eliminate_macros($path)); - } - } - elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { - my($vmspre) = $self->eliminate_macros("\$($prefix)"); - # is it a dir or just a name? - $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; - $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; - $fixedpath = vmspath($fixedpath) if $force_path; - } - else { - $fixedpath = $path; - $fixedpath = vmspath($fixedpath) if $force_path; - } - # No hints, so we try to guess - if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { - $fixedpath = vmspath($fixedpath) if -d $fixedpath; - } - - # 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/installer/perllib/File/Spec/Win32.pm b/Master/tlpkg/installer/perllib/File/Spec/Win32.pm deleted file mode 100644 index a324306a74b..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Win32.pm +++ /dev/null @@ -1,369 +0,0 @@ -package File::Spec::Win32; - -use strict; - -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.6'; - -@ISA = qw(File::Spec::Unix); - -=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( @ENV{qw(TMPDIR TEMP TMP)}, - 'SYS:/temp', - 'C:\system\temp', - 'C:/temp', - '/tmp', - '/' ); -} - -sub case_tolerant { - return 1; -} - -sub file_name_is_absolute { - my ($self,$file) = @_; - return scalar($file =~ m{^([a-z]:)?[\\/]}is); -} - -=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; -} - -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 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 { - my ($self,$path) = @_; - - $path =~ s/^([a-z]:)/\u$1/s; - $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx - $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx - $path =~ s|\\\Z(?!\n)|| - unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx - # xx1/xx2/xx3/../../xx -> xx1/xx - $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up - $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up - return $path if $path =~ m|^\.\.|; # skip relative paths - return $path unless $path =~ /\.\./; # too few .'s to cleanup - return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup - $path =~ s{^\\\.\.$}{\\}; # \.. -> \ - 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx - - return $self->_collapse($path); -} - -=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{^( (?:[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); -} - - -=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 abs2rel { - my($self,$path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; - - for ($path, $base) { $_ = $self->canonpath($_) } - - my ($path_volume) = $self->splitpath($path, 1); - my ($base_volume) = $self->splitpath($base, 1); - - # Can't relativize across volumes - return $path unless $path_volume eq $base_volume; - - for ($path, $base) { $_ = $self->rel2abs($_) } - - my $path_directories = ($self->splitpath($path, 1))[1]; - my $base_directories = ($self->splitpath($base, 1))[1]; - - # 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 ; - } - - my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); - - return $self->canonpath( $self->catpath('', $result_dirs, '') ); -} - - -sub rel2abs { - my ($self,$path,$base ) = @_; - - if ( ! $self->file_name_is_absolute( $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 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/installer/perllib/File/Temp.pm b/Master/tlpkg/installer/perllib/File/Temp.pm deleted file mode 100644 index 6ddcb3619a7..00000000000 --- a/Master/tlpkg/installer/perllib/File/Temp.pm +++ /dev/null @@ -1,2244 +0,0 @@ -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'); - - - $dir = tempdir( CLEANUP => 1 ); - ($fh, $filename) = tempfile( DIR => $dir ); - -Object interface: - - require File::Temp; - use File::Temp (); - - $fh = new File::Temp($template); - $fname = $fh->filename; - - $tmp = new File::Temp( UNLINK => 0, SUFFIX => '.dat' ); - print $tmp "Some data\n"; - print "Filename is $tmp\n"; - -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. - -=cut - -# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls -# People would like a version on 5.005 so give them what they want :-) -use 5.005; -use strict; -use Carp; -use File::Spec 0.8; -use File::Path qw/ rmtree /; -use Fcntl 1.03; -use Errno; -require VMS::Stdio if $^O eq 'VMS'; - -# Need the Symbol package if we are running older perl -require Symbol if $] < 5.006; - -### For the OO interface -use base qw/ IO::Handle /; -use overload '""' => "STRINGIFY"; - - -# 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 - }; - -# Groups of functions for export - -%EXPORT_TAGS = ( - 'POSIX' => [qw/ tmpnam tmpfile /], - 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], - ); - -# add contents of these tags to @EXPORT -Exporter::export_tags('POSIX','mktemp'); - -# Version number - -$VERSION = '0.16'; - -# 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; - -unless ($^O eq 'MacOS') { - for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE EXLOCK 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 - # eg CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; - } -} - -# 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); - no strict 'refs'; - $OPENTEMPFLAGS |= $bit if eval { - # Make sure that redefined die handlers do not cause problems - # eg CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; - } -} - -# 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 - -# 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, - "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 (eg '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 (-d $parent) { - ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; - return (); - } - unless (-w $parent) { - ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n"; - 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; - - # Store callers umask - my $umask = umask(); - - # Set a known umask - umask(066); - - # 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 ); - $open_success = sysopen($fh, $path, $flags, 0600); - } - if ( $open_success ) { - - # Reset umask - umask($umask) if defined $umask; - - # Opened successfully - return file handle and name - return ($fh, $path); - - } else { - # Reset umask - umask($umask) if defined $umask; - - # 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"}) { - - # Store callers umask - my $umask = umask(); - - # Set a known umask - umask(066); - - # Open the temp directory - if (mkdir( $path, 0700)) { - # created okay - # Reset umask - umask($umask) if defined $umask; - - return undef, $path; - } else { - - # Reset umask - umask($umask) if defined $umask; - - # 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 return a random character from the -# character list. Does not do an srand() since rand() -# will do one automatically - -# No arguments. Return value is the random character - -# No longer called since _replace_XX runs a few percent faster if -# I inline the code. This is important if we are creating thousands of -# temporary files. - -sub _randchar { - - $CHARS[ int( rand( $#CHARS ) ) ]; - -} - -# 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. - - if ($ignore) { - substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; - } else { - $path =~ s/X(?=X*\z)/$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; - my $umask = umask(); - umask(066); - chmod 0600, $file; - umask($umask) if defined $umask; -} - - -# 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 real 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 \$<=$< 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 - 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 { - 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) { - rmtree($dir, $DEBUG, 0); - } - } - - # 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. - -=over 4 - -=item B<new> - -Create a temporary file object. - - my $tmp = new File::Temp(); - -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 and SUFFIX. Additionally, the filename -template is specified using the TEMPLATE option. The OPEN option -is not supported (the file is always opened). - - $tmp = new File::Temp( TEMPLATE => 'tempXXXXX', - DIR => 'mydir', - SUFFIX => '.dat'); - -Arguments are case insensitive. - -=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 error 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; - - # 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<filename> - -Return the name of the temporary file associated with this object. - - $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<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 global variable $KEEP_ALL is true, the file will not be removed. - -=cut - -sub DESTROY { - my $self = shift; - if (${*$self}{UNLINK} && !$KEEP_ALL) { - print "# ---------> Unlinking $self\n" if $DEBUG; - - # 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( $self->filename ); # for windows - unlink1( $self, $self->filename ) - or unlink($self->filename); - } -} - -=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, 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( $template, 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. - -Options can be combined as required. - -=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 - ); - - # 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) { - if ($options{"DIR"}) { - - $template = File::Spec->catfile($options{"DIR"}, $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, - ) ); - - # 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. -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. - -=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. - -=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. - -=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. -Returns undef on failure. - -Directory must be removed by the caller. - -=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(). - -=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. - -=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. - -=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. - -=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. 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. - -=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. - -On certain platofms, eg 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. - -=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 the umask() is fixed before opening of the file, -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; - 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. - -=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 binmode() -function to change the mode of the filehandle. - -=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<Apachae::TempFile> for -different implementations of temporary file handling. - -=head1 AUTHOR - -Tim Jenness E<lt>tjenness@cpan.orgE<gt> - -Copyright (C) 1999-2005 Tim Jenness and the UK Particle Physics and -Astronomy Research Council. All Rights Reserved. This program is free -software; you can redistribute it and/or modify it under the same -terms as Perl itself. - -Original Perl implementation loosely based on the OpenBSD C code for -mkstemp(). Thanks to Tom Christiansen for suggesting that this module -should be written and providing ideas for code improvements and -security enhancements. - -=cut - -1; diff --git a/Master/tlpkg/installer/perllib/File/stat.pm b/Master/tlpkg/installer/perllib/File/stat.pm deleted file mode 100644 index 132cbee27ad..00000000000 --- a/Master/tlpkg/installer/perllib/File/stat.pm +++ /dev/null @@ -1,139 +0,0 @@ -package File::stat; -use 5.006; - -use strict; -use warnings; - -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); - -our $VERSION = '1.00'; - -BEGIN { - use Exporter (); - @EXPORT = qw(stat lstat); - @EXPORT_OK = qw( $st_dev $st_ino $st_mode - $st_nlink $st_uid $st_gid - $st_rdev $st_size - $st_atime $st_mtime $st_ctime - $st_blksize $st_blocks - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); -} -use vars @EXPORT_OK; - -# Class::Struct forbids use of @ISA -sub import { goto &Exporter::import } - -use Class::Struct qw(struct); -struct 'File::stat' => [ - map { $_ => '$' } qw{ - dev ino mode nlink uid gid rdev size - atime mtime ctime blksize blocks - } -]; - -sub populate (@) { - return unless @_; - my $stob = new(); - @$stob = ( - $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, - $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) - = @_; - return $stob; -} - -sub lstat ($) { populate(CORE::lstat(shift)) } - -sub stat ($) { - my $arg = shift; - my $st = populate(CORE::stat $arg); - return $st if $st; - my $fh; - { - local $!; - no strict 'refs'; - require Symbol; - $fh = \*{ Symbol::qualify( $arg, caller() )}; - return unless defined fileno $fh; - } - return populate(CORE::stat $fh); -} - -1; -__END__ - -=head1 NAME - -File::stat - by-name interface to Perl's built-in stat() functions - -=head1 SYNOPSIS - - use File::stat; - $st = stat($file) or die "No $file: $!"; - if ( ($st->mode & 0111) && $st->nlink > 1) ) { - print "$file is executable with lotsa links\n"; - } - - use File::stat qw(:FIELDS); - stat($file) or die "No $file: $!"; - if ( ($st_mode & 0111) && $st_nlink > 1) ) { - print "$file is executable with lotsa links\n"; - } - -=head1 DESCRIPTION - -This module's default exports override the core stat() -and lstat() functions, replacing them with versions that return -"File::stat" objects. This object has methods that -return the similarly named structure field name from the -stat(2) function; namely, -dev, -ino, -mode, -nlink, -uid, -gid, -rdev, -size, -atime, -mtime, -ctime, -blksize, -and -blocks. - -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your stat() and lstat() functions.) Access these fields as -variables named with a preceding C<st_> in front their method names. -Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import -the fields. - -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. - -=head1 BUGS - -As of Perl 5.8.0 after using this module you cannot use the implicit -C<$_> or the special filehandle C<_> with stat() or lstat(), trying -to do so leads into strange errors. The workaround is for C<$_> to -be explicit - - my $stat_obj = stat $_; - -and for C<_> to explicitly populate the object using the unexported -and undocumented populate() function with CORE::stat(): - - my $stat_obj = File::stat::populate(CORE::stat(_)); - -=head1 NOTE - -While this class is currently implemented using the Class::Struct -module to build a struct-like class, you shouldn't rely upon this. - -=head1 AUTHOR - -Tom Christiansen |