diff options
Diffstat (limited to 'chromium/third_party/cygwin/lib/perl5/5.10/File')
19 files changed, 11180 insertions, 0 deletions
diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Basename.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Basename.pm new file mode 100644 index 00000000000..b3fe0ac6e59 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Basename.pm @@ -0,0 +1,402 @@ +=head1 NAME + +File::Basename - Parse file paths into directory, filename and suffix. + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist); + $name = fileparse($fullname,@suffixlist); + + $basename = basename($fullname,@suffixlist); + $dirname = dirname($fullname); + + +=head1 DESCRIPTION + +These routines allow you to parse file paths into their directory, filename +and suffix. + +B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and +quirks, of the shell and C functions of the same name. See each +function's documentation for details. If your concern is just parsing +paths it is safer to use L<File::Spec>'s C<splitpath()> and +C<splitdir()> methods. + +It is guaranteed that + + # Where $path_separator is / for Unix, \ for Windows, etc... + dirname($path) . $path_separator . basename($path); + +is equivalent to the original path for all systems but VMS. + + +=cut + + +package File::Basename; + +# A bit of juggling to insure that C<use re 'taint';> always works, since +# File::Basename is used during the Perl build, when the re extension may +# not be available. +BEGIN { + unless (eval { require re; }) + { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT + import re 'taint'; +} + + +use strict; +use 5.006; +use warnings; +our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(fileparse fileparse_set_fstype basename dirname); +$VERSION = "2.77"; + +fileparse_set_fstype($^O); + + +=over 4 + +=item C<fileparse> +X<fileparse> + + my($filename, $directories, $suffix) = fileparse($path); + my($filename, $directories, $suffix) = fileparse($path, @suffixes); + my $filename = fileparse($path, @suffixes); + +The C<fileparse()> routine divides a file path into its $directories, $filename +and (optionally) the filename $suffix. + +$directories contains everything up to and including the last +directory separator in the $path including the volume (if applicable). +The remainder of the $path is the $filename. + + # On Unix returns ("baz", "/foo/bar/", "") + fileparse("/foo/bar/baz"); + + # On Windows returns ("baz", "C:\foo\bar\", "") + fileparse("C:\foo\bar\baz"); + + # On Unix returns ("", "/foo/bar/baz/", "") + fileparse("/foo/bar/baz/"); + +If @suffixes are given each element is a pattern (either a string or a +C<qr//>) matched against the end of the $filename. The matching +portion is removed and becomes the $suffix. + + # On Unix returns ("baz", "/foo/bar/", ".txt") + fileparse("/foo/bar/baz.txt", qr/\.[^.]*/); + +If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern +matching for suffix removal is performed case-insensitively, since +those systems are not case-sensitive when opening existing files. + +You are guaranteed that C<$directories . $filename . $suffix> will +denote the same location as the original $path. + +=cut + + +sub fileparse { + my($fullname,@suffices) = @_; + + unless (defined $fullname) { + require Carp; + Carp::croak("fileparse(): need a valid pathname"); + } + + my $orig_type = ''; + my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); + + my($taint) = substr($fullname,0,0); # Is $fullname tainted? + + if ($type eq "VMS" and $fullname =~ m{/} ) { + # We're doing Unix emulation + $orig_type = $type; + $type = 'Unix'; + } + + my($dirpath, $basename); + + if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) { + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; + } + elsif ($type eq "OS2") { + ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); + $dirpath = './' unless $dirpath; # Can't be 0 + $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; + } + elsif ($type eq "MacOS") { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); + $dirpath = ':' unless $dirpath; + } + elsif ($type eq "AmigaOS") { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); + $dirpath = './' unless $dirpath; + } + elsif ($type eq 'VMS' ) { + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); + $dirpath ||= ''; # should always be defined + } + else { # Default to Unix semantics. + ($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s); + if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + # so strip it off and treat the rest as "normal" + my $devspec = $1; + my $remainder = $3; + ($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s); + $dirpath ||= ''; # should always be defined + $dirpath = $devspec.$dirpath; + } + $dirpath = './' unless $dirpath; + } + + + my $tail = ''; + my $suffix = ''; + if (@suffices) { + foreach $suffix (@suffices) { + my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//s) { + $taint .= substr($suffix,0,0); + $tail = $1 . $tail; + } + } + } + + # Ensure taint is propgated from the path to its pieces. + $tail .= $taint; + wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) + : ($basename .= $taint); +} + + + +=item C<basename> +X<basename> X<filename> + + my $filename = basename($path); + my $filename = basename($path, @suffixes); + +This function is provided for compatibility with the Unix shell command +C<basename(1)>. It does B<NOT> always return the file name portion of a +path as you might expect. To be safe, if you want the file name portion of +a path use C<fileparse()>. + +C<basename()> returns the last level of a filepath even if the last +level is clearly directory. In effect, it is acting like C<pop()> for +paths. This differs from C<fileparse()>'s behaviour. + + # Both return "bar" + basename("/foo/bar"); + basename("/foo/bar/"); + +@suffixes work as in C<fileparse()> except all regex metacharacters are +quoted. + + # These two function calls are equivalent. + my $filename = basename("/foo/bar/baz.txt", ".txt"); + my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/); + +Also note that in order to be compatible with the shell command, +C<basename()> does not strip off a suffix if it is identical to the +remaining characters in the filename. + +=cut + + +sub basename { + my($path) = shift; + + # From BSD basename(1) + # The basename utility deletes any prefix ending with the last slash `/' + # character present in string (after first stripping trailing slashes) + _strip_trailing_sep($path); + + my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) ); + + # From BSD basename(1) + # The suffix is not stripped if it is identical to the remaining + # characters in string. + if( length $suffix and !length $basename ) { + $basename = $suffix; + } + + # Ensure that basename '/' == '/' + if( !length $basename ) { + $basename = $dirname; + } + + return $basename; +} + + + +=item C<dirname> +X<dirname> + +This function is provided for compatibility with the Unix shell +command C<dirname(1)> and has inherited some of its quirks. In spite of +its name it does B<NOT> always return the directory name as you might +expect. To be safe, if you want the directory name of a path use +C<fileparse()>. + +Only on VMS (where there is no ambiguity between the file and directory +portions of a path) and AmigaOS (possibly due to an implementation quirk in +this module) does C<dirname()> work like C<fileparse($path)>, returning just the +$directories. + + # On VMS and AmigaOS + my $directories = dirname($path); + +When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function +which is subtly different from how C<fileparse()> works. It returns all but +the last level of a file path even if the last level is clearly a directory. +In effect, it is not returning the directory portion but simply the path one +level up acting like C<chop()> for file paths. + +Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on +its returned path. + + # returns /foo/bar. fileparse() would return /foo/bar/ + dirname("/foo/bar/baz"); + + # also returns /foo/bar despite the fact that baz is clearly a + # directory. fileparse() would return /foo/bar/baz/ + dirname("/foo/bar/baz/"); + + # returns '.'. fileparse() would return 'foo/' + dirname("foo/"); + +Under VMS, if there is no directory information in the $path, then the +current default device and directory is used. + +=cut + + +sub dirname { + my $path = shift; + + my($type) = $Fileparse_fstype; + + if( $type eq 'VMS' and $path =~ m{/} ) { + # Parse as Unix + local($File::Basename::Fileparse_fstype) = ''; + return dirname($path); + } + + my($basename, $dirname) = fileparse($path); + + if ($type eq 'VMS') { + $dirname ||= $ENV{DEFAULT}; + } + elsif ($type eq 'MacOS') { + if( !length($basename) && $dirname !~ /^[^:]+:\z/) { + _strip_trailing_sep($dirname); + ($basename,$dirname) = fileparse $dirname; + } + $dirname .= ":" unless $dirname =~ /:\z/; + } + elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { + _strip_trailing_sep($dirname); + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + _strip_trailing_sep($dirname); + } + } + elsif ($type eq 'AmigaOS') { + if ( $dirname =~ /:\z/) { return $dirname } + chop $dirname; + $dirname =~ s{[^:/]+\z}{} unless length($basename); + } + else { + _strip_trailing_sep($dirname); + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + _strip_trailing_sep($dirname); + } + } + + $dirname; +} + + +# Strip the trailing path separator. +sub _strip_trailing_sep { + my $type = $Fileparse_fstype; + + if ($type eq 'MacOS') { + $_[0] =~ s/([^:]):\z/$1/s; + } + elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { + $_[0] =~ s/([^:])[\\\/]*\z/$1/; + } + else { + $_[0] =~ s{(.)/*\z}{$1}s; + } +} + + +=item C<fileparse_set_fstype> +X<filesystem> + + my $type = fileparse_set_fstype(); + my $previous_type = fileparse_set_fstype($type); + +Normally File::Basename will assume a file path type native to your current +operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...). +With this function you can override that assumption. + +Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS", +"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility), +"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is +given "Unix" will be assumed. + +If you've selected VMS syntax, and the file specification you pass to +one of these routines contains a "/", they assume you are using Unix +emulation and apply the Unix syntax rules instead, for that function +call only. + +=back + +=cut + + +BEGIN { + +my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc); +my @Types = (@Ignore_Case, qw(Unix)); + +sub fileparse_set_fstype { + my $old = $Fileparse_fstype; + + if (@_) { + my $new_type = shift; + + $Fileparse_fstype = 'Unix'; # default + foreach my $type (@Types) { + $Fileparse_fstype = $type if $new_type =~ /^$type/i; + } + + $Fileparse_igncase = + (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0; + } + + return $old; +} + +} + + +1; + + +=head1 SEE ALSO + +L<dirname(1)>, L<basename(1)>, L<File::Spec> diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/CheckTree.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/CheckTree.pm new file mode 100644 index 00000000000..29f05d8a0fc --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/CheckTree.pm @@ -0,0 +1,238 @@ +package File::CheckTree; + +use 5.006; +use Cwd; +use Exporter; +use File::Spec; +use warnings; +use strict; + +our $VERSION = '4.3'; +our @ISA = qw(Exporter); +our @EXPORT = qw(validate); + +=head1 NAME + +File::CheckTree - run many filetest checks on a tree + +=head1 SYNOPSIS + + use File::CheckTree; + + $num_warnings = validate( q{ + /vmunix -e || die + /boot -e || die + /bin cd + csh -ex + csh !-ug + sh -ex + sh !-ug + /usr -d || warn "What happened to $file?\n" + }); + +=head1 DESCRIPTION + +The validate() routine takes a single multiline string consisting of +directives, each containing a filename plus a file test to try on it. +(The file test may also be a "cd", causing subsequent relative filenames +to be interpreted relative to that directory.) After the file test +you may put C<|| die> to make it a fatal error if the file test fails. +The default is C<|| warn>. The file test may optionally have a "!' prepended +to test for the opposite condition. If you do a cd and then list some +relative filenames, you may want to indent them slightly for readability. +If you supply your own die() or warn() message, you can use $file to +interpolate the filename. + +Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. +Only the first failed test of the bunch will produce a warning. + +The routine returns the number of warnings issued. + +=head1 AUTHOR + +File::CheckTree was derived from lib/validate.pl which was +written by Larry Wall. +Revised by Paul Grassie <F<grassie@perl.com>> in 2002. + +=head1 HISTORY + +File::CheckTree used to not display fatal error messages. +It used to count only those warnings produced by a generic C<|| warn> +(and not those in which the user supplied the message). In addition, +the validate() routine would leave the user program in whatever +directory was last entered through the use of "cd" directives. +These bugs were fixed during the development of perl 5.8. +The first fixed version of File::CheckTree was 4.2. + +=cut + +my $Warnings; + +sub validate { + my ($starting_dir, $file, $test, $cwd, $oldwarnings); + + $starting_dir = cwd; + + $cwd = ""; + $Warnings = 0; + + foreach my $check (split /\n/, $_[0]) { + my ($testlist, @testlist); + + # skip blanks/comments + next if $check =~ /^\s*#/ || $check =~ /^\s*$/; + + # Todo: + # should probably check for invalid directives and die + # but earlier versions of File::CheckTree did not do this either + + # split a line like "/foo -r || die" + # so that $file is "/foo", $test is "-r || die" + # (making special allowance for quoted filenames). + if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or + $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or + $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/) + { + ($file, $test) = ($1,$2); + } + else { + die "Malformed line: '$check'"; + }; + + # change a $test like "!-ug || die" to "!-Z || die", + # capturing the bundled tests (e.g. "ug") in $2 + if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) { + $testlist = $2; + # split bundled tests, e.g. "ug" to 'u', 'g' + @testlist = split(//, $testlist); + } + else { + # put in placeholder Z for stand-alone test + @testlist = ('Z'); + } + + # will compare these two later to stop on 1st warning w/in a bundle + $oldwarnings = $Warnings; + + foreach my $one (@testlist) { + # examples of $test: "!-Z || die" or "-w || warn" + my $this = $test; + + # expand relative $file to full pathname if preceded by cd directive + $file = File::Spec->catfile($cwd, $file) + if $cwd && !File::Spec->file_name_is_absolute($file); + + # put filename in after the test operator + $this =~ s/(-\w\b)/$1 "\$file"/g; + + # change the "-Z" representing a bundle with the $one test + $this =~ s/-Z/-$one/; + + # if it's a "cd" directive... + if ($this =~ /^cd\b/) { + # add "|| die ..." + $this .= ' || die "cannot cd to $file\n"'; + # expand "cd" directive with directory name + $this =~ s/\bcd\b/chdir(\$cwd = '$file')/; + } + else { + # add "|| warn" as a default disposition + $this .= ' || warn' unless $this =~ /\|\|/; + + # change a generic ".. || die" or ".. || warn" + # to call valmess instead of die/warn directly + # valmess will look up the error message from %Val_Message + $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $ + /$1 || valmess('$3', '$2', \$file)/x; + } + + { + # count warnings, either from valmess or '-r || warn "my msg"' + # also, call any pre-existing signal handler for __WARN__ + my $orig_sigwarn = $SIG{__WARN__}; + local $SIG{__WARN__} = sub { + ++$Warnings; + if ( $orig_sigwarn ) { + $orig_sigwarn->(@_); + } + else { + warn "@_"; + } + }; + + # do the test + eval $this; + + # re-raise an exception caused by a "... || die" test + if (my $err = $@) { + # in case of any cd directives, return from whence we came + if ($starting_dir ne cwd) { + chdir($starting_dir) || die "$starting_dir: $!"; + } + die $err; + } + } + + # stop on 1st warning within a bundle of tests + last if $Warnings > $oldwarnings; + } + } + + # in case of any cd directives, return from whence we came + if ($starting_dir ne cwd) { + chdir($starting_dir) || die "chdir $starting_dir: $!"; + } + + return $Warnings; +} + +my %Val_Message = ( + 'r' => "is not readable by uid $>.", + 'w' => "is not writable by uid $>.", + 'x' => "is not executable by uid $>.", + 'o' => "is not owned by uid $>.", + 'R' => "is not readable by you.", + 'W' => "is not writable by you.", + 'X' => "is not executable by you.", + 'O' => "is not owned by you.", + 'e' => "does not exist.", + 'z' => "does not have zero size.", + 's' => "does not have non-zero size.", + 'f' => "is not a plain file.", + 'd' => "is not a directory.", + 'l' => "is not a symbolic link.", + 'p' => "is not a named pipe (FIFO).", + 'S' => "is not a socket.", + 'b' => "is not a block special file.", + 'c' => "is not a character special file.", + 'u' => "does not have the setuid bit set.", + 'g' => "does not have the setgid bit set.", + 'k' => "does not have the sticky bit set.", + 'T' => "is not a text file.", + 'B' => "is not a binary file." +); + +sub valmess { + my ($disposition, $test, $file) = @_; + my $ferror; + + if ($test =~ / ^ (!?) -(\w) \s* $ /x) { + my ($neg, $ftype) = ($1, $2); + + $ferror = "$file $Val_Message{$ftype}"; + + if ($neg eq '!') { + $ferror =~ s/ is not / should not be / || + $ferror =~ s/ does not / should not / || + $ferror =~ s/ not / /; + } + } + else { + $ferror = "Can't do $test $file.\n"; + } + + die "$ferror\n" if $disposition eq 'die'; + warn "$ferror\n"; +} + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Compare.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Compare.pm new file mode 100644 index 00000000000..7418fe61e52 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Compare.pm @@ -0,0 +1,182 @@ +package File::Compare; + +use 5.006; +use strict; +use warnings; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); + +require Exporter; + +$VERSION = '1.1005'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp compare_text); + +$Too_Big = 1024 * 1024 * 2; + +sub croak { + require Carp; + goto &Carp::croak; +} + +sub compare { + croak("Usage: compare( file1, file2 [, buffersize]) ") + unless(@_ == 2 || @_ == 3); + + my ($from,$to,$size) = @_; + my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); + + my ($fromsize,$closefrom,$closeto); + local (*FROM, *TO); + + croak("from undefined") unless (defined $from); + croak("to undefined") unless (defined $to); + + if (ref($from) && + (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { + *FROM = *$from; + } elsif (ref(\$from) eq 'GLOB') { + *FROM = $from; + } else { + open(FROM,"<",$from) or goto fail_open1; + unless ($text_mode) { + binmode FROM; + $fromsize = -s FROM; + } + $closefrom = 1; + } + + if (ref($to) && + (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { + *TO = *$to; + } elsif (ref(\$to) eq 'GLOB') { + *TO = $to; + } else { + open(TO,"<",$to) or goto fail_open2; + binmode TO unless $text_mode; + $closeto = 1; + } + + if (!$text_mode && $closefrom && $closeto) { + # If both are opened files we know they differ if their size differ + goto fail_inner if $fromsize != -s TO; + } + + if ($text_mode) { + local $/ = "\n"; + my ($fline,$tline); + while (defined($fline = <FROM>)) { + goto fail_inner unless defined($tline = <TO>); + if (ref $size) { + # $size contains ref to comparison function + goto fail_inner if &$size($fline, $tline); + } else { + goto fail_inner if $fline ne $tline; + } + } + goto fail_inner if defined($tline = <TO>); + } + else { + unless (defined($size) && $size > 0) { + $size = $fromsize || -s TO || 0; + $size = 1024 if $size < 512; + $size = $Too_Big if $size > $Too_Big; + } + + my ($fr,$tr,$fbuf,$tbuf); + $fbuf = $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) { + goto fail_inner; + } + } + goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0; + } + + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 0; + + # All of these contortions try to preserve error messages... + fail_inner: + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 1; + + fail_open2: + if ($closefrom) { + my $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +sub cmp; +*cmp = \&compare; + +sub compare_text { + my ($from,$to,$cmp) = @_; + croak("Usage: compare_text( file1, file2 [, cmp-function])") + unless @_ == 2 || @_ == 3; + croak("Third arg to compare_text() function must be a code reference") + if @_ == 3 && ref($cmp) ne 'CODE'; + + # Using a negative buffer size puts compare into text_mode too + $cmp = -1 unless defined $cmp; + compare($from, $to, $cmp); +} + +1; + +__END__ + +=head1 NAME + +File::Compare - Compare files or filehandles + +=head1 SYNOPSIS + + use File::Compare; + + if (compare("file1","file2") == 0) { + print "They're equal\n"; + } + +=head1 DESCRIPTION + +The File::Compare::compare function compares the contents of two +sources, each of which can be a file or a file handle. It is exported +from File::Compare by default. + +File::Compare::cmp is a synonym for File::Compare::compare. It is +exported from File::Compare only by request. + +File::Compare::compare_text does a line by line comparison of the two +files. It stops as soon as a difference is detected. compare_text() +accepts an optional third argument: This must be a CODE reference to +a line comparison function, which returns 0 when both lines are considered +equal. For example: + + compare_text($file1, $file2) + +is basically equivalent to + + compare_text($file1, $file2, sub {$_[0] ne $_[1]} ) + +=head1 RETURN + +File::Compare::compare and its sibling functions return 0 if the files +are equal, 1 if the files are unequal, or -1 if an error was encountered. + +=head1 AUTHOR + +File::Compare was written by Nick Ing-Simmons. +Its original documentation was written by Chip Salzenberg. + +=cut + diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Copy.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Copy.pm new file mode 100644 index 00000000000..caf8262e4fa --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Copy.pm @@ -0,0 +1,526 @@ +# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This +# source code has been placed in the public domain by the author. +# Please be kind and preserve the documentation. +# +# Additions copyright 1996 by Charles Bailey. Permission is granted +# to distribute the revised code under the same terms as Perl itself. + +package File::Copy; + +use 5.006; +use strict; +use warnings; +use File::Spec; +use Config; +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.12'; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); + +$Too_Big = 1024 * 1024 * 2; + +sub croak { + require Carp; + goto &Carp::croak; +} + +sub carp { + require Carp; + goto &Carp::carp; +} + +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::MoreFiles }; + warn 'Mac::MoreFiles could not be loaded; using non-native syscopy' + if $@ && $^W; +} + +sub _catname { + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } + + if ($^O eq 'MacOS') { + # a partial dir name that's valid only in the cwd (e.g. 'tmp') + $to = ':' . $to if $to !~ /:/; + } + + return File::Spec->catfile($to, basename($from)); +} + +# _eq($from, $to) tells whether $from and $to are identical +# works for strings and references +sub _eq { + return $_[0] == $_[1] if ref $_[0] && ref $_[1]; + return $_[0] eq $_[1] if !ref $_[0] && !ref $_[1]; + return ""; +} + +sub copy { + croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + + my $size; + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for copy: $size\n") unless ($size > 0); + } + + my $from_a_handle = (ref($from) + ? (ref($from) eq 'GLOB' + || UNIVERSAL::isa($from, 'GLOB') + || UNIVERSAL::isa($from, 'IO::Handle')) + : (ref(\$from) eq 'GLOB')); + my $to_a_handle = (ref($to) + ? (ref($to) eq 'GLOB' + || UNIVERSAL::isa($to, 'GLOB') + || UNIVERSAL::isa($to, 'IO::Handle')) + : (ref(\$to) eq 'GLOB')); + + if (_eq($from, $to)) { # works for references, too + carp("'$from' and '$to' are identical (not copied)"); + # The "copy" was a success as the source and destination contain + # the same data. + return 1; + } + + if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && + !($^O eq 'MSWin32' || $^O eq 'os2')) { + my @fs = stat($from); + if (@fs) { + my @ts = stat($to); + if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { + carp("'$from' and '$to' are identical (not copied)"); + return 0; + } + } + } + + if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); + } + + if (defined &syscopy && !$Syscopy_is_copy + && !$to_a_handle + && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles + && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. + && !($from_a_handle && $^O eq 'MSWin32') + && !($from_a_handle && $^O eq 'MacOS') + && !($from_a_handle && $^O eq 'NetWare') + ) + { + my $copy_to = $to; + + if ($^O eq 'VMS' && -e $from) { + + if (! -d $to && ! -d $from) { + + # VMS has sticky defaults on extensions, which means that + # if there is a null extension on the destination file, it + # will inherit the extension of the source file + # So add a '.' for a null extension. + + $copy_to = VMS::Filespec::vmsify($to); + my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to); + $file = $file . '.' unless ($file =~ /(?<!\^)\./); + $copy_to = File::Spec->catpath($vol, $dirs, $file); + + # Get rid of the old versions to be like UNIX + 1 while unlink $copy_to; + } + } + + return syscopy($from, $copy_to); + } + + my $closefrom = 0; + my $closeto = 0; + my ($status, $r, $buf); + local($\) = ''; + + my $from_h; + if ($from_a_handle) { + $from_h = $from; + } else { + $from = _protect($from) if $from =~ /^\s/s; + $from_h = \do { local *FH }; + open $from_h, "<", $from or goto fail_open1; + binmode $from_h or die "($!,$^E)"; + $closefrom = 1; + } + + # Seems most logical to do this here, in case future changes would want to + # make this croak for some reason. + unless (defined $size) { + $size = tied(*$from_h) ? 0 : -s $from_h || 0; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + my $to_h; + if ($to_a_handle) { + $to_h = $to; + } else { + $to = _protect($to) if $to =~ /^\s/s; + $to_h = \do { local *FH }; + open $to_h, ">", $to or goto fail_open2; + binmode $to_h or die "($!,$^E)"; + $closeto = 1; + } + + $! = 0; + for (;;) { + my ($r, $w, $t); + defined($r = sysread($from_h, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite($to_h, $buf, $r - $w, $w) + or goto fail_inner; + } + } + + close($to_h) || goto fail_open2 if $closeto; + close($from_h) || goto fail_open1 if $closefrom; + + # Use this idiom to avoid uninitialized value warning. + return 1; + + # All of these contortions try to preserve error messages... + fail_inner: + if ($closeto) { + $status = $!; + $! = 0; + close $to_h; + $! = $status unless $!; + } + fail_open2: + if ($closefrom) { + $status = $!; + $! = 0; + close $from_h; + $! = $status unless $!; + } + fail_open1: + return 0; +} + +sub move { + croak("Usage: move(FROM, TO) ") unless @_ == 2; + + my($from,$to) = @_; + + my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); + + if (-d $to && ! -d $from) { + $to = _catname($from, $to); + } + + ($tosz1,$tomt1) = (stat($to))[7,9]; + $fromsz = -s $from; + if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { + # will not rename with overwrite + unlink $to; + } + + my $rename_to = $to; + if (-$^O eq 'VMS' && -e $from) { + + if (! -d $to && ! -d $from) { + # VMS has sticky defaults on extensions, which means that + # if there is a null extension on the destination file, it + # will inherit the extension of the source file + # So add a '.' for a null extension. + + $rename_to = VMS::Filespec::vmsify($to); + my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to); + $file = $file . '.' unless ($file =~ /(?<!\^)\./); + $rename_to = File::Spec->catpath($vol, $dirs, $file); + + # Get rid of the old versions to be like UNIX + 1 while unlink $rename_to; + } + } + + return 1 if rename $from, $rename_to; + + # Did rename return an error even though it succeeded, because $to + # is on a remote NFS file system, and NFS lost the server's ack? + return 1 if defined($fromsz) && !-e $from && # $from disappeared + (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there + ((!defined $tosz1) || # not before or + ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed + $tosz2 == $fromsz; # it's all there + + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something + + { + local $@; + eval { + local $SIG{__DIE__}; + copy($from,$to) or die; + my($atime, $mtime) = (stat($from))[8,9]; + utime($atime, $mtime, $to); + unlink($from) or die; + }; + return 1 unless $@; + } + ($sts,$ossts) = ($! + 0, $^E + 0); + + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; + unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; + ($!,$^E) = ($sts,$ossts); + return 0; +} + +*cp = \© +*mv = \&move; + + +if ($^O eq 'MacOS') { + *_protect = sub { MacPerl::MakeFSSpec($_[0]) }; +} else { + *_protect = sub { "./$_[0]" }; +} + +# &syscopy is an XSUB under OS/2 +unless (defined &syscopy) { + if ($^O eq 'VMS') { + *syscopy = \&rmscopy; + } elsif ($^O eq 'mpeix') { + *syscopy = sub { + return 0 unless @_ == 2; + # Use the MPE cp program in order to + # preserve MPE file attributes. + return system('/bin/cp', '-f', $_[0], $_[1]) == 0; + }; + } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) { + # Win32::CopyFile() fill only work if we can load Win32.xs + *syscopy = sub { + return 0 unless @_ == 2; + return Win32::CopyFile(@_, 1); + }; + } elsif ($macfiles) { + *syscopy = sub { + my($from, $to) = @_; + my($dir, $toname); + + return 0 unless -e $from; + + if ($to =~ /(.*:)([^:]+):?$/) { + ($dir, $toname) = ($1, $2); + } else { + ($dir, $toname) = (":", $to); + } + + unlink($to); + Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1); + }; + } else { + $Syscopy_is_copy = 1; + *syscopy = \© + } +} + +1; + +__END__ + +=head1 NAME + +File::Copy - Copy files or filehandles + +=head1 SYNOPSIS + + use File::Copy; + + copy("file1","file2") or die "Copy failed: $!"; + copy("Copy.pm",\*STDOUT); + move("/dev1/fileA","/dev2/fileB"); + + use File::Copy "cp"; + + $n = FileHandle->new("/a/file","r"); + cp($n,"x"); + +=head1 DESCRIPTION + +The File::Copy module provides two basic functions, C<copy> and +C<move>, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item copy +X<copy> X<cp> + +The C<copy> function takes two +parameters: a file to copy from and a file to copy to. Either +argument may be a string, a FileHandle reference or a FileHandle +glob. Obviously, if the first argument is a filehandle of some +sort, it will be read from, and if it is a file I<name> it will +be opened for reading. Likewise, the second argument will be +written to (and created if need be). Trying to copy a file on top +of itself is a fatal error. + +B<Note that passing in +files as handles instead of names may lead to loss of information +on some operating systems; it is recommended that you use file +names whenever possible.> Files are opened in binary mode where +applicable. To get a consistent behaviour when copying from a +filehandle to a file, use C<binmode> on the filehandle. + +An optional third parameter can be used to specify the buffer +size used for copying. This is the number of bytes from the +first file, that will be held in memory at any given time, before +being written to the second file. The default buffer size depends +upon the file, but will generally be the whole file (up to 2MB), or +1k for filehandles that do not reference files (eg. sockets). + +You may use the syntax C<use File::Copy "cp"> to get at the +"cp" alias for this function. The syntax is I<exactly> the same. + +=item move +X<move> X<mv> X<rename> + +The C<move> function also takes two parameters: the current name +and the intended name of the file to be moved. If the destination +already exists and is a directory, and the source is not a +directory, then the source file will be renamed into the directory +specified by the destination. + +If possible, move() will simply rename the file. Otherwise, it copies +the file to the new location and deletes the original. If an error occurs +during this copy-and-delete process, you may be left with a (possibly partial) +copy of the file under the destination name. + +You may use the "mv" alias for this function in the same way that +you may use the "cp" alias for C<copy>. + +=item syscopy +X<syscopy> + +File::Copy also provides the C<syscopy> routine, which copies the +file specified in the first parameter to the file specified in the +second parameter, preserving OS-specific attributes and file +structure. For Unix systems, this is equivalent to the simple +C<copy> routine, which doesn't preserve OS-specific attributes. For +VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 +systems, this calls the C<syscopy> XSUB directly. For Win32 systems, +this calls C<Win32::CopyFile>. + +On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>, +if available. + +B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>: + +If both arguments to C<copy> are not file handles, +then C<copy> will perform a "system copy" of +the input file to a new output file, in order to preserve file +attributes, indexed file structure, I<etc.> The buffer size +parameter is ignored. If either argument to C<copy> is a +handle to an opened file, then data is copied using Perl +operators, and no effort is made to preserve file attributes +or record structure. + +The system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which +is the routine that does the actual work for syscopy). + +=item rmscopy($from,$to[,$date_flag]) +X<rmscopy> + +The first and second arguments may be strings, typeglobs, typeglob +references, or objects inheriting from IO::Handle; +they are used in all cases to obtain the +I<filespec> of the input and output files, respectively. The +name and type of the input file are used as defaults for the +output file, if necessary. + +A new version of the output file is always created, which +inherits the structure and RMS attributes of the input file, +except for owner and protections (and possibly timestamps; +see below). All data from the input file is copied to the +output file; if either of the first two parameters to C<rmscopy> +is a file handle, its position is unchanged. (Note that this +means a file handle pointing to the output file will be +associated with an old version of that file after C<rmscopy> +returns, not the newly created version.) + +The third parameter is an integer flag, which tells C<rmscopy> +how to handle timestamps. If it is E<lt> 0, none of the input file's +timestamps are propagated to the output file. If it is E<gt> 0, then +it is interpreted as a bitmask: if bit 0 (the LSB) is set, then +timestamps other than the revision date are propagated; if bit 1 +is set, the revision date is propagated. If the third parameter +to C<rmscopy> is 0, then it behaves much like the DCL COPY command: +if the name or type of the output file was explicitly specified, +then no timestamps are propagated, but if they were taken implicitly +from the input filespec, then all timestamps other than the +revision date are propagated. If this parameter is not supplied, +it defaults to 0. + +Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, +it sets C<$!>, deletes the output file, and returns 0. + +=back + +=head1 RETURN + +All functions return 1 on success, 0 on failure. +$! will be set if an error was encountered. + +=head1 NOTES + +=over 4 + +=item * + +On Mac OS (Classic), the path separator is ':', not '/', and the +current directory is denoted as ':', not '.'. You should be careful +about specifying relative pathnames. While a full path always begins +with a volume name, a relative pathname should always begin with a +':'. If specifying a volume name only, a trailing ':' is required. + +E.g. + + copy("file1", "tmp"); # creates the file 'tmp' in the current directory + copy("file1", ":tmp:"); # creates :tmp:file1 + copy("file1", ":tmp"); # same as above + copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do + # that, since it may cause confusion, see example #1) + copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume + copy("file1", ":tmp:file1"); # ok, partial path + copy("file1", "DataHD:"); # creates DataHD:file1 + + move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one + # volume to another + +=back + +=head1 AUTHOR + +File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, +and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. + +=cut + diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/DosGlob.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/DosGlob.pm new file mode 100644 index 00000000000..496a14c1379 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/DosGlob.pm @@ -0,0 +1,571 @@ +#!perl -w + +# use strict fails +#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +our $VERSION = '1.01'; +use strict; +use warnings; + +sub doglob { + my $cond = shift; + my @retval = (); + #print "doglob: ", join('|', @_), "\n"; + OUTER: + for my $pat (@_) { + my @matched = (); + my @globdirs = (); + my $head = '.'; + my $sepchr = '/'; + my $tail; + next OUTER unless defined $pat and $pat ne ''; + # if arg is within quotes strip em and do no globbing + if ($pat =~ /^"(.*)"\z/s) { + $pat = $1; + if ($cond eq 'd') { push(@retval, $pat) if -d $pat } + else { push(@retval, $pat) if -e $pat } + next OUTER; + } + # wildcards with a drive prefix such as h:*.pm must be changed + # to h:./*.pm to expand correctly + if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { + substr($pat,0,2) = $1 . "./"; + } + if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $pat), next OUTER if $tail eq ''; + if ($head =~ /[*?]/) { + @globdirs = doglob('d', $head); + push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; + $pat = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + unless ($pat =~ /[*?]/) { + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + $head .= $pat; + if ($cond eq 'd') { push(@retval,$head) if -d $head } + else { push(@retval,$head) if -e $head } + next OUTER; + } + opendir(D, $head) or next OUTER; + my @leaves = readdir D; + closedir D; + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + + # escape regex metachars but not glob chars + $pat =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex + $pat =~ s/\*/.*/g; + $pat =~ s/\?/.?/g; + + #print "regex: '$pat', head: '$head'\n"; + my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$head$e"; + push(@matched, "$head$e"), next INNER if &$matchsub($e); + # + # [DOS compatibility special case] + # Failed, add a trailing dot and try again, but only + # if name does not have a dot in it *and* pattern + # has a dot *and* name is shorter than 9 chars. + # + if (index($e,'.') == -1 and length($e) < 9 + and index($pat,'\\.') != -1) { + push(@matched, "$head$e"), next INNER if &$matchsub("$e."); + } + } + push @retval, @matched if @matched; + } + return @retval; +} + + +# +# Do DOS-like globbing on Mac OS +# +sub doglob_Mac { + my $cond = shift; + my @retval = (); + + #print "doglob_Mac: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = ':'; + my $not_esc_head = $head; + my $sepchr = ':'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"\z/s) { + $_ = $1; + # $_ may contain escaped metachars '\*', '\?' and '\' + my $not_esc_arg = $_; + $not_esc_arg =~ s/\\([*?\\])/$1/g; + if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } + else { push(@retval, $not_esc_arg) if -e $not_esc_arg } + next OUTER; + } + + if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), next OUTER if $tail eq ''; + # + # $head may contain escaped metachars '\*' and '\?' + + my $tmp_head = $head; + # if a '*' or '?' is preceded by an odd count of '\', temporary delete + # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as + # wildcards + $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; + + if ($tmp_head =~ /[*?]/) { # if there are wildcards ... + @globdirs = doglob_Mac('d', $head); + push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + + $head .= $sepchr; + $not_esc_head = $head; + # unescape $head for file operations + $not_esc_head =~ s/\\([*?\\])/$1/g; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + + my $tmp_tail = $_; + # if a '*' or '?' is preceded by an odd count of '\', temporary delete + # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as + # wildcards + $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; + + unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... + $not_esc_head = $head = '' if $head eq ':'; + my $not_esc_tail = $_; + # unescape $head and $tail for file operations + $not_esc_tail =~ s/\\([*?\\])/$1/g; + $head .= $_; + $not_esc_head .= $not_esc_tail; + if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } + else { push(@retval,$head) if -e $not_esc_head } + next OUTER; + } + #print "opendir($not_esc_head)\n"; + opendir(D, $not_esc_head) or next OUTER; + my @leaves = readdir D; + closedir D; + + # escape regex metachars but not '\' and glob chars '*', '?' + $_ =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex, + # but only if they are not escaped + $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; + + #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; + warn($@), next OUTER if $@; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$not_esc_head$e"; + + if (&$matchsub($e)) { + my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? + "$e" : "$not_esc_head$e"; + # + # On Mac OS, the two glob metachars '*' and '?' and the escape + # char '\' are valid characters for file and directory names. + # We have to escape and treat them specially. + $leave =~ s|([*?\\])|\\$1|g; + push(@matched, $leave); + next INNER; + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# _expand_volume() will only be used on Mac OS (Classic): +# Takes an array of original patterns as argument and returns an array of +# possibly modified patterns. Each original pattern is processed like +# that: +# + If there's a volume name in the pattern, we push a separate pattern +# for each mounted volume that matches (with '*', '?' and '\' escaped). +# + If there's no volume name in the original pattern, it is pushed +# unchanged. +# Note that the returned array of patterns may be empty. +# +sub _expand_volume { + + require MacPerl; # to be verbose + + my @pat = @_; + my @new_pat = (); + my @FSSpec_Vols = MacPerl::Volumes(); + my @mounted_volumes = (); + + foreach my $spec_vol (@FSSpec_Vols) { + # push all mounted volumes into array + push @mounted_volumes, MacPerl::MakePath($spec_vol); + } + #print "mounted volumes: |@mounted_volumes|\n"; + + while (@pat) { + my $pat = shift @pat; + if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? + my $vol_pat = $1; + my $tail = $2; + # + # escape regex metachars but not '\' and glob chars '*', '?' + $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex, + # but only if they are not escaped + $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; + #print "volume regex: '$vol_pat' \n"; + + foreach my $volume (@mounted_volumes) { + if ($volume =~ m|^$vol_pat\z|ios) { + # + # On Mac OS, the two glob metachars '*' and '?' and the + # escape char '\' are valid characters for volume names. + # We have to escape and treat them specially. + $volume =~ s|([*?\\])|\\$1|g; + push @new_pat, $volume . $tail; + } + } + } else { # no volume name in pattern, push original pattern + push @new_pat, $pat; + } + } + return @new_pat; +} + + +# +# _preprocess_pattern() will only be used on Mac OS (Classic): +# Resolves any updirs in the pattern. Removes a single trailing colon +# from the pattern, unless it's a volume name pattern like "*HD:" +# +sub _preprocess_pattern { + my @pat = @_; + + foreach my $p (@pat) { + my $proceed; + # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" + do { + $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + # remove a single trailing colon, e.g. ":*:" -> ":*" + $p =~ s/:([^:]+):\z/:$1/; + } + return @pat; +} + + +# +# _un_escape() will only be used on Mac OS (Classic): +# Unescapes a list of arguments which may contain escaped +# metachars '*', '?' and '\'. +# +sub _un_escape { + foreach (@_) { + s/\\([*?\\])/$1/g; + } + return @_; +} + +# +# this can be used to override CORE::glob in a specific +# package by saying C<use File::DosGlob 'glob';> in that +# namespace. +# + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my($pat,$cxix) = @_; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + if ($pat =~ /\s/) { + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + else { + push @pat, $pat; + } + + # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3. + # abc3 will be the original {3} (and drop the {}). + # abc1 abc2 will be put in @appendpat. + # This was just the esiest way, not nearly the best. + REHASH: { + my @appendpat = (); + for (@pat) { + # There must be a "," I.E. abc{efg} is not what we want. + while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) { + my ($start, $match, $end) = ($1, $2, $3); + #print "Got: \n\t$start\n\t$match\n\t$end\n"; + my $tmp = "$start$match$end"; + while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) { + #print "Striped: $tmp\n"; + # these expanshions will be preformed by the original, + # when we call REHASH. + } + push @appendpat, ("$tmp"); + s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/; + if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) { + $match = $1; + #print "GOT: \n\t$start\n\t$match\n\t$end\n\n"; + $_ = "$start$match$end"; + } + } + #print "Sould have "GOT" vs "Got"!\n"; + #FIXME: There should be checking for this. + # How or what should be done about failure is beond me. + } + if ( $#appendpat != -1 + ) { + #print "LOOP\n"; + #FIXME: Max loop, no way! :") + for ( @appendpat ) { + push @pat, $_; + } + goto REHASH; + } + } + for ( @pat ) { + s/\\{/{/g; + s/\\}/}/g; + s/\\,/,/g; + } + #print join ("\n", @pat). "\n"; + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + if ($^O eq 'MacOS') { + # first, take care of updirs and trailing colons + @pat = _preprocess_pattern(@pat); + # expand volume names + @pat = _expand_volume(@pat); + $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()]; + } else { + $entries{$cxix} = [doglob(1,@pat)]; + } + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +{ + no strict 'refs'; + + sub import { + my $pkg = shift; + return unless @_; + my $sym = shift; + my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; + } +} +1; + +__END__ + +=head1 NAME + +File::DosGlob - DOS like globbing and then some + +=head1 SYNOPSIS + + require 5.004; + + # override CORE::glob in current package + use File::DosGlob 'glob'; + + # override CORE::glob in ALL packages (use with extreme caution!) + use File::DosGlob 'GLOBAL_glob'; + + @perlfiles = glob "..\\pe?l/*.p?"; + print <..\\pe?l/*.p?>; + + # from the command line (overrides only in main::) + > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" + +=head1 DESCRIPTION + +A module that implements DOS-like globbing with a few enhancements. +It is largely compatible with perlglob.exe (the M$ setargv.obj +version) in all but one respect--it understands wildcards in +directory components. + +For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in +that it will find something like '..\lib\File/DosGlob.pm' alright). +Note that all path components are case-insensitive, and that +backslashes and forward slashes are both accepted, and preserved. +You may have to double the backslashes if you are putting them in +literally, due to double-quotish parsing of the pattern by perl. + +Spaces in the argument delimit distinct patterns, so +C<glob('*.exe *.dll')> globs all filenames that end in C<.exe> +or C<.dll>. If you want to put in literal spaces in the glob +pattern, you can escape them with either double quotes, or backslashes. +e.g. C<glob('c:/"Program Files"/*/*.dll')>, or +C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using +C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details +of the quoting rules used. + +Extending it to csh patterns is left as an exercise to the reader. + +=head1 NOTES + +=over 4 + +=item * + +Mac OS (Classic) users should note a few differences. The specification +of pathnames in glob patterns adheres to the usual Mac OS conventions: +The path separator is a colon ':', not a slash '/' or backslash '\'. A +full path always begins with a volume name. A relative pathname on Mac +OS must always begin with a ':', except when specifying a file or +directory name in the current working directory, where the leading colon +is optional. If specifying a volume name only, a trailing ':' is +required. Due to these rules, a glob like E<lt>*:E<gt> will find all +mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find +all files and directories in the current directory. + +Note that updirs in the glob pattern are resolved before the matching begins, +i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, +that a single trailing ':' in the pattern is ignored (unless it's a volume +name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories +I<and> files (and not, as one might expect, only directories). + +The metachars '*', '?' and the escape char '\' are valid characters in +volume, directory and file names on Mac OS. Hence, if you want to match +a '*', '?' or '\' literally, you have to escape these characters. Due to +perl's quoting rules, things may get a bit complicated, when you want to +match a string like '\*' literally, or when you want to match '\' literally, +but treat the immediately following character '*' as metachar. So, here's a +rule of thumb (applies to both single- and double-quoted strings): escape +each '*' or '?' or '\' with a backslash, if you want to treat them literally, +and then double each backslash and your are done. E.g. + +- Match '\*' literally + + escape both '\' and '*' : '\\\*' + double the backslashes : '\\\\\\*' + +(Internally, the glob routine sees a '\\\*', which means that both '\' and +'*' are escaped.) + + +- Match '\' literally, treat '*' as metachar + + escape '\' but not '*' : '\\*' + double the backslashes : '\\\\*' + +(Internally, the glob routine sees a '\\*', which means that '\' is escaped and +'*' is not.) + +Note that you also have to quote literal spaces in the glob pattern, as described +above. + +=back + +=head1 EXPORTS (by request only) + +glob() + +=head1 BUGS + +Should probably be built into the core, and needs to stop +pandering to DOS habits. Needs a dose of optimizium too. + +=head1 AUTHOR + +Gurusamy Sarathy <gsar@activestate.com> + +=head1 HISTORY + +=over 4 + +=item * + +Support for globally overriding glob() (GSAR 3-JUN-98) + +=item * + +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=item * + +A few dir-vs-file optimizations result in glob importation being +10 times faster than using perlglob.exe, and using perlglob.bat is +only twice as slow as perlglob.exe (GSAR 28-MAY-97) + +=item * + +Several cleanups prompted by lack of compatible perlglob.exe +under Borland (GSAR 27-MAY-97) + +=item * + +Initial version (GSAR 20-FEB-97) + +=back + +=head1 SEE ALSO + +perl + +perlglob.bat + +Text::ParseWords + +=cut + diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Fetch.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Fetch.pm new file mode 100644 index 00000000000..8c8b3f90a57 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Fetch.pm @@ -0,0 +1,1226 @@ +package File::Fetch; + +use strict; +use FileHandle; +use File::Copy; +use File::Spec; +use File::Spec::Unix; +use File::Basename qw[dirname]; + +use Cwd qw[cwd]; +use Carp qw[carp]; +use IPC::Cmd qw[can_run run]; +use File::Path qw[mkpath]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Style => 'gettext'; + +use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT + $BLACKLIST $METHOD_FAIL $VERSION $METHODS + $FTP_PASSIVE $TIMEOUT $DEBUG $WARN + ]; + +use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] }; + + +$VERSION = '0.14'; +$VERSION = eval $VERSION; # avoid warnings with development releases +$PREFER_BIN = 0; # XXX TODO implement +$FROM_EMAIL = 'File-Fetch@example.com'; +$USER_AGENT = 'File::Fetch/$VERSION'; +$BLACKLIST = [qw|ftp|]; +$METHOD_FAIL = { }; +$FTP_PASSIVE = 1; +$TIMEOUT = 0; +$DEBUG = 0; +$WARN = 1; + +### methods available to fetch the file depending on the scheme +$METHODS = { + http => [ qw|lwp wget curl lynx| ], + ftp => [ qw|lwp netftp wget curl ncftp ftp| ], + file => [ qw|lwp file| ], + rsync => [ qw|rsync| ] +}; + +### silly warnings ### +local $Params::Check::VERBOSE = 1; +local $Params::Check::VERBOSE = 1; +local $Module::Load::Conditional::VERBOSE = 0; +local $Module::Load::Conditional::VERBOSE = 0; + +### see what OS we are on, important for file:// uris ### +use constant ON_WIN => ($^O eq 'MSWin32'); +use constant ON_VMS => ($^O eq 'VMS'); +use constant ON_UNIX => (!ON_WIN); +use constant HAS_VOL => (ON_WIN); +use constant HAS_SHARE => (ON_WIN); +=pod + +=head1 NAME + +File::Fetch - A generic file fetching mechanism + +=head1 SYNOPSIS + + use File::Fetch; + + ### build a File::Fetch object ### + my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt'); + + ### fetch the uri to cwd() ### + my $where = $ff->fetch() or die $ff->error; + + ### fetch the uri to /tmp ### + my $where = $ff->fetch( to => '/tmp' ); + + ### parsed bits from the uri ### + $ff->uri; + $ff->scheme; + $ff->host; + $ff->path; + $ff->file; + +=head1 DESCRIPTION + +File::Fetch is a generic file fetching mechanism. + +It allows you to fetch any file pointed to by a C<ftp>, C<http>, +C<file>, or C<rsync> uri by a number of different means. + +See the C<HOW IT WORKS> section further down for details. + +=head1 ACCESSORS + +A C<File::Fetch> object has the following accessors + +=over 4 + +=item $ff->uri + +The uri you passed to the constructor + +=item $ff->scheme + +The scheme from the uri (like 'file', 'http', etc) + +=item $ff->host + +The hostname in the uri. Will be empty if host was originally +'localhost' for a 'file://' url. + +=item $ff->vol + +On operating systems with the concept of a volume the second element +of a file:// is considered to the be volume specification for the file. +Thus on Win32 this routine returns the volume, on other operating +systems this returns nothing. + +On Windows this value may be empty if the uri is to a network share, in +which case the 'share' property will be defined. Additionally, volume +specifications that use '|' as ':' will be converted on read to use ':'. + +On VMS, which has a volume concept, this field will be empty because VMS +file specifications are converted to absolute UNIX format and the volume +information is transparently included. + +=item $ff->share + +On systems with the concept of a network share (currently only Windows) returns +the sharename from a file://// url. On other operating systems returns empty. + +=item $ff->path + +The path from the uri, will be at least a single '/'. + +=item $ff->file + +The name of the remote file. For the local file name, the +result of $ff->output_file will be used. + +=cut + + +########################## +### Object & Accessors ### +########################## + +{ + ### template for new() and autogenerated accessors ### + my $Tmpl = { + scheme => { default => 'http' }, + host => { default => 'localhost' }, + path => { default => '/' }, + file => { required => 1 }, + uri => { required => 1 }, + vol => { default => '' }, # windows for file:// uris + share => { default => '' }, # windows for file:// uris + _error_msg => { no_override => 1 }, + _error_msg_long => { no_override => 1 }, + }; + + for my $method ( keys %$Tmpl ) { + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method} = $_[0] if @_; + return $self->{$method}; + } + } + + sub _create { + my $class = shift; + my %hash = @_; + + my $args = check( $Tmpl, \%hash ) or return; + + bless $args, $class; + + if( lc($args->scheme) ne 'file' and not $args->host ) { + return File::Fetch->_error(loc( + "Hostname required when fetching from '%1'",$args->scheme)); + } + + for (qw[path file]) { + unless( $args->$_() ) { # 5.5.x needs the () + return File::Fetch->_error(loc("No '%1' specified",$_)); + } + } + + return $args; + } +} + +=item $ff->output_file + +The name of the output file. This is the same as $ff->file, +but any query parameters are stripped off. For example: + + http://example.com/index.html?x=y + +would make the output file be C<index.html> rather than +C<index.html?x=y>. + +=back + +=cut + +sub output_file { + my $self = shift; + my $file = $self->file; + + $file =~ s/\?.*$//g; + + return $file; +} + +### XXX do this or just point to URI::Escape? +# =head2 $esc_uri = $ff->escaped_uri +# +# =cut +# +# ### most of this is stolen straight from URI::escape +# { ### Build a char->hex map +# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; +# +# sub escaped_uri { +# my $self = shift; +# my $uri = $self->uri; +# +# ### Default unsafe characters. RFC 2732 ^(uric - reserved) +# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/ +# $escapes{$1} || $self->_fail_hi($1)/ge; +# +# return $uri; +# } +# +# sub _fail_hi { +# my $self = shift; +# my $char = shift; +# +# $self->_error(loc( +# "Can't escape '%1', try using the '%2' module instead", +# sprintf("\\x{%04X}", ord($char)), 'URI::Escape' +# )); +# } +# +# sub output_file { +# +# } +# +# +# } + +=head1 METHODS + +=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' ); + +Parses the uri and creates a corresponding File::Fetch::Item object, +that is ready to be C<fetch>ed and returns it. + +Returns false on failure. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + my ($uri); + my $tmpl = { + uri => { required => 1, store => \$uri }, + }; + + check( $tmpl, \%hash ) or return; + + ### parse the uri to usable parts ### + my $href = __PACKAGE__->_parse_uri( $uri ) or return; + + ### make it into a FFI object ### + my $ff = File::Fetch->_create( %$href ) or return; + + + ### return the object ### + return $ff; +} + +### parses an uri to a hash structure: +### +### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' ) +### +### becomes: +### +### $href = { +### scheme => 'ftp', +### host => 'ftp.cpan.org', +### path => '/pub/mirror', +### file => 'index.html' +### }; +### +### In the case of file:// urls there maybe be additional fields +### +### For systems with volume specifications such as Win32 there will be +### a volume specifier provided in the 'vol' field. +### +### 'vol' => 'volumename' +### +### For windows file shares there may be a 'share' key specified +### +### 'share' => 'sharename' +### +### Note that the rules of what a file:// url means vary by the operating system +### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious +### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and +### not '/foo/bar.txt' +### +### Similarly if the host interpreting the url is VMS then +### file:///disk$user/my/notes/note12345.txt' means +### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as +### if it is unix where it means /disk$user/my/notes/note12345.txt'. +### Except for some cases in the File::Spec methods, Perl on VMS will generally +### handle UNIX format file specifications. +### +### This means it is impossible to serve certain file:// urls on certain systems. +### +### Thus are the problems with a protocol-less specification. :-( +### + +sub _parse_uri { + my $self = shift; + my $uri = shift or return; + + my $href = { uri => $uri }; + + ### find the scheme ### + $uri =~ s|^(\w+)://||; + $href->{scheme} = $1; + + ### See rfc 1738 section 3.10 + ### http://www.faqs.org/rfcs/rfc1738.html + ### And wikipedia for more on windows file:// urls + ### http://en.wikipedia.org/wiki/File:// + if( $href->{scheme} eq 'file' ) { + + my @parts = split '/',$uri; + + ### file://hostname/... + ### file://hostname/... + ### normalize file://localhost with file:/// + $href->{host} = $parts[0] || ''; + + ### index in @parts where the path components begin; + my $index = 1; + + ### file:////hostname/sharename/blah.txt + if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) { + + $href->{host} = $parts[2] || ''; # avoid warnings + $href->{share} = $parts[3] || ''; # avoid warnings + + $index = 4 # index after the share + + ### file:///D|/blah.txt + ### file:///D:/blah.txt + } elsif (HAS_VOL) { + + ### this code comes from dmq's patch, but: + ### XXX if volume is empty, wouldn't that be an error? --kane + ### if so, our file://localhost test needs to be fixed as wel + $href->{vol} = $parts[1] || ''; + + ### correct D| style colume descriptors + $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN; + + $index = 2; # index after the volume + } + + ### rebuild the path from the leftover parts; + $href->{path} = join '/', '', splice( @parts, $index, $#parts ); + + } else { + ### using anything but qw() in hash slices may produce warnings + ### in older perls :-( + @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s; + } + + ### split the path into file + dir ### + { my @parts = File::Spec::Unix->splitpath( delete $href->{path} ); + $href->{path} = $parts[1]; + $href->{file} = $parts[2]; + } + + ### host will be empty if the target was 'localhost' and the + ### scheme was 'file' + $href->{host} = '' if ($href->{host} eq 'localhost') and + ($href->{scheme} eq 'file'); + + return $href; +} + +=head2 $ff->fetch( [to => /my/output/dir/] ) + +Fetches the file you requested. By default it writes to C<cwd()>, +but you can override that by specifying the C<to> argument. + +Returns the full path to the downloaded file on success, and false +on failure. + +=cut + +sub fetch { + my $self = shift or return; + my %hash = @_; + + my $to; + my $tmpl = { + to => { default => cwd(), store => \$to }, + }; + + check( $tmpl, \%hash ) or return; + + ### On VMS force to VMS format so File::Spec will work. + $to = VMS::Filespec::vmspath($to) if ON_VMS; + + ### create the path if it doesn't exist yet ### + unless( -d $to ) { + eval { mkpath( $to ) }; + + return $self->_error(loc("Could not create path '%1'",$to)) if $@; + } + + ### set passive ftp if required ### + local $ENV{FTP_PASSIVE} = $FTP_PASSIVE; + + ### we dont use catfile on win32 because if we are using a cygwin tool + ### under cmd.exe they wont understand windows style separators. + my $out_to = ON_WIN ? $to.'/'.$self->output_file + : File::Spec->catfile( $to, $self->output_file ); + + for my $method ( @{ $METHODS->{$self->scheme} } ) { + my $sub = '_'.$method.'_fetch'; + + unless( __PACKAGE__->can($sub) ) { + $self->_error(loc("Cannot call method for '%1' -- WEIRD!", + $method)); + next; + } + + ### method is blacklisted ### + next if grep { lc $_ eq $method } @$BLACKLIST; + + ### method is known to fail ### + next if $METHOD_FAIL->{$method}; + + ### there's serious issues with IPC::Run and quoting of command + ### line arguments. using quotes in the wrong place breaks things, + ### and in the case of say, + ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document + ### "index.html" "http://www.cpan.org/index.html?q=1&y=2" + ### it doesn't matter how you quote, it always fails. + local $IPC::Cmd::USE_IPC_RUN = 0; + + if( my $file = $self->$sub( + to => $out_to + )){ + + unless( -e $file && -s _ ) { + $self->_error(loc("'%1' said it fetched '%2', ". + "but it was not created",$method,$file)); + + ### mark the failure ### + $METHOD_FAIL->{$method} = 1; + + next; + + } else { + + my $abs = File::Spec->rel2abs( $file ); + return $abs; + } + } + } + + + ### if we got here, we looped over all methods, but we weren't able + ### to fetch it. + return; +} + +######################## +### _*_fetch methods ### +######################## + +### LWP fetching ### +sub _lwp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### modules required to download with lwp ### + my $use_list = { + LWP => '0.0', + 'LWP::UserAgent' => '0.0', + 'HTTP::Request' => '0.0', + 'HTTP::Status' => '0.0', + URI => '0.0', + + }; + + if( can_load(modules => $use_list) ) { + + ### setup the uri object + my $uri = URI->new( File::Spec::Unix->catfile( + $self->path, $self->file + ) ); + + ### special rules apply for file:// uris ### + $uri->scheme( $self->scheme ); + $uri->host( $self->scheme eq 'file' ? '' : $self->host ); + $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file'; + + ### set up the useragent object + my $ua = LWP::UserAgent->new(); + $ua->timeout( $TIMEOUT ) if $TIMEOUT; + $ua->agent( $USER_AGENT ); + $ua->from( $FROM_EMAIL ); + $ua->env_proxy; + + my $res = $ua->mirror($uri, $to) or return; + + ### uptodate or fetched ok ### + if ( $res->code == 304 or $res->code == 200 ) { + return $to; + + } else { + return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]", + $res->code, HTTP::Status::status_message($res->code), + $res->status_line)); + } + + } else { + $METHOD_FAIL->{'lwp'} = 1; + return; + } +} + +### Net::FTP fetching +sub _netftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### required modules ### + my $use_list = { 'Net::FTP' => 0 }; + + if( can_load( modules => $use_list ) ) { + + ### make connection ### + my $ftp; + my @options = ($self->host); + push(@options, Timeout => $TIMEOUT) if $TIMEOUT; + unless( $ftp = Net::FTP->new( @options ) ) { + return $self->_error(loc("Ftp creation failed: %1",$@)); + } + + ### login ### + unless( $ftp->login( anonymous => $FROM_EMAIL ) ) { + return $self->_error(loc("Could not login to '%1'",$self->host)); + } + + ### set binary mode, just in case ### + $ftp->binary; + + ### create the remote path + ### remember remote paths are unix paths! [#11483] + my $remote = File::Spec::Unix->catfile( $self->path, $self->file ); + + ### fetch the file ### + my $target; + unless( $target = $ftp->get( $remote, $to ) ) { + return $self->_error(loc("Could not fetch '%1' from '%2'", + $remote, $self->host)); + } + + ### log out ### + $ftp->quit; + + return $target; + + } else { + $METHOD_FAIL->{'netftp'} = 1; + return; + } +} + +### /bin/wget fetch ### +sub _wget_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a wget binary ### + if( my $wget = can_run('wget') ) { + + ### no verboseness, thanks ### + my $cmd = [ $wget, '--quiet' ]; + + ### if a timeout is set, add it ### + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + + ### run passive if specified ### + push @$cmd, '--passive-ftp' if $FTP_PASSIVE; + + ### set the output document, add the uri ### + push @$cmd, '--output-document', + ### DO NOT quote things for IPC::Run, it breaks stuff. + $IPC::Cmd::USE_IPC_RUN + ? ($to, $self->uri) + : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG + )) { + ### wget creates the output document always, even if the fetch + ### fails.. so unlink it in that case + 1 while unlink $to; + + return $self->_error(loc( "Command failed: %1", $captured || '' )); + } + + return $to; + + } else { + $METHOD_FAIL->{'wget'} = 1; + return; + } +} + + +### /bin/ftp fetch ### +sub _ftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a ftp binary ### + if( my $ftp = can_run('ftp') ) { + + my $fh = FileHandle->new; + + local $SIG{CHLD} = 'IGNORE'; + + unless ($fh->open("|$ftp -n")) { + return $self->_error(loc("%1 creation failed: %2", $ftp, $!)); + } + + my @dialog = ( + "lcd " . dirname($to), + "open " . $self->host, + "user anonymous $FROM_EMAIL", + "cd /", + "cd " . $self->path, + "binary", + "get " . $self->file . " " . $self->output_file, + "quit", + ); + + foreach (@dialog) { $fh->print($_, "\n") } + $fh->close or return; + + return $to; + } +} + +### lynx is stupid - it decompresses any .gz file it finds to be text +### use /bin/lynx to fetch files +sub _lynx_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### see if we have a lynx binary ### + if( my $lynx = can_run('lynx') ) { + + unless( IPC::Cmd->can_capture_buffer ) { + $METHOD_FAIL->{'lynx'} = 1; + + return $self->_error(loc( + "Can not capture buffers. Can not use '%1' to fetch files", + 'lynx' )); + } + + ### write to the output file ourselves, since lynx ass_u_mes to much + my $local = FileHandle->new(">$to") + or return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + + ### dump to stdout ### + my $cmd = [ + $lynx, + '-source', + "-auth=anonymous:$FROM_EMAIL", + ]; + + push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $IPC::Cmd::USE_IPC_RUN + ? $self->uri + : QUOTE. $self->uri .QUOTE; + + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + ### print to local file ### + ### XXX on a 404 with a special error page, $captured will actually + ### hold the contents of that page, and make it *appear* like the + ### request was a success, when really it wasn't :( + ### there doesn't seem to be an option for lynx to change the exit + ### code based on a 4XX status or so. + ### the closest we can come is using --error_file and parsing that, + ### which is very unreliable ;( + $local->print( $captured ); + $local->close or return; + + return $to; + + } else { + $METHOD_FAIL->{'lynx'} = 1; + return; + } +} + +### use /bin/ncftp to fetch files +sub _ncftp_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + ### we can only set passive mode in interactive sesssions, so bail out + ### if $FTP_PASSIVE is set + return if $FTP_PASSIVE; + + ### see if we have a ncftp binary ### + if( my $ncftp = can_run('ncftp') ) { + + my $cmd = [ + $ncftp, + '-V', # do not be verbose + '-p', $FROM_EMAIL, # email as password + $self->host, # hostname + dirname($to), # local dir for the file + # remote path to the file + ### DO NOT quote things for IPC::Run, it breaks stuff. + $IPC::Cmd::USE_IPC_RUN + ? File::Spec::Unix->catdir( $self->path, $self->file ) + : QUOTE. File::Spec::Unix->catdir( + $self->path, $self->file ) .QUOTE + + ]; + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + return $to; + + } else { + $METHOD_FAIL->{'ncftp'} = 1; + return; + } +} + +### use /bin/curl to fetch files +sub _curl_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + if (my $curl = can_run('curl')) { + + ### these long opts are self explanatory - I like that -jmb + my $cmd = [ $curl ]; + + push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; + + push(@$cmd, '--silent') unless $DEBUG; + + ### curl does the right thing with passive, regardless ### + if ($self->scheme eq 'ftp') { + push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); + } + + ### curl doesn't follow 302 (temporarily moved) etc automatically + ### so we add --location to enable that. + push @$cmd, '--fail', '--location', '--output', + ### DO NOT quote things for IPC::Run, it breaks stuff. + $IPC::Cmd::USE_IPC_RUN + ? ($to, $self->uri) + : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + return $to; + + } else { + $METHOD_FAIL->{'curl'} = 1; + return; + } +} + + +### use File::Copy for fetching file:// urls ### +### +### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html) +### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://) +### + +sub _file_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + + + ### prefix a / on unix systems with a file uri, since it would + ### look somewhat like this: + ### file:///home/kane/file + ### wheras windows file uris for 'c:\some\dir\file' might look like: + ### file:///C:/some/dir/file + ### file:///C|/some/dir/file + ### or for a network share '\\host\share\some\dir\file': + ### file:////host/share/some/dir/file + ### + ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like: + ### file://vms.host.edu/disk$user/my/notes/note12345.txt + ### + + my $path = $self->path; + my $vol = $self->vol; + my $share = $self->share; + + my $remote; + if (!$share and $self->host) { + return $self->_error(loc( + "Currently %1 cannot handle hosts in %2 urls", + 'File::Fetch', 'file://' + )); + } + + if( $vol ) { + $path = File::Spec->catdir( split /\//, $path ); + $remote = File::Spec->catpath( $vol, $path, $self->file); + + } elsif( $share ) { + ### win32 specific, and a share name, so we wont bother with File::Spec + $path =~ s|/+|\\|g; + $remote = "\\\\".$self->host."\\$share\\$path"; + + } else { + ### File::Spec on VMS can not currently handle UNIX syntax. + my $file_class = ON_VMS + ? 'File::Spec::Unix' + : 'File::Spec'; + + $remote = $file_class->catfile( $path, $self->file ); + } + + ### File::Copy is littered with 'die' statements :( ### + my $rv = eval { File::Copy::copy( $remote, $to ) }; + + ### something went wrong ### + if( !$rv or $@ ) { + return $self->_error(loc("Could not copy '%1' to '%2': %3 %4", + $remote, $to, $!, $@)); + } + + return $to; +} + +### use /usr/bin/rsync to fetch files +sub _rsync_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + if (my $rsync = can_run('rsync')) { + + my $cmd = [ $rsync ]; + + ### XXX: rsync has no I/O timeouts at all, by default + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + + push(@$cmd, '--quiet') unless $DEBUG; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $IPC::Cmd::USE_IPC_RUN + ? ($self->uri, $to) + : (QUOTE. $self->uri .QUOTE, QUOTE. $to .QUOTE); + + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); + } + + return $to; + + } else { + $METHOD_FAIL->{'rsync'} = 1; + return; + } +} + +################################# +# +# Error code +# +################################# + +=pod + +=head2 $ff->error([BOOL]) + +Returns the last encountered error as string. +Pass it a true value to get the C<Carp::longmess()> output instead. + +=cut + +### error handling the way Archive::Extract does it +sub _error { + my $self = shift; + my $error = shift; + + $self->_error_msg( $error ); + $self->_error_msg_long( Carp::longmess($error) ); + + if( $WARN ) { + carp $DEBUG ? $self->_error_msg_long : $self->_error_msg; + } + + return; +} + +sub error { + my $self = shift; + return shift() ? $self->_error_msg_long : $self->_error_msg; +} + + +1; + +=pod + +=head1 HOW IT WORKS + +File::Fetch is able to fetch a variety of uris, by using several +external programs and modules. + +Below is a mapping of what utilities will be used in what order +for what schemes, if available: + + file => LWP, file + http => LWP, wget, curl, lynx + ftp => LWP, Net::FTP, wget, curl, ncftp, ftp + rsync => rsync + +If you'd like to disable the use of one or more of these utilities +and/or modules, see the C<$BLACKLIST> variable further down. + +If a utility or module isn't available, it will be marked in a cache +(see the C<$METHOD_FAIL> variable further down), so it will not be +tried again. The C<fetch> method will only fail when all options are +exhausted, and it was not able to retrieve the file. + +A special note about fetching files from an ftp uri: + +By default, all ftp connections are done in passive mode. To change +that, see the C<$FTP_PASSIVE> variable further down. + +Furthermore, ftp uris only support anonymous connections, so no +named user/password pair can be passed along. + +C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable +further down. + +=head1 GLOBAL VARIABLES + +The behaviour of File::Fetch can be altered by changing the following +global variables: + +=head2 $File::Fetch::FROM_EMAIL + +This is the email address that will be sent as your anonymous ftp +password. + +Default is C<File-Fetch@example.com>. + +=head2 $File::Fetch::USER_AGENT + +This is the useragent as C<LWP> will report it. + +Default is C<File::Fetch/$VERSION>. + +=head2 $File::Fetch::FTP_PASSIVE + +This variable controls whether the environment variable C<FTP_PASSIVE> +and any passive switches to commandline tools will be set to true. + +Default value is 1. + +Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch +files, since passive mode can only be set interactively for this binary + +=head2 $File::Fetch::TIMEOUT + +When set, controls the network timeout (counted in seconds). + +Default value is 0. + +=head2 $File::Fetch::WARN + +This variable controls whether errors encountered internally by +C<File::Fetch> should be C<carp>'d or not. + +Set to false to silence warnings. Inspect the output of the C<error()> +method manually to see what went wrong. + +Defaults to C<true>. + +=head2 $File::Fetch::DEBUG + +This enables debugging output when calling commandline utilities to +fetch files. +This also enables C<Carp::longmess> errors, instead of the regular +C<carp> errors. + +Good for tracking down why things don't work with your particular +setup. + +Default is 0. + +=head2 $File::Fetch::BLACKLIST + +This is an array ref holding blacklisted modules/utilities for fetching +files with. + +To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could +set $File::Fetch::BLACKLIST to: + + $File::Fetch::BLACKLIST = [qw|lwp netftp|] + +The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable. + +See the note on C<MAPPING> below. + +=head2 $File::Fetch::METHOD_FAIL + +This is a hashref registering what modules/utilities were known to fail +for fetching files (mostly because they weren't installed). + +You can reset this cache by assigning an empty hashref to it, or +individually remove keys. + +See the note on C<MAPPING> below. + +=head1 MAPPING + + +Here's a quick mapping for the utilities/modules, and their names for +the $BLACKLIST, $METHOD_FAIL and other internal functions. + + LWP => lwp + Net::FTP => netftp + wget => wget + lynx => lynx + ncftp => ncftp + ftp => ftp + curl => curl + rsync => rsync + +=head1 FREQUENTLY ASKED QUESTIONS + +=head2 So how do I use a proxy with File::Fetch? + +C<File::Fetch> currently only supports proxies with LWP::UserAgent. +You will need to set your environment variables accordingly. For +example, to use an ftp proxy: + + $ENV{ftp_proxy} = 'foo.com'; + +Refer to the LWP::UserAgent manpage for more details. + +=head2 I used 'lynx' to fetch a file, but its contents is all wrong! + +C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>, +which we in turn capture. If that content is a 'custom' error file +(like, say, a C<404 handler>), you will get that contents instead. + +Sadly, C<lynx> doesn't support any options to return a different exit +code on non-C<200 OK> status, giving us no way to tell the difference +between a 'successfull' fetch and a custom error page. + +Therefor, we recommend to only use C<lynx> as a last resort. This is +why it is at the back of our list of methods to try as well. + +=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do? + +C<File::Fetch> is relatively smart about things. When trying to write +a file to disk, it removes the C<query parameters> (see the +C<output_file> method for details) from the file name before creating +it. In most cases this suffices. + +If you have any other characters you need to escape, please install +the C<URI::Escape> module from CPAN, and pre-encode your URI before +passing it to C<File::Fetch>. You can read about the details of URIs +and URI encoding here: + + http://www.faqs.org/rfcs/rfc2396.html + +=head1 TODO + +=over 4 + +=item Implement $PREFER_BIN + +To indicate to rather use commandline tools than modules + +=back + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + + + + diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Find.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Find.pm new file mode 100644 index 00000000000..d39063b4e2b --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Find.pm @@ -0,0 +1,1338 @@ +package File::Find; +use 5.006; +use strict; +use warnings; +use warnings::register; +our $VERSION = '1.13'; +require Exporter; +require Cwd; + +# +# Modified to ensure sub-directory traversal order is not inverded by stack +# push and pops. That is remains in the same order as in the directory file, +# or user pre-processing (EG:sorted). +# + +=head1 NAME + +File::Find - Traverse a directory tree. + +=head1 SYNOPSIS + + use File::Find; + find(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + finddepth(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); + +=head1 DESCRIPTION + +These are functions for searching through directory trees doing work +on each file found similar to the Unix I<find> command. File::Find +exports two functions, C<find> and C<finddepth>. They work similarly +but have subtle differences. + +=over 4 + +=item B<find> + + find(\&wanted, @directories); + find(\%options, @directories); + +C<find()> does a depth-first search over the given C<@directories> in +the order they are given. For each file or directory found, it calls +the C<&wanted> subroutine. (See below for details on how to use the +C<&wanted> function). Additionally, for each directory found, it will +C<chdir()> into that directory and continue the search, invoking the +C<&wanted> function on each file or subdirectory in the directory. + +=item B<finddepth> + + finddepth(\&wanted, @directories); + finddepth(\%options, @directories); + +C<finddepth()> works just like C<find()> except that it invokes the +C<&wanted> function for a directory I<after> invoking it for the +directory's contents. It does a postorder traversal instead of a +preorder traversal, working from the bottom of the directory tree up +where C<find()> works from the top of the tree down. + +=back + +=head2 %options + +The first argument to C<find()> is either a code reference to your +C<&wanted> function, or a hash reference describing the operations +to be performed for each file. The +code reference is described in L<The wanted function> below. + +Here are the possible keys for the hash: + +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is +described in L<The wanted function> below. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point C<finddepth()> is a shortcut for +specifying C<< { bydepth => 1 } >> in the first argument of C<find()>. + +=item C<preprocess> + +The value should be a code reference. This code reference is used to +preprocess the current directory. The name of the currently processed +directory is in C<$File::Find::dir>. Your preprocessing function is +called after C<readdir()>, but before the loop that calls the C<wanted()> +function. It is called with a list of strings (actually file/directory +names) and is expected to return a list of strings. The code can be +used to sort the file/directory names alphabetically, numerically, +or to filter out directory entries based on their name alone. When +I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. + +=item C<postprocess> + +The value should be a code reference. It is invoked just before leaving +the currently processed directory. It is called in void context with no +arguments. The name of the current directory is in C<$File::Find::dir>. This +hook is handy for summarizing a directory, such as calculating its disk +usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a +no-op. + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See I<follow_fast> and I<follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item * + +It is guaranteed that an I<lstat> has been called before the user's +C<wanted()> function is called. This enables fast file checks involving S<_>. +Note that this guarantee no longer holds if I<follow> or I<follow_fast> +are not set. + +=item * + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved. If the link is +a dangling symbolic link, then fullname will be set to C<undef>. + +=back + +This is a no-op on Win32. + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files more +than once. It does detect cycles, however. Since only symbolic links +have to be hashed, this is much cheaper both in space and time. If +processing a file more than once (by the user's C<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +This is also a no-op on Win32. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. + +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. + +C<follow_skip==2> causes File::Find to ignore any duplicate files and +directories but to proceed normally otherwise. + +=item C<dangling_symlinks> + +If true and a code reference, will be called with the symbolic link +name and the directory it lives in as arguments. Otherwise, if true +and warnings are on, warning "symbolic_link_name is a dangling +symbolic link\n" will be issued. If false, the dangling symbolic link +will be silently ignored. + +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The C<wanted()> +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in taint-mode (-T command line switch or if EUID != UID +or if EGID != GID) then internally directory names have to be untainted +before they can be chdir'ed to. Therefore they are checked against a regular +expression I<untaint_pattern>. Note that all names passed to the user's +I<wanted()> function are still tainted. If this option is used while +not in taint-mode, C<untaint> is a no-op. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the parentheses are vital. + +=item C<untaint_skip> + +If set, a directory which fails the I<untaint_pattern> is skipped, +including all its sub-directories. The default is to 'die' in such a case. + +=back + +=head2 The wanted function + +The C<wanted()> function does whatever verifications you want on +each file and directory. Note that despite its name, the C<wanted()> +function is a generic callback function, and does B<not> tell +File::Find if a file is "wanted" or not. In fact, its return value +is ignored. + +The wanted function takes no arguments but rather does its work +through a collection of variables. + +=over 4 + +=item C<$File::Find::dir> is the current directory name, + +=item C<$_> is the current filename within that directory + +=item C<$File::Find::name> is the complete pathname to the file. + +=back + +The above variables have all been localized and may be changed without +effecting data outside of the wanted function. + +For example, when examining the file F</some/path/foo.ext> you will have: + + $File::Find::dir = /some/path/ + $_ = foo.ext + $File::Find::name = /some/path/foo.ext + +You are chdir()'d to C<$File::Find::dir> when the function is called, +unless C<no_chdir> was specified. Note that when changing to +directories is in effect the root directory (F</>) is a somewhat +special case inasmuch as the concatenation of C<$File::Find::dir>, +C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The +table below summarizes all variants: + + $File::Find::name $File::Find::dir $_ + default / / . + no_chdir=>0 /etc / etc + /etc/x /etc x + + no_chdir=>1 / / / + /etc / /etc + /etc/x /etc /etc/x + + +When C<follow> or C<follow_fast> are in effect, there is +also a C<$File::Find::fullname>. The function may set +C<$File::Find::prune> to prune the tree unless C<bydepth> was +specified. Unless C<follow> or C<follow_fast> is specified, for +compatibility reasons (find.pl, find2perl) there are in addition the +following globals available: C<$File::Find::topdir>, +C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. + +This library is useful for the C<find2perl> tool, which when fed, + + find2perl / -name .nfs\* -mtime +7 \ + -exec rm -f {} \; -o -fstype nfs -prune + +produces something like: + + sub wanted { + /^\.nfs.*\z/s && + (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && + int(-M _) > 7 && + unlink($_) + || + ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && + $dev < 0 && + ($File::Find::prune = 1); + } + +Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical +filehandle that caches the information from the preceding +C<stat()>, C<lstat()>, or filetest. + +Here's another interesting wanted function. It will find all symbolic +links that don't resolve: + + sub wanted { + -l && !-e && print "bogus link: $File::Find::name\n"; + } + +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 WARNINGS + +If you run your program with the C<-w> switch, or if you use the +C<warnings> pragma, File::Find will report warnings for several weird +situations. You can disable these warnings by putting the statement + + no warnings 'File::Find'; + +in the appropriate scope. See L<perllexwarn> for more info about lexical +warnings. + +=head1 CAVEAT + +=over 2 + +=item $dont_use_nlink + +You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to +force File::Find to always stat directories. This was used for file systems +that do not have an C<nlink> count matching the number of sub-directories. +Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file +system) and a couple of others. + +You shouldn't need to set this variable, since File::Find should now detect +such file systems on-the-fly and switch itself to using stat. This works even +for parts of your file system, like a mounted CD-ROM. + +If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs. + +=item symlinks + +Be aware that the option to follow symbolic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. + +=back + +=head1 NOTES + +=over 4 + +=item * + +Mac OS (Classic) users should note a few differences: + +=over 4 + +=item * + +The path separator is ':', not '/', and the current directory is denoted +as ':', not '.'. You should be careful about specifying relative pathnames. +While a full path always begins with a volume name, a relative pathname +should always begin with a ':'. If specifying a volume name only, a +trailing ':' is required. + +=item * + +C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_> +contains the name of a directory, that name may or may not end with a +':'. Likewise, C<$File::Find::name>, which contains the complete +pathname to that directory, and C<$File::Find::fullname>, which holds +the absolute pathname of that directory with all symbolic links resolved, +may or may not end with a ':'. + +=item * + +The default C<untaint_pattern> (see above) on Mac OS is set to +C<qr|^(.+)$|>. Note that the parentheses are vital. + +=item * + +The invisible system file "Icon\015" is ignored. While this file may +appear in every directory, there are some more invisible system files +on every volume, which are all located at the volume root level (i.e. +"MacintoshHD:"). These system files are B<not> excluded automatically. +Your filter may use the following code to recognize invisible files or +directories (requires Mac::Files): + + use Mac::Files; + + # invisible() -- returns 1 if file/directory is invisible, + # 0 if it's visible or undef if an error occurred + + sub invisible($) { + my $file = shift; + my ($fileCat, $fileInfo); + my $invisible_flag = 1 << 14; + + if ( $fileCat = FSpGetCatInfo($file) ) { + if ($fileInfo = $fileCat->ioFlFndrInfo() ) { + return (($fileInfo->fdFlags & $invisible_flag) && 1); + } + } + return undef; + } + +Generally, invisible files are system files, unless an odd application +decides to use invisible files for its own purposes. To distinguish +such files from system files, you have to look at the B<type> and B<creator> +file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and +C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes +(see MacPerl.pm for details). + +Files that appear on the desktop actually reside in an (hidden) directory +named "Desktop Folder" on the particular disk volume. Note that, although +all desktop files appear to be on the same "virtual" desktop, each disk +volume actually maintains its own "Desktop Folder" directory. + +=back + +=back + +=head1 BUGS AND CAVEATS + +Despite the name of the C<finddepth()> function, both C<find()> and +C<finddepth()> perform a depth-first search of the directory +hierarchy. + +=head1 HISTORY + +File::Find used to produce incorrect results if called recursively. +During the development of perl 5.8 this bug was fixed. +The first fixed version of File::Find was 1.01. + +=cut + +our @ISA = qw(Exporter); +our @EXPORT = qw(find finddepth); + + +use strict; +my $Is_VMS; +my $Is_MacOS; + +require File::Basename; +require File::Spec; + +# Should ideally be my() not our() but local() currently +# refuses to operate on lexicals + +our %SLnkSeen; +our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process, $dangling_symlinks); + +sub contract_name { + my ($cdir,$fn) = @_; + + return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir; + + $cdir = substr($cdir,0,rindex($cdir,'/')+1); + + $fn =~ s|^\./||; + + my $abs_name= $cdir . $fn; + + if (substr($fn,0,3) eq '../') { + 1 while $abs_name =~ s!/[^/]*/\.\./!/!; + } + + return $abs_name; +} + +# return the absolute name of a directory or file +sub contract_name_Mac { + my ($cdir,$fn) = @_; + my $abs_name; + + if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':' + + my $colon_count = length ($1); + if ($colon_count == 1) { + $abs_name = $cdir . $2; + return $abs_name; + } + else { + # need to move up the tree, but + # only if it's not a volume name + for (my $i=1; $i<$colon_count; $i++) { + unless ($cdir =~ /^[^:]+:$/) { # volume name + $cdir =~ s/[^:]+:$//; + } + else { + return undef; + } + } + $abs_name = $cdir . $2; + return $abs_name; + } + + } + else { + + # $fn may be a valid path to a directory or file or (dangling) + # symlink, without a leading ':' + if ( (-e $fn) || (-l $fn) ) { + if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:* + return $fn; # $fn is already an absolute path + } + else { + $abs_name = $cdir . $fn; + return $abs_name; + } + } + else { # argh!, $fn is not a valid directory/file + return undef; + } + } +} + +sub PathCombine($$) { + my ($Base,$Name) = @_; + my $AbsName; + + if ($Is_MacOS) { + # $Name is the resolved symlink (always a full path on MacOS), + # i.e. there's no need to call contract_name_Mac() + $AbsName = $Name; + + # (simple) check for recursion + if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion + return undef; + } + } + else { + if (substr($Name,0,1) eq '/') { + $AbsName= $Name; + } + else { + $AbsName= contract_name($Base,$Name); + } + + # (simple) check for recursion + my $newlen= length($AbsName); + if ($newlen <= length($Base)) { + if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') + && $AbsName eq substr($Base,0,$newlen)) + { + return undef; + } + } + } + return $AbsName; +} + +sub Follow_SymLink($) { + my ($AbsName) = @_; + + my ($NewName,$DEV, $INO); + ($DEV, $INO)= lstat $AbsName; + + while (-l _) { + if ($SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 2) { + die "$AbsName is encountered a second time"; + } + else { + return undef; + } + } + $NewName= PathCombine($AbsName, readlink($AbsName)); + unless(defined $NewName) { + if ($follow_skip < 2) { + die "$AbsName is a recursive symbolic link"; + } + else { + return undef; + } + } + else { + $AbsName= $NewName; + } + ($DEV, $INO) = lstat($AbsName); + return undef unless defined $DEV; # dangling symbolic link + } + + if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) { + if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) { + die "$AbsName encountered a second time"; + } + else { + return undef; + } + } + + return $AbsName; +} + +our($dir, $name, $fullname, $prune); +sub _find_dir_symlnk($$$); +sub _find_dir($$$); + +# check whether or not a scalar variable is tainted +# (code straight from the Camel, 3rd ed., page 561) +sub is_tainted_pp { + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length + local $@; + eval { eval "# $nada" }; + return length($@) != 0; +} + +sub _find_opt { + my $wanted = shift; + die "invalid top directory" unless defined $_[0]; + + # This function must local()ize everything because callbacks may + # call find() or finddepth() + + local %SLnkSeen; + local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process, $dangling_symlinks); + local($dir, $name, $fullname, $prune); + local *_ = \my $a; + + my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd(); + if ($Is_VMS) { + # VMS returns this by default in VMS format which just doesn't + # work for the rest of this module. + $cwd = VMS::Filespec::unixpath($cwd); + + # Apparently this is not expected to have a trailing space. + # To attempt to make VMS/UNIX conversions mostly reversable, + # a trailing slash is needed. The run-time functions ignore the + # resulting double slash, but it causes the perl tests to fail. + $cwd =~ s#/\z##; + + # This comes up in upper case now, but should be lower. + # In the future this could be exact case, no need to change. + } + my $cwd_untainted = $cwd; + my $check_t_cwd = 1; + $wanted_callback = $wanted->{wanted}; + $bydepth = $wanted->{bydepth}; + $pre_process = $wanted->{preprocess}; + $post_process = $wanted->{postprocess}; + $no_chdir = $wanted->{no_chdir}; + $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow}; + $follow = $^O eq 'MSWin32' ? 0 : + $full_check || $wanted->{follow_fast}; + $follow_skip = $wanted->{follow_skip}; + $untaint = $wanted->{untaint}; + $untaint_pat = $wanted->{untaint_pattern}; + $untaint_skip = $wanted->{untaint_skip}; + $dangling_symlinks = $wanted->{dangling_symlinks}; + + # for compatibility reasons (find.pl, find2perl) + local our ($topdir, $topdev, $topino, $topmode, $topnlink); + + # a symbolic link to a directory doesn't increase the link count + $avoid_nlink = $follow || $File::Find::dont_use_nlink; + + my ($abs_dir, $Is_Dir); + + Proc_Top_Item: + foreach my $TOP (@_) { + my $top_item = $TOP; + + ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; + + if ($Is_MacOS) { + $top_item = ":$top_item" + if ( (-d _) && ( $top_item !~ /:/ ) ); + } elsif ($^O eq 'MSWin32') { + $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|; + } + else { + $top_item =~ s|/\z|| unless $top_item eq '/'; + } + + $Is_Dir= 0; + + if ($follow) { + + if ($Is_MacOS) { + $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety + + if ($top_item eq $File::Find::current_dir) { + $abs_dir = $cwd; + } + else { + $abs_dir = contract_name_Mac($cwd, $top_item); + unless (defined $abs_dir) { + warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n"; + next Proc_Top_Item; + } + } + + } + else { + if (substr($top_item,0,1) eq '/') { + $abs_dir = $top_item; + } + elsif ($top_item eq $File::Find::current_dir) { + $abs_dir = $cwd; + } + else { # care about any ../ + $top_item =~ s/\.dir\z//i if $Is_VMS; + $abs_dir = contract_name("$cwd/",$top_item); + } + } + $abs_dir= Follow_SymLink($abs_dir); + unless (defined $abs_dir) { + if ($dangling_symlinks) { + if (ref $dangling_symlinks eq 'CODE') { + $dangling_symlinks->($top_item, $cwd); + } else { + warnings::warnif "$top_item is a dangling symbolic link\n"; + } + } + next Proc_Top_Item; + } + + if (-d _) { + $top_item =~ s/\.dir\z//i if $Is_VMS; + _find_dir_symlnk($wanted, $abs_dir, $top_item); + $Is_Dir= 1; + } + } + else { # no follow + $topdir = $top_item; + unless (defined $topnlink) { + warnings::warnif "Can't stat $top_item: $!\n"; + next Proc_Top_Item; + } + if (-d _) { + $top_item =~ s/\.dir\z//i if $Is_VMS; + _find_dir($wanted, $top_item, $topnlink); + $Is_Dir= 1; + } + else { + $abs_dir= $top_item; + } + } + + unless ($Is_Dir) { + unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { + if ($Is_MacOS) { + ($dir,$_) = (':', $top_item); # $File::Find::dir, $_ + } + else { + ($dir,$_) = ('./', $top_item); + } + } + + $abs_dir = $dir; + if (( $untaint ) && (is_tainted($dir) )) { + ( $abs_dir ) = $dir =~ m|$untaint_pat|; + unless (defined $abs_dir) { + if ($untaint_skip == 0) { + die "directory $dir is still tainted"; + } + else { + next Proc_Top_Item; + } + } + } + + unless ($no_chdir || chdir $abs_dir) { + warnings::warnif "Couldn't chdir $abs_dir: $!\n"; + next Proc_Top_Item; + } + + $name = $abs_dir . $_; # $File::Find::name + $_ = $name if $no_chdir; + + { $wanted_callback->() }; # protect against wild "next" + + } + + unless ( $no_chdir ) { + if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) { + ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|; + unless (defined $cwd_untainted) { + die "insecure cwd in find(depth)"; + } + $check_t_cwd = 0; + } + unless (chdir $cwd_untainted) { + die "Can't cd to $cwd: $!\n"; + } + } + } +} + +# API: +# $wanted +# $p_dir : "parent directory" +# $nlink : what came back from the stat +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir($$$) { + my ($wanted, $p_dir, $nlink) = @_; + my ($CdLvl,$Level) = (0,0); + my @Stack; + my @filenames; + my ($subcount,$sub_nlink); + my $SE= []; + my $dir_name= $p_dir; + my $dir_pref; + my $dir_rel = $File::Find::current_dir; + my $tainted = 0; + my $no_nlink; + + if ($Is_MacOS) { + $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface + } elsif ($^O eq 'MSWin32') { + $dir_pref = ($p_dir =~ m|\w:/?$| ? $p_dir : "$p_dir/" ); + } elsif ($^O eq 'VMS') { + + # VMS is returning trailing .dir on directories + # and trailing . on files and symbolic links + # in UNIX syntax. + # + + $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.'; + + $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" ); + } + else { + $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); + } + + local ($dir, $name, $prune, *DIR); + + unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) { + my $udir = $p_dir; + if (( $untaint ) && (is_tainted($p_dir) )) { + ( $udir ) = $p_dir =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $p_dir is still tainted"; + } + else { + return; + } + } + } + unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { + warnings::warnif "Can't cd to $udir: $!\n"; + return; + } + } + + # push the starting directory + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + + if ($Is_MacOS) { + $p_dir = $dir_pref; # ensure trailing ':' + } + + while (defined $SE) { + unless ($bydepth) { + $dir= $p_dir; # $File::Find::dir + $name= $dir_name; # $File::Find::name + $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ + # prune may happen here + $prune= 0; + { $wanted_callback->() }; # protect against wild "next" + next if $prune; + } + + # change to that directory + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + my $udir= $dir_rel; + if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) { + ( $udir ) = $dir_rel =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + if ($Is_MacOS) { + die "directory ($p_dir) $dir_rel is still tainted"; + } + else { + die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted"; + } + } else { # $untaint_skip == 1 + next; + } + } + } + unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { + if ($Is_MacOS) { + warnings::warnif "Can't cd to ($p_dir) $udir: $!\n"; + } + else { + warnings::warnif "Can't cd to (" . + ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n"; + } + next; + } + $CdLvl++; + } + + if ($Is_MacOS) { + $dir_name = "$dir_name:" unless ($dir_name =~ /:$/); + } + + $dir= $dir_name; # $File::Find::dir + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) { + warnings::warnif "Can't opendir($dir_name): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + @filenames = $pre_process->(@filenames) if $pre_process; + push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; + + # default: use whatever was specifid + # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back) + $no_nlink = $avoid_nlink; + # if dir has wrong nlink count, force switch to slower stat method + $no_nlink = 1 if ($nlink < 2); + + if ($nlink == 2 && !$no_nlink) { + # This dir has no subdirectories. + for my $FN (@filenames) { + if ($Is_VMS) { + # Big hammer here - Compensate for VMS trailing . and .dir + # No win situation until this is changed, but this + # will handle the majority of the cases with breaking the fewest + + $FN =~ s/\.dir\z//i; + $FN =~ s#\.$## if ($FN ne '.'); + } + next if $FN =~ $File::Find::skip_pattern; + + $name = $dir_pref . $FN; # $File::Find::name + $_ = ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + + } + else { + # This dir has subdirectories. + $subcount = $nlink - 2; + + # HACK: insert directories at this position. so as to preserve + # the user pre-processed ordering of files. + # EG: directory traversal is in user sorted order, not at random. + my $stack_top = @Stack; + + for my $FN (@filenames) { + next if $FN =~ $File::Find::skip_pattern; + if ($subcount > 0 || $no_nlink) { + # Seen all the subdirs? + # check for directoriness. + # stat is faster for a file in the current directory + $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; + + if (-d _) { + --$subcount; + $FN =~ s/\.dir\z//i if $Is_VMS; + # HACK: replace push to preserve dir traversal order + #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; + splice @Stack, $stack_top, 0, + [$CdLvl,$dir_name,$FN,$sub_nlink]; + } + else { + $name = $dir_pref . $FN; # $File::Find::name + $_= ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + else { + $name = $dir_pref . $FN; # $File::Find::name + $_= ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + } + } + continue { + while ( defined ($SE = pop @Stack) ) { + ($Level, $p_dir, $dir_rel, $nlink) = @$SE; + if ($CdLvl > $Level && !$no_chdir) { + my $tmp; + if ($Is_MacOS) { + $tmp = (':' x ($CdLvl-$Level)) . ':'; + } + elsif ($Is_VMS) { + $tmp = '[' . ('-' x ($CdLvl-$Level)) . ']'; + } + else { + $tmp = join('/',('..') x ($CdLvl-$Level)); + } + die "Can't cd to $tmp from $dir_name" + unless chdir ($tmp); + $CdLvl = $Level; + } + + if ($Is_MacOS) { + # $pdir always has a trailing ':', except for the starting dir, + # where $dir_rel eq ':' + $dir_name = "$p_dir$dir_rel"; + $dir_pref = "$dir_name:"; + } + elsif ($^O eq 'MSWin32') { + $dir_name = ($p_dir =~ m|\w:/?$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } + elsif ($^O eq 'VMS') { + if ($p_dir =~ m/[\]>]+$/) { + $dir_name = $p_dir; + $dir_name =~ s/([\]>]+)$/.$dir_rel$1/; + $dir_pref = $dir_name; + } + else { + $dir_name = "$p_dir/$dir_rel"; + $dir_pref = "$dir_name/"; + } + } + else { + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } + + if ( $nlink == -2 ) { + $name = $dir = $p_dir; # $File::Find::name / dir + $_ = $File::Find::current_dir; + $post_process->(); # End-of-directory processing + } + elsif ( $nlink < 0 ) { # must be finddepth, report dirname now + $name = $dir_name; + if ($Is_MacOS) { + if ($dir_rel eq ':') { # must be the top dir, where we started + $name =~ s|:$||; # $File::Find::name + $p_dir = "$p_dir:" unless ($p_dir =~ /:$/); + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $name : $dir_rel); # $_ + } + else { + if ( substr($name,-2) eq '/.' ) { + substr($name, length($name) == 2 ? -1 : -2) = ''; + } + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel ); + if ( substr($_,-2) eq '/.' ) { + substr($_, length($_) == 2 ? -1 : -2) = ''; + } + } + { $wanted_callback->() }; # protect against wild "next" + } + else { + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + last; + } + } + } +} + + +# API: +# $wanted +# $dir_loc : absolute location of a dir +# $p_dir : "parent directory" +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir_symlnk($$$) { + my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory + my @Stack; + my @filenames; + my $new_loc; + my $updir_loc = $dir_loc; # untainted parent directory + my $SE = []; + my $dir_name = $p_dir; + my $dir_pref; + my $loc_pref; + my $dir_rel = $File::Find::current_dir; + my $byd_flag; # flag for pending stack entry if $bydepth + my $tainted = 0; + my $ok = 1; + + if ($Is_MacOS) { + $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:"; + $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:"; + } else { + $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); + $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); + } + + local ($dir, $name, $fullname, $prune, *DIR); + + unless ($no_chdir) { + # untaint the topdir + if (( $untaint ) && (is_tainted($dir_loc) )) { + ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted + # once untainted, $updir_loc is pushed on the stack (as parent directory); + # hence, we don't need to untaint the parent directory every time we chdir + # to it later + unless (defined $updir_loc) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + return; + } + } + } + $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir); + unless ($ok) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + return; + } + } + + push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth; + + if ($Is_MacOS) { + $p_dir = $dir_pref; # ensure trailing ':' + } + + while (defined $SE) { + + unless ($bydepth) { + # change (back) to parent directory (always untainted) + unless ($no_chdir) { + unless (chdir $updir_loc) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + $dir= $p_dir; # $File::Find::dir + $name= $dir_name; # $File::Find::name + $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ + $fullname= $dir_loc; # $File::Find::fullname + # prune may happen here + $prune= 0; + lstat($_); # make sure file tests with '_' work + { $wanted_callback->() }; # protect against wild "next" + next if $prune; + } + + # change to that directory + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + $updir_loc = $dir_loc; + if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) { + # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir + ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; + unless (defined $updir_loc) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + next; + } + } + } + unless (chdir $updir_loc) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + + if ($Is_MacOS) { + $dir_name = "$dir_name:" unless ($dir_name =~ /:$/); + } + + $dir = $dir_name; # $File::Find::dir + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) { + warnings::warnif "Can't opendir($dir_loc): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + for my $FN (@filenames) { + if ($Is_VMS) { + # Big hammer here - Compensate for VMS trailing . and .dir + # No win situation until this is changed, but this + # will handle the majority of the cases with breaking the fewest. + + $FN =~ s/\.dir\z//i; + $FN =~ s#\.$## if ($FN ne '.'); + } + next if $FN =~ $File::Find::skip_pattern; + + # follow symbolic links / do an lstat + $new_loc = Follow_SymLink($loc_pref.$FN); + + # ignore if invalid symlink + unless (defined $new_loc) { + if (!defined -l _ && $dangling_symlinks) { + if (ref $dangling_symlinks eq 'CODE') { + $dangling_symlinks->($FN, $dir_pref); + } else { + warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; + } + } + + $fullname = undef; + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + { $wanted_callback->() }; + next; + } + + if (-d _) { + if ($Is_VMS) { + $FN =~ s/\.dir\z//i; + $FN =~ s#\.$## if ($FN ne '.'); + $new_loc =~ s/\.dir\z//i; + $new_loc =~ s#\.$## if ($new_loc ne '.'); + } + push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1]; + } + else { + $fullname = $new_loc; # $File::Find::fullname + $name = $dir_pref . $FN; # $File::Find::name + $_ = ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + + } + continue { + while (defined($SE = pop @Stack)) { + ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE; + if ($Is_MacOS) { + # $p_dir always has a trailing ':', except for the starting dir, + # where $dir_rel eq ':' + $dir_name = "$p_dir$dir_rel"; + $dir_pref = "$dir_name:"; + $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:"; + } + else { + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + $loc_pref = "$dir_loc/"; + } + if ( $byd_flag < 0 ) { # must be finddepth, report dirname now + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + $fullname = $dir_loc; # $File::Find::fullname + $name = $dir_name; # $File::Find::name + if ($Is_MacOS) { + if ($dir_rel eq ':') { # must be the top dir, where we started + $name =~ s|:$||; # $File::Find::name + $p_dir = "$p_dir:" unless ($p_dir =~ /:$/); + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $name : $dir_rel); # $_ + } + else { + if ( substr($name,-2) eq '/.' ) { + substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $dir_name : $dir_rel); # $_ + if ( substr($_,-2) eq '/.' ) { + substr($_, length($_) == 2 ? -1 : -2) = ''; + } + } + + lstat($_); # make sure file tests with '_' work + { $wanted_callback->() }; # protect against wild "next" + } + else { + push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth; + last; + } + } + } +} + + +sub wrap_wanted { + my $wanted = shift; + if ( ref($wanted) eq 'HASH' ) { + 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/chromium/third_party/cygwin/lib/perl5/5.10/File/Path.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Path.pm new file mode 100644 index 00000000000..19b5750b45b --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Path.pm @@ -0,0 +1,898 @@ +package File::Path; + +use 5.005_04; +use strict; + +use Cwd 'getcwd'; +use File::Basename (); +use File::Spec (); + +BEGIN { + if ($] < 5.006) { + # can't say 'opendir my $dh, $dirname' + # need to initialise $dh + eval "use Symbol"; + } +} + +use Exporter (); +use vars qw($VERSION @ISA @EXPORT); +$VERSION = '2.04'; +@ISA = qw(Exporter); +@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 = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); + +sub _carp { + require Carp; + goto &Carp::carp; +} + +sub _croak { + require Carp; + goto &Carp::croak; +} + +sub _error { + my $arg = shift; + my $message = shift; + my $object = shift; + + if ($arg->{error}) { + $object = '' unless defined $object; + push @{${$arg->{error}}}, {$object => "$message: $!"}; + } + else { + _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); + } +} + +sub mkpath { + my $old_style = ( + UNIVERSAL::isa($_[0],'ARRAY') + or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)) + or (@_ == 3 + and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1) + and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1) + ) + ) ? 1 : 0; + + my $arg; + my $paths; + + if ($old_style) { + my ($verbose, $mode); + ($paths, $verbose, $mode) = @_; + $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + $arg->{verbose} = defined $verbose ? $verbose : 0; + $arg->{mode} = defined $mode ? $mode : 0777; + } + else { + if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) { + $arg = pop @_; + exists $arg->{mask} and $arg->{mode} = delete $arg->{mask}; + $arg->{mode} = 0777 unless exists $arg->{mode}; + ${$arg->{error}} = [] if exists $arg->{error}; + } + else { + @{$arg}{qw(verbose mode)} = (0, 0777); + } + $paths = [@_]; + } + return _mkpath($arg, $paths); +} + +sub _mkpath { + my $arg = shift; + my $paths = shift; + + local($")=$Is_MacOS ? ":" : "/"; + my(@created,$path); + foreach $path (@$paths) { + next unless length($path); + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT + # Logic wants Unix paths, so go with the flow. + if ($Is_VMS) { + next if $path eq '/'; + $path = VMS::Filespec::unixify($path); + } + next if -d $path; + my $parent = File::Basename::dirname($path); + unless (-d $parent or $path eq $parent) { + push(@created,_mkpath($arg, [$parent])); + } + print "mkdir $path\n" if $arg->{verbose}; + if (mkdir($path,$arg->{mode})) { + push(@created, $path); + } + else { + my $save_bang = $!; + my ($e, $e1) = ($save_bang, $^E); + $e .= "; $e1" if $e ne $e1; + # allow for another process to have created it meanwhile + if (!-d $path) { + $! = $save_bang; + if ($arg->{error}) { + push @{${$arg->{error}}}, {$path => $e}; + } + else { + _croak("mkdir $path: $e"); + } + } + } + } + return @created; +} + +sub rmtree { + my $old_style = ( + UNIVERSAL::isa($_[0],'ARRAY') + or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)) + or (@_ == 3 + and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1) + and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1) + ) + ) ? 1 : 0; + + my $arg; + my $paths; + + if ($old_style) { + my ($verbose, $safe); + ($paths, $verbose, $safe) = @_; + $arg->{verbose} = defined $verbose ? $verbose : 0; + $arg->{safe} = defined $safe ? $safe : 0; + + if (defined($paths) and length($paths)) { + $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + } + else { + _carp ("No root path(s) specified\n"); + return 0; + } + } + else { + if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) { + $arg = pop @_; + ${$arg->{error}} = [] if exists $arg->{error}; + ${$arg->{result}} = [] if exists $arg->{result}; + } + else { + @{$arg}{qw(verbose safe)} = (0, 0); + } + $paths = [@_]; + } + + $arg->{prefix} = ''; + $arg->{depth} = 0; + + $arg->{cwd} = getcwd() or do { + _error($arg, "cannot fetch initial working directory"); + return 0; + }; + for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint + + @{$arg}{qw(device inode)} = (stat $arg->{cwd})[0,1] or do { + _error($arg, "cannot stat initial working directory", $arg->{cwd}); + return 0; + }; + + return _rmtree($arg, $paths); +} + +sub _rmtree { + my $arg = shift; + my $paths = shift; + + my $count = 0; + my $curdir = File::Spec->curdir(); + my $updir = File::Spec->updir(); + + my (@files, $root); + ROOT_DIR: + foreach $root (@$paths) { + if ($Is_MacOS) { + $root = ":$root" unless $root =~ /:/; + $root .= ":" unless $root =~ /:\z/; + } + else { + $root =~ s{/\z}{}; + } + + # since we chdir into each directory, it may not be obvious + # to figure out where we are if we generate a message about + # a file name. We therefore construct a semi-canonical + # filename, anchored from the directory being unlinked (as + # opposed to being truly canonical, anchored from the root (/). + + my $canon = $arg->{prefix} + ? File::Spec->catfile($arg->{prefix}, $root) + : $root + ; + + my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; + + if ( -d _ ) { + $root = VMS::Filespec::pathify($root) if $Is_VMS; + if (!chdir($root)) { + # see if we can escalate privileges to get in + # (e.g. funny protection mask such as -w- instead of rwx) + $perm &= 07777; + my $nperm = $perm | 0700; + if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { + _error($arg, "cannot make child directory read-write-exec", $canon); + next ROOT_DIR; + } + elsif (!chdir($root)) { + _error($arg, "cannot chdir to child", $canon); + next ROOT_DIR; + } + } + + my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do { + _error($arg, "cannot stat current working directory", $canon); + next ROOT_DIR; + }; + + ($ldev eq $device and $lino eq $inode) + or _croak("directory $canon changed before chdir, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting."); + + $perm &= 07777; # don't forget setuid, setgid, sticky bits + my $nperm = $perm | 0700; + + # notabene: 0700 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + + if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) { + _error($arg, "cannot make directory read+writeable", $canon); + $nperm = $perm; + } + + my $d; + $d = gensym() if $] < 5.006; + if (!opendir $d, $curdir) { + _error($arg, "cannot opendir", $canon); + @files = (); + } + else { + no strict 'refs'; + if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { + # Blindly untaint dir names if taint mode is + # active, or any perl < 5.006 + @files = map { /\A(.*)\z/s; $1 } readdir $d; + } + else { + @files = readdir $d; + } + closedir $d; + } + + if ($Is_VMS) { + # Deleting large numbers of files from VMS Files-11 + # filesystems is faster if done in reverse ASCIIbetical order. + # include '.' to '.;' from blead patch #31775 + @files = map {$_ eq '.' ? '.;' : $_} reverse @files; + ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//; + } + @files = grep {$_ ne $updir and $_ ne $curdir} @files; + + if (@files) { + # remove the contained files before the directory itself + my $narg = {%$arg}; + @{$narg}{qw(device inode cwd prefix depth)} + = ($device, $inode, $updir, $canon, $arg->{depth}+1); + $count += _rmtree($narg, \@files); + } + + # restore directory permissions of required now (in case the rmdir + # below fails), while we are still in the directory and may do so + # without a race via '.' + if ($nperm != $perm and not chmod($perm, $curdir)) { + _error($arg, "cannot reset chmod", $canon); + } + + # don't leave the client code in an unexpected directory + chdir($arg->{cwd}) + or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); + + # ensure that a chdir upwards didn't take us somewhere other + # than we expected (see CVE-2002-0435) + ($device, $inode) = (stat $curdir)[0,1] + or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); + + ($arg->{device} eq $device and $arg->{inode} eq $inode) + or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting."); + + if ($arg->{depth} or !$arg->{keep_root}) { + if ($arg->{safe} && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $arg->{verbose}; + next ROOT_DIR; + } + if (!chmod $perm | 0700, $root) { + if ($Force_Writeable) { + _error($arg, "cannot make directory writeable", $canon); + } + } + print "rmdir $root\n" if $arg->{verbose}; + if (rmdir $root) { + push @{${$arg->{result}}}, $root if $arg->{result}; + ++$count; + } + else { + _error($arg, "cannot remove directory", $canon); + if (!chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + ) { + _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + } + } + } + } + else { + # not a directory + $root = VMS::Filespec::vmsify("./$root") + if $Is_VMS + && !File::Spec->file_name_is_absolute($root) + && ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax + + if ($arg->{safe} && + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { + print "skipped $root\n" if $arg->{verbose}; + next ROOT_DIR; + } + + my $nperm = $perm & 07777 | 0600; + if ($nperm != $perm and not chmod $nperm, $root) { + if ($Force_Writeable) { + _error($arg, "cannot make file writeable", $canon); + } + } + print "unlink $canon\n" if $arg->{verbose}; + # delete all versions under VMS + for (;;) { + if (unlink $root) { + push @{${$arg->{result}}}, $root if $arg->{result}; + } + else { + _error($arg, "cannot unlink file", $canon); + $Force_Writeable and chmod($perm, $root) or + _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + + return $count; +} + +1; +__END__ + +=head1 NAME + +File::Path - Create or remove directory trees + +=head1 VERSION + +This document describes version 2.04 of File::Path, released +2007-11-13. + +=head1 SYNOPSIS + + use File::Path; + + # modern + mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} ); + + rmtree( + 'foo/bar/baz', '/zug/zwang', + { verbose => 1, error => \my $err_list } + ); + + # traditional + 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 +of arbitrary depth. Similarly, the C<rmtree> function provides a +convenient way to delete an entire directory subtree from the +filesystem, much like the Unix command C<rm -r>. + +Both functions may be called in one of two ways, the traditional, +compatible with code written since the dawn of time, and modern, +that offers a more flexible and readable idiom. New code should use +the modern interface. + +=head2 FUNCTIONS + +The modern way of calling C<mkpath> and C<rmtree> is with a list +of directories to create, or remove, respectively, followed by an +optional hash reference containing keys to control the +function's behaviour. + +=head3 C<mkpath> + +The following keys are recognised as parameters to C<mkpath>. +The function returns the list of files actually created during the +call. + + my @created = mkpath( + qw(/tmp /flub /home/nobody), + {verbose => 1, mode => 0750}, + ); + print "created $_\n" for @created; + +=over 4 + +=item mode + +The numeric permissions mode to apply to each created directory +(defaults to 0777), to be modified by the current C<umask>. If the +directory already exists (and thus does not need to be created), +the permissions will not be modified. + +C<mask> is recognised as an alias for this parameter. + +=item verbose + +If present, will cause C<mkpath> to print the name of each directory +as it is created. By default nothing is printed. + +=item error + +If present, will be interpreted as a reference to a list, and will +be used to store any errors that are encountered. See the ERROR +HANDLING section for more information. + +If this parameter is not used, certain error conditions may raise +a fatal error that will cause the program will halt, unless trapped +in an C<eval> block. + +=back + +=head3 C<rmtree> + +=over 4 + +=item verbose + +If present, will cause C<rmtree> to print the name of each file as +it is unlinked. By default nothing is printed. + +=item safe + +When set to a true value, will cause C<rmtree> to skip the files +for which the process lacks the required privileges needed to delete +files, such as delete privileges on VMS. In other words, the code +will make no attempt to alter file permissions. Thus, if the process +is interrupted, no filesystem object will be left in a more +permissive mode. + +=item keep_root + +When set to a true value, will cause all files and subdirectories +to be removed, except the initially specified directories. This comes +in handy when cleaning out an application's scratch directory. + + rmtree( '/tmp', {keep_root => 1} ); + +=item result + +If present, will be interpreted as a reference to a list, and will +be used to store the list of all files and directories unlinked +during the call. If nothing is unlinked, a reference to an empty +list is returned (rather than C<undef>). + + rmtree( '/tmp', {result => \my $list} ); + print "unlinked $_\n" for @$list; + +This is a useful alternative to the C<verbose> key. + +=item error + +If present, will be interpreted as a reference to a list, +and will be used to store any errors that are encountered. +See the ERROR HANDLING section for more information. + +Removing things is a much more dangerous proposition than +creating things. As such, there are certain conditions that +C<rmtree> may encounter that are so dangerous that the only +sane action left is to kill the program. + +Use C<error> to trap all that is reasonable (problems with +permissions and the like), and let it die if things get out +of hand. This is the safest course of action. + +=back + +=head2 TRADITIONAL INTERFACE + +The old interfaces of C<mkpath> and C<rmtree> take a reference to +a list of directories (to create or remove), followed by a series +of positional, numeric, modal parameters that control their behaviour. + +This design made it difficult to add additional functionality, as +well as posed the problem of what to do when the calling code only +needs to set the last parameter. Even though the code doesn't care +how the initial positional parameters are set, the programmer is +forced to learn what the defaults are, and specify them. + +Worse, if it turns out in the future that it would make more sense +to change the default behaviour of the first parameter (for example, +to avoid a security vulnerability), all existing code will remain +hard-wired to the wrong defaults. + +Finally, a series of numeric parameters are much less self-documenting +in terms of communicating to the reader what the code is doing. Named +parameters do not have this problem. + +In the traditional API, 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. In scalar context it returns +the number of directories 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: $@"; + } + +In the traditional API, 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. If you want to keep +the roots themselves, you must use the modern API. + +=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, directories and symlinks successfully +deleted. Symlinks are simply deleted and not followed. + +Note also that the occurrence of errors in C<rmtree> using the +traditional interface can be determined I<only> by trapping diagnostic +messages using C<$SIG{__WARN__}>; it is not apparent from the return +value. (The modern interface may use the C<error> parameter to +record any problems encountered). + +=head2 ERROR HANDLING + +If C<mkpath> or C<rmtree> encounter an error, a diagnostic message +will be printed to C<STDERR> via C<carp> (for non-fatal errors), +or via C<croak> (for fatal errors). + +If this behaviour is not desirable, the C<error> attribute may be +used to hold a reference to a variable, which will be used to store +the diagnostics. The result is a reference to a list of hash +references. For each hash reference, the key is the name of the +file, and the value is the error message (usually the contents of +C<$!>). An example usage looks like: + + rmpath( 'foo/bar', 'bar/rat', {error => \my $err} ); + for my $diag (@$err) { + my ($file, $message) = each %$diag; + print "problem unlinking $file: $message\n"; + } + +If no errors are encountered, C<$err> will point to an empty list +(thus there is no need to test for C<undef>). If a general error +is encountered (for instance, C<rmtree> attempts to remove a directory +tree that does not exist), the diagnostic key will be empty, only +the value will be set: + + rmpath( '/no/such/path', {error => \my $err} ); + for my $diag (@$err) { + my ($file, $message) = each %$diag; + if ($file eq '') { + print "general error: $message\n"; + } + } + +=head2 NOTES + +C<File::Path> blindly exports C<mkpath> and C<rmtree> into the +current namespace. These days, this is considered bad style, but +to change it now would break too much code. Nonetheless, you are +invited to specify what it is you are expecting to use: + + use File::Path 'rmtree'; + +=head3 HEURISTICS + +The functions detect (as far as possible) which way they are being +called and will act appropriately. It is important to remember that +the heuristic for detecting the old style is either the presence +of an array reference, or two or three parameters total and second +and third parameters are numeric. Hence... + + mkpath 486, 487, 488; + +... will not assume the modern style and create three directories, rather +it will create one directory verbosely, setting the permission to +0750 (488 being the decimal equivalent of octal 750). Here, old +style trumps new. It must, for backwards compatibility reasons. + +If you want to ensure there is absolutely no ambiguity about which +way the function will behave, make sure the first parameter is a +reference to a one-element list, to force the old style interpretation: + + mkpath [486], 487, 488; + +and get only one directory created. Or add a reference to an empty +parameter hash, to force the new style: + + mkpath 486, 487, 488, {}; + +... and hence create the three directories. If the empty hash +reference seems a little strange to your eyes, or you suspect a +subsequent programmer might I<helpfully> optimise it away, you +can add a parameter set to a default value: + + mkpath 486, 487, 488, {verbose => 0}; + +=head3 SECURITY CONSIDERATIONS + +There were race conditions 1.x implementations of File::Path's +C<rmtree> function (although sometimes patched depending on the OS +distribution or platform). The 2.0 version contains code to avoid the +problem mentioned in CVE-2002-0435. + +See the following pages for more information: + + http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 + http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html + http://www.debian.org/security/2005/dsa-696 + +Additionally, unless the C<safe> parameter is set (or the +third parameter in the traditional interface is TRUE), should a +C<rmtree> be interrupted, files that were originally in read-only +mode may now have their permissions set to a read-write (or "delete +OK") mode. + +=head1 DIAGNOSTICS + +FATAL errors will cause the program to halt (C<croak>), since the +problem is so severe that it would be dangerous to continue. (This +can always be trapped with C<eval>, but it's not a good idea. Under +the circumstances, dying is the best thing to do). + +SEVERE errors may be trapped using the modern interface. If the +they are not trapped, or the old interface is used, such an error +will cause the program will halt. + +All other errors may be trapped using the modern interface, otherwise +they will be C<carp>ed about. Program execution will not be halted. + +=over 4 + +=item mkdir [path]: [errmsg] (SEVERE) + +C<mkpath> was unable to create the path. Probably some sort of +permissions error at the point of departure, or insufficient resources +(such as free inodes on Unix). + +=item No root path(s) specified + +C<mkpath> was not given any paths to create. This message is only +emitted if the routine is called with the traditional interface. +The modern interface will remain silent if given nothing to do. + +=item No such file or directory + +On Windows, if C<mkpath> gives you this warning, it may mean that +you have exceeded your filesystem's maximum path length. + +=item cannot fetch initial working directory: [errmsg] + +C<rmtree> attempted to determine the initial directory by calling +C<Cwd::getcwd>, but the call failed for some reason. No attempt +will be made to delete anything. + +=item cannot stat initial working directory: [errmsg] + +C<rmtree> attempted to stat the initial directory (after having +successfully obtained its name via C<getcwd>), however, the call +failed for some reason. No attempt will be made to delete anything. + +=item cannot chdir to [dir]: [errmsg] + +C<rmtree> attempted to set the working directory in order to +begin deleting the objects therein, but was unsuccessful. This is +usually a permissions issue. The routine will continue to delete +other things, but this directory will be left intact. + +=item directory [dir] changed before chdir, expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL) + +C<rmtree> recorded the device and inode of a directory, and then +moved into it. It then performed a C<stat> on the current directory +and detected that the device and inode were no longer the same. As +this is at the heart of the race condition problem, the program +will die at this point. + +=item cannot make directory [dir] read+writeable: [errmsg] + +C<rmtree> attempted to change the permissions on the current directory +to ensure that subsequent unlinkings would not run into problems, +but was unable to do so. The permissions remain as they were, and +the program will carry on, doing the best it can. + +=item cannot read [dir]: [errmsg] + +C<rmtree> tried to read the contents of the directory in order +to acquire the names of the directory entries to be unlinked, but +was unsuccessful. This is usually a permissions issue. The +program will continue, but the files in this directory will remain +after the call. + +=item cannot reset chmod [dir]: [errmsg] + +C<rmtree>, after having deleted everything in a directory, attempted +to restore its permissions to the original state but failed. The +directory may wind up being left behind. + +=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL) + +C<rmtree>, after having deleted everything and restored the permissions +of a directory, was unable to chdir back to the parent. This is usually +a sign that something evil this way comes. + +=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) + +C<rmtree> was unable to stat the parent directory after have returned +from the child. Since there is no way of knowing if we returned to +where we think we should be (by comparing device and inode) the only +way out is to C<croak>. + +=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL) + +When C<rmtree> returned from deleting files in a child directory, a +check revealed that the parent directory it returned to wasn't the one +it started out from. This is considered a sign of malicious activity. + +=item cannot make directory [dir] writeable: [errmsg] + +Just before removing a directory (after having successfully removed +everything it contained), C<rmtree> attempted to set the permissions +on the directory to ensure it could be removed and failed. Program +execution continues, but the directory may possibly not be deleted. + +=item cannot remove directory [dir]: [errmsg] + +C<rmtree> attempted to remove a directory, but failed. This may because +some objects that were unable to be removed remain in the directory, or +a permissions issue. The directory will be left behind. + +=item cannot restore permissions of [dir] to [0nnn]: [errmsg] + +After having failed to remove a directory, C<rmtree> was unable to +restore its permissions from a permissive state back to a possibly +more restrictive setting. (Permissions given in octal). + +=item cannot make file [file] writeable: [errmsg] + +C<rmtree> attempted to force the permissions of a file to ensure it +could be deleted, but failed to do so. It will, however, still attempt +to unlink the file. + +=item cannot unlink file [file]: [errmsg] + +C<rmtree> failed to remove a file. Probably a permissions issue. + +=item cannot restore permissions of [file] to [0nnn]: [errmsg] + +After having failed to remove a file, C<rmtree> was also unable +to restore the permissions on the file to a possibly less permissive +setting. (Permissions given in octal). + +=back + +=head1 SEE ALSO + +=over 4 + +=item * + +L<File::Remove> + +Allows files and directories to be moved to the Trashcan/Recycle +Bin (where they may later be restored if necessary) if the operating +system supports such functionality. This feature may one day be +made available directly in C<File::Path>. + +=item * + +L<File::Find::Rule> + +When removing directory trees, if you want to examine each file to +decide whether to delete it (and possibly leaving large swathes +alone), F<File::Find::Rule> offers a convenient and flexible approach +to examining directory trees. + +=back + +=head1 BUGS + +Please report all bugs on the RT queue: + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> + +=head1 ACKNOWLEDGEMENTS + +Paul Szabo identified the race condition originally, and Brendan +O'Dea wrote an implementation for Debian that addressed the problem. +That code was used as a basis for the current code. Their efforts +are greatly appreciated. + +=head1 AUTHORS + +Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey +<F<bailey@newman.upenn.edu>>. Currently maintained by David Landgren +<F<david@landgren.net>>. + +=head1 COPYRIGHT + +This module is copyright (C) Charles Bailey, Tim Bunce and +David Landgren 1995-2007. All rights reserved. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec.pm new file mode 100644 index 00000000000..b7b7b52cc7c --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec.pm @@ -0,0 +1,339 @@ +package File::Spec; + +use strict; +use vars qw(@ISA $VERSION); + +$VERSION = '3.2702'; +$VERSION = eval $VERSION; + +my %module = (MacOS => 'Mac', + MSWin32 => 'Win32', + os2 => 'OS2', + VMS => 'VMS', + epoc => 'Epoc', + NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. + dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. + cygwin => 'Cygwin'); + + +my $module = $module{$^O} || 'Unix'; + +require "File/Spec/$module.pm"; +@ISA = ("File::Spec::$module"); + +1; + +__END__ + +=head1 NAME + +File::Spec - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec; + + $x=File::Spec->catfile('a', 'b', 'c'); + +which returns 'a/b/c' under Unix. Or: + + use File::Spec::Functions; + + $x = catfile('a', 'b', 'c'); + +=head1 DESCRIPTION + +This module is designed to support operations commonly performed on file +specifications (usually called "file names", but not to be confused with the +contents of a file, or Perl's file handles), such as concatenating several +directory and file names into a single path, or determining whether a path +is rooted. It is based on code directly taken from MakeMaker 5.17, code +written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya +Zakharevich, Paul Schinder, and others. + +Since these functions are different for most operating systems, each set of +OS specific routines is available in a separate module, including: + + File::Spec::Unix + File::Spec::Mac + File::Spec::OS2 + File::Spec::Win32 + File::Spec::VMS + +The module appropriate for the current OS is automatically loaded by +File::Spec. Since some modules (like VMS) make use of facilities available +only under that OS, it may not be possible to load all modules under all +operating systems. + +Since File::Spec is object oriented, subroutines should not be called directly, +as in: + + File::Spec::catfile('a','b'); + +but rather as class methods: + + File::Spec->catfile('a','b'); + +For simple uses, L<File::Spec::Functions> provides convenient functional +forms of these methods. + +=head1 METHODS + +=over 2 + +=item canonpath +X<canonpath> + +No physical check on the filesystem, but a logical cleanup of a +path. + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=item catdir +X<catdir> + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS/2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + + $path = File::Spec->catdir( @directories ); + +=item catfile +X<catfile> + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + + $path = File::Spec->catfile( @directories, $filename ); + +=item curdir +X<curdir> + +Returns a string representation of the current directory. + + $curdir = File::Spec->curdir(); + +=item devnull +X<devnull> + +Returns a string representation of the null device. + + $devnull = File::Spec->devnull(); + +=item rootdir +X<rootdir> + +Returns a string representation of the root directory. + + $rootdir = File::Spec->rootdir(); + +=item tmpdir +X<tmpdir> + +Returns a string representation of the first writable directory from a +list of possible temporary directories. Returns the current directory +if no writable temporary directories are found. The list of directories +checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> +(unless taint is on) and F</tmp>. + + $tmpdir = File::Spec->tmpdir(); + +=item updir +X<updir> + +Returns a string representation of the parent directory. + + $updir = File::Spec->updir(); + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + + @paths = File::Spec->no_upwards( @paths ); + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +case is not or is significant when comparing file specifications. +Cygwin and Win32 accept an optional mount point resp. drive ("C:") argument. +On all other platforms the optional mount point argument is ignored. +TODO: case-insensitive FAT, NFS, Samba mounts on Unix. + + $is_case_tolerant = File::Spec->case_tolerant( $mount_point ); + +=item file_name_is_absolute + +Takes as its argument a path, and returns true if it is an absolute path. + + $is_absolute = File::Spec->file_name_is_absolute( $path ); + +This does not consult the local filesystem on Unix, Win32, OS/2, or +Mac OS (Classic). It does consult the working environment for VMS +(see L<File::Spec::VMS/file_name_is_absolute>). + +=item path +X<path> + +Takes no argument. Returns the environment variable C<PATH> (or the local +platform's equivalent) as a list. + + @PATH = File::Spec->path(); + +=item join +X<join, path> + +join is the same as catfile. + +=item splitpath +X<splitpath> X<split, path> + +Splits a path in to volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless C<$no_file> is true or a +trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=item splitdir +X<splitdir> X<split, dir> + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +C<$directories> must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSes. + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is +inserted if need be. On other OSes, C<$volume> is significant. + + $full_path = File::Spec->catpath( $volume, $directory, $file ); + +=item abs2rel +X<abs2rel> X<absolute, path> X<relative, path> + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<Cwd::cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<Cwd::cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=item rel2abs() +X<rel2abs> X<absolute, path> X<relative, path> + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<Cwd::cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=back + +For further information, please see L<File::Spec::Unix>, +L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or +L<File::Spec::VMS>. + +=head1 SEE ALSO + +L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, +L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, +L<ExtUtils::MakeMaker> + +=head1 AUTHOR + +Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< <kjahds@kjahds.com> >>, +Andy Dougherty C<< <doughera@lafayette.edu> >>, +Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>, +Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>. +VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>. +OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>. +Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and +Thomas Wegner C<< <wegner_thomas@yahoo.com> >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>, +modified by Barrie Slaymaker C<< <barries@slaysys.com> >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Cygwin.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Cygwin.pm new file mode 100644 index 00000000000..8661b55c78f --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Cygwin.pm @@ -0,0 +1,152 @@ +package File::Spec::Cygwin; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.2702'; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Cygwin - methods for Cygwin file specs + +=head1 SYNOPSIS + + require File::Spec::Cygwin; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +This module is still in beta. Cygwin-knowledgeable folks are invited +to offer patches and suggestions. + +=cut + +=pod + +=over 4 + +=item canonpath + +Any C<\> (backslashes) are converted to C</> (forward slashes), +and then File::Spec::Unix canonpath() is called on the result. + +=cut + +sub canonpath { + my($self,$path) = @_; + return unless defined $path; + + $path =~ s|\\|/|g; + + # Handle network path names beginning with double slash + my $node = ''; + if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) { + $node = $1; + } + return $node . $self->SUPER::canonpath($path); +} + +sub catdir { + my $self = shift; + return unless @_; + + # Don't create something that looks like a //network/path + if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { + shift; + return $self->SUPER::catdir('', @_); + } + + $self->SUPER::catdir(@_); +} + +=pod + +=item file_name_is_absolute + +True is returned if the file name begins with C<drive_letter:>, +and if not, File::Spec::Unix file_name_is_absolute() is called. + +=cut + + +sub file_name_is_absolute { + my ($self,$file) = @_; + return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test + return $self->SUPER::file_name_is_absolute($file); +} + +=item tmpdir (override) + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + /tmp + $ENV{'TMP'} + $ENV{'TEMP'} + C:/temp + +Since Perl 5.8.0, if running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' ); +} + +=item case_tolerant + +Override Unix. Cygwin case-tolerance depends on managed mount settings and +as with MSWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsystem. +See http://cygwin.com/ml/cygwin/2007-07/msg00891.html +Accepts an optional drive-mount argument. +Default: 1 + +=cut + +my %tmp_case_tolerant; +sub case_tolerant () { + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + + my $drive = shift; + $drive = shift if $drive =~ /^File::Spec/; + my $windrive; + if (! $drive) { + $windrive = $ENV{SYSTEMDRIVE} || substr($ENV{WINDIR}, 0, 2); + $drive = Cygwin::win_to_posix_path($windrive."\\"); + } + return $tmp_case_tolerant{$drive} if exists $tmp_case_tolerant{$drive}; + my $mntopts = Cygwin::mount_flags($drive); + if ($mntopts and ($mntopts =~ /,managed/)) { + $tmp_case_tolerant{$drive} = 0; + return 0; + } + require File::Spec::Win32; + $windrive = substr(Cygwin::posix_to_win_path($drive),0,2); + $tmp_case_tolerant{$drive} = File::Spec::Win32::case_tolerant($windrive); + return $tmp_case_tolerant{$drive}; +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Epoc.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Epoc.pm new file mode 100644 index 00000000000..1e0ad188bd2 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Epoc.pm @@ -0,0 +1,78 @@ +package File::Spec::Epoc; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = '3.2701'; + +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Epoc - methods for Epoc file specs + +=head1 SYNOPSIS + + require File::Spec::Epoc; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This package is still work in progress ;-) + +=cut + +sub case_tolerant { + return 1; +} + +=pod + +=over 4 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=back + +=cut + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + $path =~ s|/+|/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + return $path; +} + +=pod + +=head1 AUTHOR + +o.flebbe@gmx.de + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Functions.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Functions.pm new file mode 100644 index 00000000000..ab335e16a05 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Functions.pm @@ -0,0 +1,109 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '3.2701'; + +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/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Mac.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Mac.pm new file mode 100644 index 00000000000..97fa6766263 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Mac.pm @@ -0,0 +1,780 @@ +package File::Spec::Mac; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.2701'; + +@ISA = qw(File::Spec::Unix); + +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::Files }; +} + +sub case_tolerant { 1 } + + +=head1 NAME + +File::Spec::Mac - File::Spec for Mac OS (Classic) + +=head1 SYNOPSIS + + require File::Spec::Mac; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item canonpath + +On Mac OS, there's nothing to be done. Returns what it's given. + +=cut + +sub canonpath { + my ($self,$path) = @_; + return $path; +} + +=item catdir() + +Concatenate two or more directory names to form a path separated by colons +(":") ending with a directory. Resulting paths are B<relative> by default, +but can be forced to be absolute (but avoid this, see below). Automatically +puts a trailing ":" on the end of the complete path, because that's what's +done in MacPerl's environment and helps to distinguish a file path from a +directory path. + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting +path is relative by default and I<not> absolute. This decision was made due +to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths +on all other operating systems, it will now also follow this convention on Mac +OS. Note that this may break some existing scripts. + +The intended purpose of this routine is to concatenate I<directory names>. +But because of the nature of Macintosh paths, some additional possibilities +are allowed to make using this routine give reasonable results for some +common situations. In other words, you are also allowed to concatenate +I<paths> instead of directory names (strictly speaking, a string like ":a" +is a path, but not a name, since it contains a punctuation character ":"). + +So, beside calls like + + catdir("a") = ":a:" + catdir("a","b") = ":a:b:" + catdir() = "" (special case) + +calls like the following + + catdir(":a:") = ":a:" + catdir(":a","b") = ":a:b:" + catdir(":a:","b") = ":a:b:" + catdir(":a:",":b:") = ":a:b:" + catdir(":") = ":" + +are allowed. + +Here are the rules that are used in C<catdir()>; note that we try to be as +compatible as possible to Unix: + +=over 2 + +=item 1. + +The resulting path is relative by default, i.e. the resulting path will have a +leading colon. + +=item 2. + +A trailing colon is added automatically to the resulting path, to denote a +directory. + +=item 3. + +Generally, each argument has one leading ":" and one trailing ":" +removed (if any). They are then joined together by a ":". Special +treatment applies for arguments denoting updir paths like "::lib:", +see (4), or arguments consisting solely of colons ("colon paths"), +see (5). + +=item 4. + +When an updir path like ":::lib::" is passed as argument, the number +of directories to climb up is handled correctly, not removing leading +or trailing colons when necessary. E.g. + + catdir(":::a","::b","c") = ":::a::b:c:" + catdir(":::a::","::b","c") = ":::a:::b:c:" + +=item 5. + +Adding a colon ":" or empty string "" to a path at I<any> position +doesn't alter the path, i.e. these arguments are ignored. (When a "" +is passed as the first argument, it has a special meaning, see +(6)). This way, a colon ":" is handled like a "." (curdir) on Unix, +while an empty string "" is generally ignored (see +C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".." +(updir), and a ":::" is handled like a "../.." etc. E.g. + + catdir("a",":",":","b") = ":a:b:" + catdir("a",":","::",":b") = ":a::b:" + +=item 6. + +If the first argument is an empty string "" or is a volume name, i.e. matches +the pattern /^[^:]+:/, the resulting path is B<absolute>. + +=item 7. + +Passing an empty string "" as the first argument to C<catdir()> is +like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e. + + catdir("","a","b") is the same as + + catdir(rootdir(),"a","b"). + +This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and +C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup +volume, which is the closest in concept to Unix' "/". This should help +to run existing scripts originally written for Unix. + +=item 8. + +For absolute paths, some cleanup is done, to ensure that the volume +name isn't immediately followed by updirs. This is invalid, because +this would go beyond "root". Generally, these cases are handled like +their Unix counterparts: + + Unix: + Unix->catdir("","") = "/" + Unix->catdir("",".") = "/" + Unix->catdir("","..") = "/" # can't go beyond root + Unix->catdir("",".","..","..","a") = "/a" + Mac: + Mac->catdir("","") = rootdir() # (e.g. "HD:") + Mac->catdir("",":") = rootdir() + Mac->catdir("","::") = rootdir() # can't go beyond root + Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:") + +However, this approach is limited to the first arguments following +"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more +arguments that move up the directory tree, an invalid path going +beyond root can be created. + +=back + +As you've seen, you can force C<catdir()> to create an absolute path +by passing either an empty string or a path that begins with a volume +name as the first argument. However, you are strongly encouraged not +to do so, since this is done only for backward compatibility. Newer +versions of File::Spec come with a method called C<catpath()> (see +below), that is designed to offer a portable solution for the creation +of absolute paths. It takes volume, directory and file portions and +returns an entire path. While C<catdir()> is still suitable for the +concatenation of I<directory names>, you are encouraged to use +C<catpath()> to concatenate I<volume names> and I<directory +paths>. E.g. + + $dir = File::Spec->catdir("tmp","sources"); + $abs_path = File::Spec->catpath("MacintoshHD:", $dir,""); + +yields + + "MacintoshHD:tmp:sources:" . + +=cut + +sub catdir { + my $self = shift; + return '' unless @_; + my @args = @_; + my $first_arg; + my $relative; + + # take care of the first argument + + if ($args[0] eq '') { # absolute path, rootdir + shift @args; + $relative = 0; + $first_arg = $self->rootdir; + + } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name + $relative = 0; + $first_arg = shift @args; + # add a trailing ':' if need be (may be it's a path like HD:dir) + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + + } else { # relative path + $relative = 1; + if ( $args[0] =~ /^::+\Z(?!\n)/ ) { + # updir colon path ('::', ':::' etc.), don't shift + $first_arg = ':'; + } elsif ($args[0] eq ':') { + $first_arg = shift @args; + } else { + # add a trailing ':' if need be + $first_arg = shift @args; + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + } + } + + # For all other arguments, + # (a) ignore arguments that equal ':' or '', + # (b) handle updir paths specially: + # '::' -> concatenate '::' + # '::' . '::' -> concatenate ':::' etc. + # (c) add a trailing ':' if need be + + my $result = $first_arg; + while (@args) { + my $arg = shift @args; + unless (($arg eq '') || ($arg eq ':')) { + if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::' + my $updir_count = length($arg) - 1; + while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path + $arg = shift @args; + $updir_count += (length($arg) - 1); + } + $arg = (':' x $updir_count); + } else { + $arg =~ s/^://s; # remove a leading ':' if any + $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':' + } + $result .= $arg; + }#unless + } + + if ( ($relative) && ($result !~ /^:/) ) { + # add a leading colon if need be + $result = ":$result"; + } + + unless ($relative) { + # remove updirs immediately following the volume name + $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/; + } + + return $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename. Resulting paths are B<relative> +by default, but can be forced to be absolute (but avoid this). + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the +resulting path is relative by default and I<not> absolute. This +decision was made due to portability reasons. Since +C<File::Spec-E<gt>catfile()> returns relative paths on all other +operating systems, it will now also follow this convention on Mac OS. +Note that this may break some existing scripts. + +The last argument is always considered to be the file portion. Since +C<catfile()> uses C<catdir()> (see above) for the concatenation of the +directory portions (if any), the following with regard to relative and +absolute paths is true: + + catfile("") = "" + catfile("file") = "file" + +but + + catfile("","") = rootdir() # (e.g. "HD:") + catfile("","file") = rootdir() . file # (e.g. "HD:file") + catfile("HD:","file") = "HD:file" + +This means that C<catdir()> is called only when there are two or more +arguments, as one might expect. + +Note that the leading ":" is removed from the filename, so that + + catfile("a","b","file") = ":a:b:file" and + + catfile("a","b",":file") = ":a:b:file" + +give the same answer. + +To concatenate I<volume names>, I<directory paths> and I<filenames>, +you are encouraged to use C<catpath()> (see below). + +=cut + +sub catfile { + my $self = shift; + return '' unless @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $file =~ s/^://s; + return $dir.$file; +} + +=item curdir + +Returns a string representing the current directory. On Mac OS, this is ":". + +=cut + +sub curdir { + return ":"; +} + +=item devnull + +Returns a string representing the null device. On Mac OS, this is "Dev:Null". + +=cut + +sub devnull { + return "Dev:Null"; +} + +=item rootdir + +Returns a string representing the root directory. Under MacPerl, +returns the name of the startup volume, since that's the closest in +concept, although other volumes aren't rooted there. The name has a +trailing ":", because that's the correct specification for a volume +name on Mac OS. + +If Mac::Files could not be loaded, the empty string is returned. + +=cut + +sub rootdir { +# +# There's no real root directory on Mac OS. The name of the startup +# volume is returned, since that's the closest in concept. +# + return '' unless $macfiles; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*\Z(?!\n)/:/s; + return $system; +} + +=item tmpdir + +Returns the contents of $ENV{TMPDIR}, if that directory exits or the +current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will +contain a path like "MacintoshHD:Temporary Items:", which is a hidden +directory on your startup volume. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} ); +} + +=item updir + +Returns a string representing the parent directory. On Mac OS, this is "::". + +=cut + +sub updir { + return "::"; +} + +=item file_name_is_absolute + +Takes as argument a path and returns true, if it is an absolute path. +If the path has a leading ":", it's a relative path. Otherwise, it's an +absolute path, unless the path doesn't contain any colons, i.e. it's a name +like "a". In this particular case, the path is considered to be relative +(i.e. it is considered to be a filename). Use ":" in the appropriate place +in the path if you want to distinguish unambiguously. As a special case, +the filename '' is always considered to be absolute. Note that with version +1.2 of File::Spec::Mac, this does no longer consult the local filesystem. + +E.g. + + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) + + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + if ($file =~ /:/) { + return (! ($file =~ m/^:/s) ); + } elsif ( $file eq '' ) { + return 1 ; + } else { + return 0; # i.e. a file like "a" + } +} + +=item path + +Returns the null list for the MacPerl application, since the concept is +usually meaningless under Mac OS. But if you're using the MacPerl tool under +MPW, it gives back $ENV{Commands} suitably split, as is done in +:lib:ExtUtils:MM_Mac.pm. + +=cut + +sub path { +# +# The concept is meaningless under the MacPerl application. +# Under MPW, it has a meaning. +# + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. + +On Mac OS, assumes that the last part of the path is a filename unless +$no_file is true or a trailing separator ":" is present. + +The volume portion is always returned with a trailing ":". The directory portion +is always returned with a leading (to denote a relative path) and a trailing ":" +(to denote a directory). The file portion is always returned I<without> a leading ":". +Empty portions are returned as empty string ''. + +The results can be passed to C<catpath()> to get back a path equivalent to +(usually identical to) the original path. + + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file); + + if ( $nofile ) { + ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s; + } + else { + $path =~ + m|^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + |xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + $volume = '' unless defined($volume); + $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir" + if ($directory) { + # Make sure non-empty directories begin and end in ':' + $directory .= ':' unless (substr($directory,-1) eq ':'); + $directory = ":$directory" unless (substr($directory,0,1) eq ':'); + } else { + $directory = ''; + } + $file = '' unless defined($file); + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of C<catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories should be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. Consider using C<splitpath()> otherwise. + +Unlike just splitting the directories on the separator, empty directory names +(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing +colon to distinguish a directory path from a file path, a single trailing colon +will be ignored, i.e. there's no empty directory name after it. + +Hence, on Mac OS, both + + File::Spec->splitdir( ":a:b::c:" ); and + File::Spec->splitdir( ":a:b::c" ); + +yield: + + ( "a", "b", "::", "c") + +while + + File::Spec->splitdir( ":a:b::c::" ); + +yields: + + ( "a", "b", "::", "c", "::") + + +=cut + +sub splitdir { + my ($self, $path) = @_; + my @result = (); + my ($head, $sep, $tail, $volume, $directories); + + return @result if ( (!defined($path)) || ($path eq '') ); + return (':') if ($path eq ':'); + + ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; + + # deprecated, but handle it correctly + if ($volume) { + push (@result, $volume); + $sep .= ':'; + } + + while ($sep || $directories) { + if (length($sep) > 1) { + my $updir_count = length($sep) - 1; + for (my $i=0; $i<$updir_count; $i++) { + # push '::' updir_count times; + # simulate Unix '..' updirs + push (@result, '::'); + } + } + $sep = ''; + if ($directories) { + ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s; + push (@result, $head); + $directories = $tail; + } + } + return @result; +} + + +=item catpath + + $path = File::Spec->catpath($volume,$directory,$file); + +Takes volume, directory and file portions and returns an entire path. On Mac OS, +$volume, $directory and $file are concatenated. A ':' is inserted if need be. You +may pass an empty string for each portion. If all portions are empty, the empty +string is returned. If $volume is empty, the result will be a relative path, +beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any) +is removed form $file and the remainder is returned. If $file is empty, the +resulting path will have a trailing ':'. + + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( (! $volume) && (! $directory) ) { + $file =~ s/^:// if $file; + return $file ; + } + + # We look for a volume in $volume, then in $directory, but not both + + my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1); + + $volume = $dir_volume unless length $volume; + my $path = $volume; # may be '' + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + + if ($directory) { + $directory = $dir_dirs if $volume; + $directory =~ s/^://; # remove leading ':' if any + $path .= $directory; + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + } + + if ($file) { + $file =~ s/^://; # remove leading ':' if any + $path .= $file; + } + + return $path; +} + +=item abs2rel + +Takes a destination path and an optional base path and returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then the current working directory is used. +If $base is relative, then it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +If $path and $base appear to be on two different volumes, we will not +attempt to resolve the two paths, and we will instead simply return +$path. Note that previous versions of this module ignored the volume +of $base, which resulted in garbage results part of the time. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is relative, it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +Based on code written by Shigio Yamaguchi. + + +=cut + +# maybe this should be done in canonpath() ? +sub _resolve_updirs { + my $path = shift @_; + my $proceed; + + # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file" + do { + $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + + return $path; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + $base = _resolve_updirs( $base ); # resolve updirs in $base + } + else { + $base = _resolve_updirs( $base ); + } + + # Split up paths - ignore $base's file + my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path ); + my ( $base_vol, $base_dirs ) = $self->splitpath( $base ); + + return $path unless lc( $path_vol ) eq lc( $base_vol ); + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_dirs ); + my @basechunks = $self->splitdir( $base_dirs ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @pathchunks now has the directories to descend in to. + # ensure relative path, even if @pathchunks is empty + $path_dirs = $self->catdir( ':', @pathchunks ); + + # @basechunks now contains the number of directories to climb out of. + $base_dirs = (':' x @basechunks) . ':' ; + + return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path: + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then $base is set to the current working +directory. If $base is relative, then it is converted to absolute form +using C<rel2abs()>. This means that it is taken to be relative to the +current working directory. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is already absolute, it is returned and $base is ignored. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base) = @_; + + if ( ! $self->file_name_is_absolute($path) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute($base) ) { + $base = $self->rel2abs($base) ; + } + + # Split up paths + + # igonore $path's volume + my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; + + # ignore $base's file part + my ( $base_vol, $base_dirs ) = $self->splitpath($base) ; + + # Glom them together + $path_dirs = ':' if ($path_dirs eq ''); + $base_dirs =~ s/:$//; # remove trailing ':', if any + $base_dirs = $base_dirs . $path_dirs; + + $path = $self->catpath( $base_vol, $base_dirs, $path_file ); + } + return $path; +} + + +=back + +=head1 AUTHORS + +See the authors list in I<File::Spec>. Mac OS support by Paul Schinder +<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/OS2.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/OS2.pm new file mode 100644 index 00000000000..48d09fa2f9c --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/OS2.pm @@ -0,0 +1,273 @@ +package File::Spec::OS2; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.2701'; + +@ISA = qw(File::Spec::Unix); + +sub devnull { + return "/dev/nul"; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); +} + +sub path { + my $path = $ENV{PATH}; + $path =~ s:\\:/:g; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +sub _cwd { + # In OS/2 the "require Cwd" is unnecessary bloat. + return Cwd::sys_cwd(); +} + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy + $tmpdir = $_[0]->_tmpdir( @d, '/tmp', '/' ); +} + +sub catdir { + my $self = shift; + my @args = @_; + foreach (@args) { + tr[\\][/]; + # append a backslash to each argument unless it has one there + $_ .= "/" unless m{/$}; + } + return $self->canonpath(join('', @args)); +} + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + $path =~ s/^([a-z]:)/\l$1/s; + $path =~ s|\\|/|g; + $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx + $path =~ s|/\Z(?!\n)|| + unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx + $path =~ s{^/\.\.$}{/}; # /.. -> / + 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx + return $path; +} + + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +sub splitdir { + my ($self,$directories) = @_ ; + split m|[\\/]|, $directories, -1; +} + + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '/' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; + my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; + return $path unless $path_volume eq $base_volume; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '/', @pathchunks ); + $base_directories = CORE::join( '/', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories/$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + return $self->canonpath( + $self->catpath( "", $path_directories, $path_file ) + ) ; +} + + +sub rel2abs { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +1; +__END__ + +=head1 NAME + +File::Spec::OS2 - methods for OS/2 file specs + +=head1 SYNOPSIS + + require File::Spec::OS2; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +Amongst the changes made for OS/2 are... + +=over 4 + +=item tmpdir + +Modifies the list of places temp directory information is looked for. + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / + +=item splitpath + +Volumes can be drive letters or UNC sharenames (\\server\share). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Unix.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Unix.pm new file mode 100644 index 00000000000..33033b372ab --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Unix.pm @@ -0,0 +1,518 @@ +package File::Spec::Unix; + +use strict; +use vars qw($VERSION); + +$VERSION = '3.2702'; + +=head1 NAME + +File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules + +=head1 SYNOPSIS + + require File::Spec::Unix; # Done automatically by File::Spec + +=head1 DESCRIPTION + +Methods for manipulating file specifications. Other File::Spec +modules, such as File::Spec::Mac, inherit from File::Spec::Unix and +override specific methods. + +=head1 METHODS + +=over 2 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminates successive slashes and successive "/.". + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=cut + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + # Handle POSIX-style node names beginning with double slash (qnx, nto) + # (POSIX says: "a pathname that begins with two successive slashes + # may be interpreted in an implementation-defined manner, although + # more than two leading slashes shall be treated as a single slash.") + my $node = ''; + my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; + if ( $double_slashes_special && $path =~ s{^(//[^/]+)(?:/|\z)}{/}s ) { + $node = $1; + } + # This used to be + # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); + # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail + # (Mainly because trailing "" directories didn't get stripped). + # Why would cygwin avoid collapsing multiple slashes into one? --jhi + $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx + $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx + $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return "$node$path"; +} + +=item catdir() + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + +=cut + +sub catdir { + my $self = shift; + + $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift; + my $file = $self->canonpath(pop @_); + return $file unless @_; + my $dir = $self->catdir(@_); + $dir .= "/" unless substr($dir,-1) eq "/"; + return $dir.$file; +} + +=item curdir + +Returns a string representation of the current directory. "." on UNIX. + +=cut + +sub curdir () { '.' } + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull () { '/dev/null' } + +=item rootdir + +Returns a string representation of the root directory. "/" on UNIX. + +=cut + +sub rootdir () { '/' } + +=item tmpdir + +Returns a string representation of the first writable directory from +the following list or the current directory if none from the list are +writable: + + $ENV{TMPDIR} + /tmp + +Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +my $tmpdir; +sub _tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + my @dirlist = @_; + { + no strict 'refs'; + if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + } + foreach (@dirlist) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = $self->curdir unless defined $tmpdir; + $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + return $tmpdir; +} + +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); +} + +=item updir + +Returns a string representation of the parent directory. ".." on UNIX. + +=cut + +sub updir () { '..' } + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + +=cut + +sub no_upwards { + my $self = shift; + return grep(!/^\.{1,2}\z/s, @_); +} + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +is not or is significant when comparing file specifications. +Todo: Add mount point argument to support case-tolerant NFS and samba shares. + +=cut + +sub case_tolerant () { 0 } + +=item file_name_is_absolute + +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, OS/2 or Mac +OS (Classic). It does consult the working environment for VMS (see +L<File::Spec::VMS/file_name_is_absolute>). + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. + +=cut + +sub path { + return () unless exists $ENV{PATH}; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +=item join + +join is the same as catfile. + +=cut + +sub join { + my $self = shift; + return $self->catfile(@_); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless $no_file is true or a +trailing separator or /. or /.. is present. On Unix this means that $no_file +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSs. + +On Unix, + + File::Spec->splitdir( "/a/b//c/" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + return split m|/|, $_[1], -1; # Preserve trailing fields +} + + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and directory and file are concatenated. A '/' is +inserted if needed (though if the directory portion doesn't start with +'/' it is not added). On other OSs, $volume is significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; +} + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + ($path, $base) = map $self->canonpath($_), $path, $base; + + if (grep $self->file_name_is_absolute($_), $path, $base) { + ($path, $base) = map $self->rel2abs($_), $path, $base; + } + else { + # save a couple of cwd()s if both paths are relative + ($path, $base) = map $self->catdir('/', $_), $path, $base; + } + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + my $path_directories = ($self->splitpath($path, 1))[1]; + my $base_directories = ($self->splitpath($base, 1))[1]; + + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + if ($base_directories eq $self->rootdir) { + shift @pathchunks; + return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); + } + + while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { + shift @pathchunks ; + shift @basechunks ; + } + return $self->curdir unless @pathchunks || @basechunks; + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. + my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} + +sub _same { + $_[1] eq $_[2]; +} + +=item rel2abs() + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores +the $base filename. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +# Internal routine to File::Spec, no point in making this public since +# it is the standard Cwd interface. Most of the platform-specific +# File::Spec subclasses use this. +sub _cwd { + require Cwd; + Cwd::getcwd(); +} + + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + pop @dirs if @dirs && $dirs[-1] eq ''; + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/VMS.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/VMS.pm new file mode 100644 index 00000000000..747a89d4fdb --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/VMS.pm @@ -0,0 +1,536 @@ +package File::Spec::VMS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.2701'; + +@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) = @_; + + return undef unless defined $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/\[\]// unless $path eq '[]'; # [] ==> + 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 = shift; + my $dir = pop; + my @dirs = grep {defined() && length()} @_; + + my $rslt; + if (@dirs) { + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + 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 = shift; + my $file = $self->canonpath(pop()); + my @files = grep {defined() && length()} @_; + + 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.((defined $rslt) && ($rslt ne '') ? '/' : '').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) = @_; + my @dirs = (); + return @dirs if ( (!defined $dirspec) || ('' eq $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 + $dirspec =~ s/^(\[|<)\./$1/; + @dirs = split /(?<!\^)\./, vmspath($dirspec); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec 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 ); + my $pathchunks = @pathchunks; + unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; + my @basechunks = $self->splitdir( $base_directories ); + my $basechunks = @basechunks; + unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @basechunks now contains the directories to climb out of, + # @pathchunks now has the directories to descend in to. + if ((@basechunks > 0) || ($basechunks != $pathchunks)) { + $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + } + else { + $path_directories = join '.', @pathchunks; + } + $path_directories = '['.$path_directories.']'; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +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 (defined $path) && ($path ne ''); + $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/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Win32.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Win32.pm new file mode 100644 index 00000000000..9520bbf7165 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Spec/Win32.pm @@ -0,0 +1,450 @@ +package File::Spec::Win32; + +use strict; + +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.2702'; + +@ISA = qw(File::Spec::Unix); + +# Some regexes we use for path splitting +my $DRIVE_RX = '[a-zA-Z]:'; +my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; +my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; + + +=head1 NAME + +File::Spec::Win32 - methods for Win32 file specs + +=head1 SYNOPSIS + + require File::Spec::Win32; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over 4 + +=item devnull + +Returns a string representation of the null device. + +=cut + +sub devnull { + return "nul"; +} + +sub rootdir () { '\\' } + + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + SYS:/temp + C:\system\temp + C:/temp + /tmp + / + +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). + +Since Perl 5.8.0, if running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), + 'SYS:/temp', + 'C:\system\temp', + 'C:/temp', + '/tmp', + '/' ); +} + +=item case_tolerant + +MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsystem. +See http://cygwin.com/ml/cygwin/2007-07/msg00891.html +Accepts an optional drive-letter argument. +Default: 1 + +=cut + +sub case_tolerant () { + use Win32; + my @ver = Win32::GetOSVersion(); + # From XP on this is disabled. + if ($ver[4] >= 2 and $ver[1] >= 5 and $ver[2] >= 1) { return 1; } + if ($ver[4] < 2) { return 1; } # Win32s,95,ME are always case_tolerant. + eval { require Win32API::File; } or return 1; + my $drive = shift; + $drive = shift if $drive =~ /^File::Spec/; + $drive ||= $ENV{SYSTEMDRIVE} || substr($ENV{WINDIR}, 0, 2); + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } +} + +=item file_name_is_absolute + +As of right now, this returns 2 if the path is absolute with a +volume, 1 if it's absolute with no volume, 0 otherwise. + +=cut + +sub file_name_is_absolute { + + my ($self,$file) = @_; + + if ($file =~ m{^($VOL_RX)}o) { + my $vol = $1; + return ($vol =~ m{^$UNC_RX}o ? 2 + : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 + : 0); + } + return $file =~ m{^[\\/]} ? 1 : 0; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + shift; + + # Legacy / compatibility support + # + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catfile('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); +} + +sub catdir { + shift; + + # Legacy / compatibility support + # + return "" + unless @_; + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catdir('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); +} + +sub path { + my @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + unshift(@path, "."); + return @path; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". +On Win32 makes + + dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even + dir1\dir2\dir3\...\dir4 -> \dir\dir4 + +=cut + +sub canonpath { + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, '' ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L</catpath> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^ ( $VOL_RX ? ) (.*) }sox; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( $VOL_RX ? ) + ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }sox; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L<catdir()|File::Spec/catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\Z(?!\n)| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + my $v; + $volume .= $v + if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + +sub _same { + lc($_[1]) eq lc($_[2]); +} + +sub rel2abs { + my ($self,$path,$base ) = @_; + + my $is_abs = $self->file_name_is_absolute($path); + + # Check for volume (should probably document the '2' thing...) + return $self->canonpath( $path ) if $is_abs == 2; + + if ($is_abs) { + # It's missing a volume, add one + my $vol = ($self->splitpath( $self->_cwd() ))[0]; + return $self->canonpath( $vol . $path ); + } + + if ( !defined( $base ) || $base eq '' ) { + require Cwd ; + $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; + $base = $self->_cwd() unless defined $base ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + + return $self->canonpath( $path ) ; +} + +=back + +=head2 Note For File::Spec::Win32 Maintainers + +Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. + +=head1 COPYRIGHT + +Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + + +sub _canon_cat(@) # @path -> path +{ + my $first = shift; + my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter + ? ucfirst( $1 ).( $2 ? "\\" : "" ) + : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) + (?: [\\/] ([^\\/]+) )? + [\\/]? }{}xs # UNC volume + ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" + : $first =~ s{ \A [\\/] }{}x # root dir + ? "\\" + : ""; + my $path = join "\\", $first, @_; + + $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy + + # xx/././yy --> xx/yy + $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + \. + (?:\\\.)* # and more + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}gx; + + # XXX I do not know whether more dots are supported by the OS supporting + # this ... annotation (NetWare or symbian but not MSWin32). + # Then .... could easily become ../../.. etc: + # Replace \.\.\. by (\.\.\.+) and substitute with + # { $1 . ".." . "\\.." x (length($2)-2) }gex + # ... --> ../.. + $path =~ s{ (\A|\\) # at begin or after a slash + \.\.\. + (?=\\|\z) # at end or followed by slash + }{$1..\\..}gx; + # xx\yy\..\zz --> xx\zz + while ( $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + [^\\]+ # rip this 'yy' off + \\\.\. + (?<!\A\.\.\\\.\.) # do *not* replace ^..\.. + (?<!\\\.\.\\\.\.) # do *not* replace \..\.. + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}sx ) {} + + $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # <vol>\.. --> <vol>\ + $path =~ s{ \A # at begin + \.\. + (?:\\\.\.)* # and more + (?:\\|\z) # at end or followed by slash + }{}x; + + return $1 # \\HOST\SHARE\ --> \\HOST\SHARE + if $path eq "" + and $volume =~ m#\A(\\\\.*)\\\z#s; + } + return $path ne "" || $volume ? $volume.$path : "."; +} + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/Temp.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/Temp.pm new file mode 100644 index 00000000000..120b5325101 --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/Temp.pm @@ -0,0 +1,2425 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=begin __INTERNALS + +=head1 PORTABILITY + +This section is at the top in order to provide easier access to +porters. It is not expected to be rendered by a standard pod +formatting tool. Please skip straight to the SYNOPSIS section if you +are not trying to port this module to a new platform. + +This module is designed to be portable across operating systems and it +currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS +(Classic). When porting to a new OS there are generally three main +issues that have to be solved: + +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C<stat> reliable? By default all the +return values from C<stat> are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If C<unlink0> fails +then the C<stat> comparison should be modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); + + binmode( $fh, ":utf8" ); + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + +Object interface: + + require File::Temp; + use File::Temp (); + use File::Temp qw/ :seekable /; + + $fh = File::Temp->new(); + $fname = $fh->filename; + + $fh = File::Temp->new(TEMPLATE => $template); + $fname = $fh->filename; + + $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); + print $tmp "Some data\n"; + print "Filename is $tmp\n"; + $tmp->seek( 0, SEEK_END ); + +The following interfaces are provided for compatibility with +existing APIs. They should not be used in new code. + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=head1 DESCRIPTION + +C<File::Temp> can be used to create and open temporary files in a safe +way. There is both a function interface and an object-oriented +interface. The File::Temp constructor or the tempfile() function can +be used to return the name and the open filehandle of a temporary +file. The tempdir() function can be used to create a temporary +directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L<POSIX|POSIX> +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +Filehandles returned by these functions support the seekable methods. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.004 so give them what they want :-) +use 5.004; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use IO::Seekable; # For SEEK_* +use Errno; +require VMS::Stdio if $^O eq 'VMS'; + +# pre-emptively load Carp::Heavy. If we don't when we run out of file +# handles and attempt to call croak() we get an error message telling +# us that Carp::Heavy won't load rather than an error telling us we +# have run out of file handles. We either preload croak() or we +# switch the calls to croak from _gettemp() to use die. +eval { require Carp::Heavy; }; + +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + +### For the OO interface +use base qw/ IO::Handle IO::Seekable /; +use overload '""' => "STRINGIFY", fallback => 1; + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); + +$DEBUG = 0; +$KEEP_ALL = 0; + +# We are exporting functions + +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + cleanup + SEEK_SET + SEEK_CUR + SEEK_END + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp','seekable'); + +# Version number + +$VERSION = '0.20'; + +# This is a list of characters that can be used in random filenames + +my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z + a b c d e f g h i j k l m n o p q r s t u v w x y z + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 1000; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; +my $LOCKFLAG; + +unless ($^O eq 'MacOS') { + for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # e.g. CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } + # Special case O_EXLOCK + $LOCKFLAG = eval { + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + &Fcntl::O_EXLOCK(); + }; +} + +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +unless ($^O eq 'MacOS') { + for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + local($@); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # e.g. CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } +} + +# Private hash tracking which files have been created by each process id via the OO interface +my %FILES_CREATED_BY_OBJECT; + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix +# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true. + +# Optionally a reference to a scalar can be passed into the function +# On error this will be used to store the reason for the error +# "ErrStr" => \$errstr + +# "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# stored in an error string and returned to give the reason whilst debugging +# This routine is not called by any external function +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # the internal error string - expect it to be overridden + # Need this in case the caller decides not to supply us a value + # need an anonymous scalar + my $tempErrStr; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + "unlink_on_close" => 0, + "use_exlock" => 1, + "ErrStr" => \$tempErrStr, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Make sure the error string is set to undef + ${$options{ErrStr}} = undef; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + ${$options{ErrStr}} = "The template must end with at least ". + MINX . " 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry (i.e. the directory template) that means + # we are in the current directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-e $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) does not exist"; + return (); + } + unless (-d $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; + return (); + } + 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; + + # Attempt to open the file + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock}); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { + + # in case of odd umask force rw + chmod(0600, $path); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Open the temp directory + if (mkdir( $path, 0700)) { + # in case of odd umask + chmod(0700, $path); + + return undef, $path; + } else { + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" + . MAX_TRIES . ") to open temp file/dir"; + + return (); + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + my $end = ( $] >= 5.006 ? "\\z" : "\\Z" ); + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; + } else { + $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; + } + return $path; +} + +# Internal routine to force a temp file to be writable after +# it is created so that we can unlink it. Windows seems to occassionally +# force a file to be readonly when written to certain temp locations +sub _force_writable { + my $file = shift; + chmod 0600, $file; +} + + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Optionally: reference to scalar to contain error message +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + my $err_ref = shift; + + # Stat path + my @info = stat($path); + unless (scalar(@info)) { + $$err_ref = "stat(path) returned no values"; + return 0; + }; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the effective uid from the $> variable + # UID is in [4] + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'", + File::Temp->top_system_uid()); + + $$err_ref = "Directory owned neither by root nor the current user" + if ref($err_ref); + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + # Must be a directory + unless (-d $path) { + $$err_ref = "Path ($path) is not a directory" + if ref($err_ref); + return 0; + } + # Must have sticky bit set + unless (-k $path) { + $$err_ref = "Sticky bit not set on $path when dir is group|world writable" + if ref($err_ref); + return 0; + } + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +# Takes optional second arg as scalar ref to error reason + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + print "_is_verysafe testing $path\n" if $DEBUG; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + my $err_ref = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + local($@); + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir,$err_ref); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. + +sub _can_unlink_opened_file { + + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { + return 0; + } else { + return 1; + } + +} + +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') { + return 0; + } else { + return 1; + } + +} + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opened file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred to since all the magic is done with an END block + +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories They will + # only exist in this block. + + # This means we only have to set up a single END block to remove + # all files. + + # in order to prevent child processes inadvertently deleting the parent + # temp files we use a hash to store the temp files and directories + # created by a particular process id. + + # %files_to_unlink contains values that are references to an array of + # array references containing the filehandle and filename associated with + # the temp file. + my (%files_to_unlink, %dirs_to_unlink); + + # Set up an end block to use these arrays + END { + 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, and can be compared to a filename directly. The object +isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are +available. + +=over 4 + +=item B<new> + +Create a temporary file object. + + my $tmp = File::Temp->new(); + +by default the object is constructed as if C<tempfile> +was called without options, but with the additional behaviour +that the temporary file is removed by the object destructor +if UNLINK is set to true (the default). + +Supported arguments are the same as for C<tempfile>: UNLINK +(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename +template is specified using the TEMPLATE option. The OPEN option +is not supported (the file is always opened). + + $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', + DIR => 'mydir', + SUFFIX => '.dat'); + +Arguments are case insensitive. + +Can call croak() if an error occurs. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + # read arguments and convert keys to upper case + my %args = @_; + %args = map { uc($_), $args{$_} } keys %args; + + # see if they are unlinking (defaulting to yes) + my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); + delete $args{UNLINK}; + + # template (store it in an 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; + + # Cache the filename by pid so that the destructor can decide whether to remove it + $FILES_CREATED_BY_OBJECT{$$}{$path} = 1; + + # Store unlink information in hash slot (plus other constructor info) + %{*$fh} = %args; + + # create the object + bless $fh, $class; + + # final method-based configuration + $fh->unlink_on_destroy( $unlink ); + + return $fh; +} + +=item B<newdir> + +Create a temporary directory using an object oriented interface. + + $dir = File::Temp->newdir(); + +By default the directory is deleted when the object goes out of scope. + +Supports the same options as the C<tempdir> function. Note that directories +created with this method default to CLEANUP => 1. + + $dir = File::Temp->newdir( $template, %options ); + +=cut + +sub newdir { + my $self = shift; + + # need to handle args as in tempdir because we have to force CLEANUP + # default without passing CLEANUP to tempdir + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + my %options = @_; + my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 ); + + delete $options{CLEANUP}; + + my $tempdir; + if (defined $template) { + $tempdir = tempdir( $template, %options ); + } else { + $tempdir = tempdir( %options ); + } + return bless { DIRNAME => $tempdir, + CLEANUP => $cleanup, + LAUNCHPID => $$, + }, "File::Temp::Dir"; +} + +=item B<filename> + +Return the name of the temporary file associated with this object +(if the object was created using the "new" constructor). + + $filename = $tmp->filename; + +This method is called automatically when the object is used as +a string. + +=cut + +sub filename { + my $self = shift; + return ${*$self}; +} + +sub STRINGIFY { + my $self = shift; + return $self->filename; +} + +=item B<dirname> + +Return the name of the temporary directory associated with this +object (if the object was created using the "newdir" constructor). + + $dirname = $tmpdir->dirname; + +This method is called automatically when the object is used in string context. + +=item B<unlink_on_destroy> + +Control whether the file is unlinked when the object goes out of scope. +The file is removed if this value is true and $KEEP_ALL is not. + + $fh->unlink_on_destroy( 1 ); + +Default is for the file to be removed. + +=cut + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + ${*$self}{UNLINK} = shift; + } + return ${*$self}{UNLINK}; +} + +=item B<DESTROY> + +When the object goes out of scope, the destructor is called. This +destructor will attempt to unlink the file (using C<unlink1>) +if the constructor was called with UNLINK set to 1 (the default state +if UNLINK is not specified). + +No error is given if the unlink fails. + +If the object has been passed to a child process during a fork, the +file will be deleted when the object goes out of scope in the parent. + +For a temporary directory object the directory will be removed +unless the CLEANUP argument was used in the constructor (and set to +false) or C<unlink_on_destroy> was modified after creation. + +If the global variable $KEEP_ALL is true, the file or directory +will not be removed. + +=cut + +sub DESTROY { + my $self = shift; + if (${*$self}{UNLINK} && !$KEEP_ALL) { + print "# ---------> Unlinking $self\n" if $DEBUG; + + # only delete if this process created it + return unless exists $FILES_CREATED_BY_OBJECT{$$}{$self->filename}; + + # 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, TMPDIR => 1); + +Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file +into the same temporary directory as would be used if no template was +specified at all. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits (dependent on +$KEEP_ALL). Default is for the file to be removed if a file handle is +requested and to be kept if the filename is requested. In a scalar +context (where no filename is returned) the file is always deleted +either (depending on the operating system) on exit or when it is +closed (unless $KEEP_ALL is true when the temp file is created). + +Use the object-oriented interface if fine-grained control of when +a file is removed is required. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L<File::Spec>) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( DIR => $dir ); + +If called in scalar context, only the filehandle is returned and the +file will automatically be deleted when closed on operating systems +that support this (see the description of tmpfile() elsewhere in this +document). This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition by fumbling +with the filename. On systems that can not unlink an open file or can +not mark a file as temporary when it is opened (for example, Windows +NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when +the program ends (equivalent to setting UNLINK to 1). The C<UNLINK> +flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +If the operating system supports it (for example BSD derived systems), the +filehandle will be opened with O_EXLOCK (open with exclusive file lock). +This can sometimes cause problems if the intention is to pass the filename +to another system that expects to take an exclusive lock itself (such as +DBD::SQLite) whilst ensuring that the tempfile is not reused. In this +situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK +will be true (this retains compatibility with earlier releases). + + ($fh, $filename) = tempfile($template, EXLOCK => 0); + +Options can be combined as required. + +Will croak() if there is an error. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file + "TMPDIR" => 0, # Place tempfile in tempdir if template specified + "EXLOCK" => 1, # Open file with O_EXLOCK + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + # End up with current directory if neither DIR not TMPDIR are set + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + $template = File::Spec->catfile(File::Spec->tmpdir, $template ); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it (which may be + # important if they want a child process to use the file) + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + + # Create the file + my ($fh, $path, $errstr); + croak "Error in tempfile() using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "unlink_on_close" => $unlink_on_close, + "suffixlen" => length($options{'SUFFIX'}), + "ErrStr" => \$errstr, + "use_exlock" => $options{EXLOCK}, + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B<tempdir> + +This is the recommended interface for creation of temporary +directories. By default the directory will not be removed on exit +(that is, it won't be temporary; this behaviour can not be changed +because of issues with backwards compatibility). To enable removal +either use the CLEANUP option which will trigger removal on program +exit, or consider using the "newdir" method in the object interface which +will allow the directory to be cleaned up when the object goes out of +scope. + +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L<File::Spec|File::Spec>). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, create the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C<TMPDIR> option is ignored if C<DIR> is set +explicitly. Additionally, C<TMPDIR> is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L<File::Path|File::Path> module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +Will croak() if there is an error. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + + my $errstr; + croak "Error in tempdir() using $template: $errstr" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B<mkstemp> + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced +with unique alphanumeric combinations. + +Will croak() if there is an error. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path, $errstr); + croak "Error in mkstemp using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B<mkstemps> + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C<testXXXXXX> and suffix of C<.dat> +would generate a file similar to F<testhGji_w.dat>. + +Returns just the filehandle alone when called in scalar context. + +Will croak() if there is an error. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path, $errstr); + croak "Error in mkstemps using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B<mkdtemp> + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. + +Directory must be removed by the caller. + +Will croak() if there is an error. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + my ($junk, $tmpdir, $errstr); + croak "Error creating temp directory from template $template\: $errstr" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + return $tmpdir; + +} + +=item B<mktemp> + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +Will croak() if there is an error. + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk, $errstr); + croak "Error getting name to temp file from template $template: $errstr" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L<POSIX> +using the mkstemp() from this module. + +Unlike the L<POSIX|POSIX> implementations, the directory used +for the temporary file is not specified in a system include +file (C<P_tmpdir>) but simply depends on the choice of tmpdir() +returned by L<File::Spec|File::Spec>. On some implementations this +location can be set using the C<TMPDIR> environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B<tmpnam> + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L<File::Spec/tmpdir> for information on the choice of temporary +directory for a particular operating system. + +Will croak() if there is an error. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B<tmpfile> + +Returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +Will croak() if there is an error. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in a list context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + # This will fail on NFS + unlink0($fh, $file) + or return undef; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B<tempnam> + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C<sysopen> +with C<O_CREAT | O_EXCL> if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +Will croak() if there is an error. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B<unlink0> + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) + or die "Error unlinking file $path safely"; + +Returns false on error but croaks() if there is a security +anomaly. The filehandle is not closed since on some occasions this is +not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C<dev> and C<rdev> fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C<stat(FH)> being more accurate than +C<stat(filename)>, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C<unlink0> it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +This function is disabled if the global variable $KEEP_ALL is true +and an unlink on open file is supported. If the unlink is to be deferred +to the END block, the file is still registered for removal. + +This function should not be called if you are using the object oriented +interface since the it will interfere with the object destructor deleting +the file. + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + + # return early (Without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + my @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=item B<cmpstat> + +Compare C<stat> of filehandle with C<stat> of provided filename. This +can be used to check that the filename and filehandle initially point +to the same file and that the number of links to the file is 1 (all +fields returned by stat() are compared). + + cmpstat($fh, $path) + or die "Error comparing handle with file"; + +Returns false if the stat information differs or if the link count is +greater than 1. Calls croak if there is a security anomaly. + +On certain platforms, for example Windows, not all the fields returned by stat() +can be compared. For example, the C<dev> and C<rdev> fields seem to be +different in Windows. Also, it seems that the size of the file +returned by stat() does not always agree, with C<stat(FH)> being more +accurate than C<stat(filename)>, presumably because of caching issues +even when using autoflush (this is usually overcome by waiting a while +after writing to the tempfile before attempting to C<unlink0> it). + +Not exported by default. + +=cut + +sub cmpstat { + + croak 'Usage: cmpstat(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Comparing stat\n" + if $DEBUG; + + # Stat the filehandle - which may be closed if someone has manually + # closed the file. Can not turn off warnings without using $^W + # unless we upgrade to 5.006 minimum requirement + my @fh; + { + local ($^W) = 0; + @fh = stat $fh; + } + return unless @fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh" if $^W; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f $path) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); + } elsif ($^O eq 'mpeix') { + @okstat = (0..4,8..10); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + return 1; +} + +=item B<unlink1> + +Similar to C<unlink0> except after file comparison using cmpstat, the +filehandle is closed prior to attempting to unlink the file. This +allows the file to be removed without using an END block, but does +mean that the post-unlink comparison of the filehandle state provided +by C<unlink0> is not available. + + unlink1($fh, $path) + or die "Error closing and unlinking file"; + +Usually called from the object destructor when using the OO interface. + +Not exported by default. + +This function is disabled if the global variable $KEEP_ALL is true. + +Can call croak() if there is a security anomaly during the stat() +comparison. + +=cut + +sub unlink1 { + croak 'Usage: unlink1(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # Close the file + close( $fh ) or return 0; + + # Make sure the file is writable (for windows) + _force_writable( $path ); + + # return early (without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # remove the file + return unlink($path); +} + +=item B<cleanup> + +Calling this function will cause any temp files or temp directories +that are registered for removal to be removed. This happens automatically +when the process exits but can be triggered manually if the caller is sure +that none of the temp files are required. This method can be registered as +an Apache callback. + +On OSes where temp files are automatically removed when the temp file +is closed, calling this function will have no effect other than to remove +temporary directories (which may include temporary files). + + File::Temp::cleanup(); + +Not exported by default. + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B<safe_level> + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and is +writable, that temporary files are opened only if they do not already +exist, and that possible race conditions are avoided. Finally the +L<unlink0|"unlink0"> function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L<POSIX|POSIX> +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L<POSIX|POSIX> +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L<Fcntl|Fcntl> that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C<safe_level>. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Dont allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than +simply by root. + +This is required since on many unix systems C</tmp> is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C<safe_level> is set to MEDIUM or higher. + +=cut + +{ + my $TopSystemUID = 10; + $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=item B<$KEEP_ALL> + +Controls whether temporary files and directories should be retained +regardless of any instructions in the program to remove them +automatically. This is useful for debugging but should not be used in +production code. + + $File::Temp::KEEP_ALL = 1; + +Default is for files to be removed as requested by the caller. + +In some cases, files will only be retained if this variable is true +when the file is created. This means that you can not create a temporary +file, set this variable and expect the temp file to still be around +when the program exits. + +=item B<$DEBUG> + +Controls whether debugging messages should be enabled. + + $File::Temp::DEBUG = 1; + +Default is for debugging mode to be disabled. + +=back + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + +=head2 Forking + +In some cases files created by File::Temp are removed from within an +END block. Since END blocks are triggered when a child process exits +(unless C<POSIX::_exit()> is used by the child) File::Temp takes care +to only remove those temp files created by a particular process ID. This +means that a child will not attempt to remove temp files created by the +parent process. + +If you are forking many processes in parallel that are all creating +temporary files, you may need to reset the random number seed using +srand(EXPR) in each child else all the children will attempt to walk +through the same set of random file names and may well cause +themselves to give up if they exceed the number of retry attempts. + +=head2 BINMODE + +The file returned by File::Temp will have been opened in binary mode +if such a mode is available. If that is not correct, use the C<binmode()> +function to change the mode of the filehandle. + +Note that you can modify the encoding of a file opened by File::Temp +also by using C<binmode()>. + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. The module was shipped +as a standard part of perl from v5.6.1. + +=head1 SEE ALSO + +L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> + +See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for +different implementations of temporary file handling. + +See L<File::Tempdir> for an alternative object-oriented wrapper for +the C<tempdir> function. + +=head1 AUTHOR + +Tim Jenness E<lt>tjenness@cpan.orgE<gt> + +Copyright (C) 2007 Tim Jenness. +Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + +package File::Temp::Dir; + +use File::Path qw/ rmtree /; +use strict; +use overload '""' => "STRINGIFY", fallback => 1; + +# private class specifically to support tempdir objects +# created by File::Temp->newdir + +# ostensibly the same method interface as File::Temp but without +# inheriting all the IO::Seekable methods and other cruft + +# Read-only - returns the name of the temp directory + +sub dirname { + my $self = shift; + return $self->{DIRNAME}; +} + +sub STRINGIFY { + my $self = shift; + return $self->dirname; +} + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + $self->{CLEANUP} = shift; + } + return $self->{CLEANUP}; +} + +sub DESTROY { + my $self = shift; + if ($self->unlink_on_destroy && + $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { + rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0) + if -d $self->{DIRNAME}; + } +} + + +1; diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/File/stat.pm b/chromium/third_party/cygwin/lib/perl5/5.10/File/stat.pm new file mode 100644 index 00000000000..132cbee27ad --- /dev/null +++ b/chromium/third_party/cygwin/lib/perl5/5.10/File/stat.pm @@ -0,0 +1,139 @@ +package File::stat; +use 5.006; + +use strict; +use warnings; + +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); + +our $VERSION = '1.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 |