ÿØÿà JFIF    ÿÛ „ ( %!1!%*+...983,7(-.- GlobMapper.pm000064400000040606152342777310007153 0ustar00package File::GlobMapper; use strict; use warnings; use Carp; our ($CSH_GLOB); BEGIN { if ($] < 5.006) { require File::BSDGlob; import File::BSDGlob qw(:glob) ; $CSH_GLOB = File::BSDGlob::GLOB_CSH() ; *globber = \&File::BSDGlob::csh_glob; } else { require File::Glob; import File::Glob qw(:glob) ; $CSH_GLOB = File::Glob::GLOB_CSH() ; #*globber = \&File::Glob::bsd_glob; *globber = \&File::Glob::csh_glob; } } our ($Error); our ($VERSION, @EXPORT_OK); $VERSION = '1.001'; @EXPORT_OK = qw( globmap ); our $BEGIN_DELIM = "\xFF"; our $END_DELIM = "\xFE"; our $BACKSLASH_ESC = "\xFD"; our $HASH_ESC = "\xFC"; our $STAR_ESC = "\xFB"; our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); $noPreBS = '(? '([^/]*)', '?' => '([^/])', '.' => '\.', '[' => '([', '(' => '(', ')' => ')', ); %wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; sub globmap ($$;) { my $inputGlob = shift ; my $outputGlob = shift ; my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) or croak "globmap: $Error" ; return $obj->getFileMap(); } sub new { my $class = shift ; my $inputGlob = shift ; my $outputGlob = shift ; # TODO -- flags needs to default to whatever File::Glob does my $flags = shift || $CSH_GLOB ; #my $flags = shift ; $inputGlob =~ s/^\s*\<\s*//; $inputGlob =~ s/\s*\>\s*$//; $outputGlob =~ s/^\s*\<\s*//; $outputGlob =~ s/\s*\>\s*$//; my %object = ( InputGlob => $inputGlob, OutputGlob => $outputGlob, GlobFlags => $flags, Braces => 0, WildCount => 0, Pairs => [], Sigil => '#', ); my $self = bless \%object, ref($class) || $class ; $self->_parseInputGlob() or return undef ; $self->_parseOutputGlob() or return undef ; my @inputFiles = globber($self->{InputGlob}, $flags) ; if (GLOB_ERROR) { $Error = $!; return undef ; } #if (whatever) { my $missing = grep { ! -e $_ } @inputFiles ; if ($missing) { $Error = "$missing input files do not exist"; return undef ; } } $self->{InputFiles} = \@inputFiles ; $self->_getFiles() or return undef ; return $self; } sub _retError { my $string = shift ; $Error = "$string in input fileglob" ; return undef ; } sub _unmatched { my $delimeter = shift ; _retError("Unmatched $delimeter"); return undef ; } sub _parseBit { my $self = shift ; my $string = shift ; my $out = ''; my $depth = 0 ; while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//) { $out .= quotemeta($1) ; $out .= $mapping{$2} if defined $mapping{$2}; ++ $self->{WildCount} if $wildCount{$2} ; if ($2 eq ',') { return _unmatched("(") if $depth ; $out .= '|'; } elsif ($2 eq '(') { ++ $depth ; } elsif ($2 eq ')') { return _unmatched(")") if ! $depth ; -- $depth ; } elsif ($2 eq '[') { # TODO -- quotemeta & check no '/' # TODO -- check for \] & other \ within the [] $string =~ s#(.*?\])## or return _unmatched("["); $out .= "$1)" ; } elsif ($2 eq ']') { return _unmatched("]"); } elsif ($2 eq '{' || $2 eq '}') { return _retError("Nested {} not allowed"); } } $out .= quotemeta $string; return _unmatched("(") if $depth ; return $out ; } sub _parseInputGlob { my $self = shift ; my $string = $self->{InputGlob} ; my $inGlob = ''; # Multiple concatenated *'s don't make sense #$string =~ s#\*\*+#*# ; # TODO -- Allow space to delimit patterns? #my @strings = split /\s+/, $string ; #for my $str (@strings) my $out = ''; my $depth = 0 ; while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//) { $out .= quotemeta($1) ; $out .= $mapping{$2} if defined $mapping{$2}; ++ $self->{WildCount} if $wildCount{$2} ; if ($2 eq '(') { ++ $depth ; } elsif ($2 eq ')') { return _unmatched(")") if ! $depth ; -- $depth ; } elsif ($2 eq '[') { # TODO -- quotemeta & check no '/' or '(' or ')' # TODO -- check for \] & other \ within the [] $string =~ s#(.*?\])## or return _unmatched("["); $out .= "$1)" ; } elsif ($2 eq ']') { return _unmatched("]"); } elsif ($2 eq '}') { return _unmatched("}"); } elsif ($2 eq '{') { # TODO -- check no '/' within the {} # TODO -- check for \} & other \ within the {} my $tmp ; unless ( $string =~ s/(.*?)$noPreBS\}//) { return _unmatched("{"); } #$string =~ s#(.*?)\}##; #my $alt = join '|', # map { quotemeta $_ } # split "$noPreBS,", $1 ; my $alt = $self->_parseBit($1); defined $alt or return 0 ; $out .= "($alt)" ; ++ $self->{Braces} ; } } return _unmatched("(") if $depth ; $out .= quotemeta $string ; $self->{InputGlob} =~ s/$noPreBS[\(\)]//g; $self->{InputPattern} = $out ; #print "# INPUT '$self->{InputGlob}' => '$out'\n"; return 1 ; } sub _parseOutputGlob { my $self = shift ; my $string = $self->{OutputGlob} ; my $maxwild = $self->{WildCount}; if ($self->{GlobFlags} & GLOB_TILDE) #if (1) { $string =~ s{ ^ ~ # find a leading tilde ( # save this in $1 [^/] # a non-slash character * # repeated 0 or more times (0 means me) ) }{ $1 ? (getpwnam($1))[7] : ( $ENV{HOME} || $ENV{LOGDIR} ) }ex; } # max #1 must be == to max no of '*' in input while ( $string =~ m/#(\d)/g ) { croak "Max wild is #$maxwild, you tried #$1" if $1 > $maxwild ; } my $noPreBS = '(?{InputPattern}'\n"; # print "OUTPUT '$self->{OutputGlob}' => '$string'\n"; $self->{OutputPattern} = $string ; return 1 ; } sub _getFiles { my $self = shift ; my %outInMapping = (); my %inFiles = () ; foreach my $inFile (@{ $self->{InputFiles} }) { next if $inFiles{$inFile} ++ ; my $outFile = $inFile ; my @matches ; my $noPreESC = '(?{InputPattern}/ )) { $outFile = $self->{OutputPattern}; my $ix = 1; # get the filename glob $outFile =~ s/${noPreESC}${BEGIN_DELIM}${END_DELIM}/$inFile/g; # now each of the #1, #2,... for my $pattern (@matches) { $outFile =~ s/${noPreESC}${BEGIN_DELIM}${ix}${END_DELIM}/$pattern/g; ++ $ix; } # unescape $outFile =~ s/${BEGIN_DELIM}${BEGIN_DELIM}/${BEGIN_DELIM}/g; $outFile =~ s/${END_DELIM}${END_DELIM}/${END_DELIM}/g; $outFile =~ s/${HASH_ESC}/#/g; $outFile =~ s/${STAR_ESC}/*/g; if (defined $outInMapping{$outFile}) { $Error = "multiple input files map to one output file"; return undef ; } $outInMapping{$outFile} = $inFile; push @{ $self->{Pairs} }, [$inFile, $outFile]; } } return 1 ; } sub getFileMap { my $self = shift ; return $self->{Pairs} ; } sub getHash { my $self = shift ; return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; } 1; __END__ =head1 NAME File::GlobMapper - Extend File Glob to Allow Input and Output Files =head1 SYNOPSIS use File::GlobMapper qw( globmap ); my $aref = globmap $input => $output or die $File::GlobMapper::Error ; my $gm = new File::GlobMapper $input => $output or die $File::GlobMapper::Error ; =head1 DESCRIPTION This module needs Perl5.005 or better. This module takes the existing C module as a starting point and extends it to allow new filenames to be derived from the files matched by C. This can be useful when carrying out batch operations on multiple files that have both an input filename and output filename and the output file can be derived from the input filename. Examples of operations where this can be useful include, file renaming, file copying and file compression. =head2 Behind The Scenes To help explain what C does, consider what code you would write if you wanted to rename all files in the current directory that ended in C<.tar.gz> to C<.tgz>. So say these files are in the current directory alpha.tar.gz beta.tar.gz gamma.tar.gz and they need renamed to this alpha.tgz beta.tgz gamma.tgz Below is a possible implementation of a script to carry out the rename (error cases have been omitted) foreach my $old ( glob "*.tar.gz" ) { my $new = $old; $new =~ s#(.*)\.tar\.gz$#$1.tgz# ; rename $old => $new or die "Cannot rename '$old' to '$new': $!\n; } Notice that a file glob pattern C<*.tar.gz> was used to match the C<.tar.gz> files, then a fairly similar regular expression was used in the substitute to allow the new filename to be created. Given that the file glob is just a cut-down regular expression and that it has already done a lot of the hard work in pattern matching the filenames, wouldn't it be handy to be able to use the patterns in the fileglob to drive the new filename? Well, that's I what C does. Here is same snippet of code rewritten using C for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' ) { my ($from, $to) = @$pair; rename $from => $to or die "Cannot rename '$old' to '$new': $!\n; } So how does it work? Behind the scenes the C function does a combination of a file glob to match existing filenames followed by a substitute to create the new filenames. Notice how both parameters to C are strings that are delimited by <>. This is done to make them look more like file globs - it is just syntactic sugar, but it can be handy when you want the strings to be visually distinctive. The enclosing <> are optional, so you don't have to use them - in fact the first thing globmap will do is remove these delimiters if they are present. The first parameter to C, C<*.tar.gz>, is an I. Once the enclosing "< ... >" is removed, this is passed (more or less) unchanged to C to carry out a file match. Next the fileglob C<*.tar.gz> is transformed behind the scenes into a full Perl regular expression, with the additional step of wrapping each transformed wildcard metacharacter sequence in parenthesis. In this case the input fileglob C<*.tar.gz> will be transformed into this Perl regular expression ([^/]*)\.tar\.gz Wrapping with parenthesis allows the wildcard parts of the Input File Glob to be referenced by the second parameter to C, C<#1.tgz>, the I. This parameter operates just like the replacement part of a substitute command. The difference is that the C<#1> syntax is used to reference sub-patterns matched in the input fileglob, rather than the C<$1> syntax that is used with perl regular expressions. In this case C<#1> is used to refer to the text matched by the C<*> in the Input File Glob. This makes it easier to use this module where the parameters to C are typed at the command line. The final step involves passing each filename matched by the C<*.tar.gz> file glob through the derived Perl regular expression in turn and expanding the output fileglob using it. The end result of all this is a list of pairs of filenames. By default that is what is returned by C. In this example the data structure returned will look like this ( ['alpha.tar.gz' => 'alpha.tgz'], ['beta.tar.gz' => 'beta.tgz' ], ['gamma.tar.gz' => 'gamma.tgz'] ) Each pair is an array reference with two elements - namely the I filename, that C has matched, and a I filename that is derived from the I filename. =head2 Limitations C has been kept simple deliberately, so it isn't intended to solve all filename mapping operations. Under the hood C (or for older versions of Perl, C) is used to match the files, so you will never have the flexibility of full Perl regular expression. =head2 Input File Glob The syntax for an Input FileGlob is identical to C, except for the following =over 5 =item 1. No nested {} =item 2. Whitespace does not delimit fileglobs. =item 3. The use of parenthesis can be used to capture parts of the input filename. =item 4. If an Input glob matches the same file more than once, only the first will be used. =back The syntax =over 5 =item B<~> =item B<~user> =item B<.> Matches a literal '.'. Equivalent to the Perl regular expression \. =item B<*> Matches zero or more characters, except '/'. Equivalent to the Perl regular expression [^/]* =item B Matches zero or one character, except '/'. Equivalent to the Perl regular expression [^/]? =item B<\> Backslash is used, as usual, to escape the next character. =item B<[]> Character class. =item B<{,}> Alternation =item B<()> Capturing parenthesis that work just like perl =back Any other character it taken literally. =head2 Output File Glob The Output File Glob is a normal string, with 2 glob-like features. The first is the '*' metacharacter. This will be replaced by the complete filename matched by the input file glob. So *.c *.Z The second is Output FileGlobs take the =over 5 =item "*" The "*" character will be replaced with the complete input filename. =item #1 Patterns of the form /#\d/ will be replaced with the =back =head2 Returned Data =head1 EXAMPLES =head2 A Rename script Below is a simple "rename" script that uses C to determine the source and destination filenames. use File::GlobMapper qw(globmap) ; use File::Copy; die "rename: Usage rename 'from' 'to'\n" unless @ARGV == 2 ; my $fromGlob = shift @ARGV; my $toGlob = shift @ARGV; my $pairs = globmap($fromGlob, $toGlob) or die $File::GlobMapper::Error; for my $pair (@$pairs) { my ($from, $to) = @$pair; move $from => $to ; } Here is an example that renames all c files to cpp. $ rename '*.c' '#1.cpp' =head2 A few example globmaps Below are a few examples of globmaps To copy all your .c file to a backup directory '' '' If you want to compress all '' '<*.gz>' To uncompress '' '' =head1 SEE ALSO L =head1 AUTHOR The I module was written by Paul Marquess, F. =head1 COPYRIGHT AND LICENSE Copyright (c) 2005 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. stat.pm000064400000023536152342777310006101 0ustar00package File::stat; use 5.006; use strict; use warnings; use warnings::register; use Carp; BEGIN { *warnif = \&warnings::warnif } our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); our $VERSION = '1.07'; my @fields; BEGIN { use Exporter (); @EXPORT = qw(stat lstat); @fields = 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_OK = ( @fields, "stat_cando" ); %EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] ); } use vars @fields; use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR); BEGIN { # These constants will croak on use if the platform doesn't define # them. It's important to avoid inflicting that on the user. no strict 'refs'; for (qw(suid sgid svtx)) { my $val = eval { &{"Fcntl::S_I\U$_"} }; *{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" }; } for (qw(SOCK CHR BLK REG DIR LNK)) { *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} } ? \&{"Fcntl::S_IS$_"} : sub { "" }; } # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above # RT #111638 *{"S_ISFIFO"} = defined &Fcntl::S_IFIFO ? \&Fcntl::S_ISFIFO : sub { "" }; } # from doio.c sub _ingroup { my ($gid, $eff) = @_; # I am assuming that since VMS doesn't have getgroups(2), $) will # always only contain a single entry. $^O eq "VMS" and return $_[0] == $); my ($egid, @supp) = split " ", $); my ($rgid) = split " ", $(; $gid == ($eff ? $egid : $rgid) and return 1; grep $gid == $_, @supp and return 1; return ""; } # VMS uses the Unix version of the routine, even though this is very # suboptimal. VMS has a permissions structure that doesn't really fit # into struct stat, and unlike on Win32 the normal -X operators respect # that, but unfortunately by the time we get here we've already lost the # information we need. It looks to me as though if we were to preserve # the st_devnam entry of vmsish.h's fake struct stat (which actually # holds the filename) it might be possible to do this right, but both # getting that value out of the struct (perl's stat doesn't return it) # and interpreting it later would require this module to have an XS # component (at which point we might as well just call Perl_cando and # have done with it). if (grep $^O eq $_, qw/os2 MSWin32 dos/) { # from doio.c *cando = sub { ($_[0][2] & $_[1]) ? 1 : "" }; } else { # from doio.c *cando = sub { my ($s, $mode, $eff) = @_; my $uid = $eff ? $> : $<; my ($stmode, $stuid, $stgid) = @$s[2,4,5]; # This code basically assumes that the rwx bits of the mode are # the 0777 bits, but so does Perl_cando. if ($uid == 0 && $^O ne "VMS") { # If we're root on unix # not testing for executable status => all file tests are true return 1 if !($mode & 0111); # testing for executable status => # for a file, any x bit will do # for a directory, always true return 1 if $stmode & 0111 || S_ISDIR($stmode); return ""; } if ($stuid == $uid) { $stmode & $mode and return 1; } elsif (_ingroup($stgid, $eff)) { $stmode & ($mode >> 3) and return 1; } else { $stmode & ($mode >> 6) and return 1; } return ""; }; } # alias for those who don't like objects *stat_cando = \&cando; my %op = ( r => sub { cando($_[0], S_IRUSR, 1) }, w => sub { cando($_[0], S_IWUSR, 1) }, x => sub { cando($_[0], S_IXUSR, 1) }, o => sub { $_[0][4] == $> }, R => sub { cando($_[0], S_IRUSR, 0) }, W => sub { cando($_[0], S_IWUSR, 0) }, X => sub { cando($_[0], S_IXUSR, 0) }, O => sub { $_[0][4] == $< }, e => sub { 1 }, z => sub { $_[0][7] == 0 }, s => sub { $_[0][7] }, f => sub { S_ISREG ($_[0][2]) }, d => sub { S_ISDIR ($_[0][2]) }, l => sub { S_ISLNK ($_[0][2]) }, p => sub { S_ISFIFO($_[0][2]) }, S => sub { S_ISSOCK($_[0][2]) }, b => sub { S_ISBLK ($_[0][2]) }, c => sub { S_ISCHR ($_[0][2]) }, u => sub { _suid($_[0][2]) }, g => sub { _sgid($_[0][2]) }, k => sub { _svtx($_[0][2]) }, M => sub { ($^T - $_[0][9] ) / 86400 }, C => sub { ($^T - $_[0][10]) / 86400 }, A => sub { ($^T - $_[0][8] ) / 86400 }, ); use constant HINT_FILETEST_ACCESS => 0x00400000; # we need fallback=>1 or stringifying breaks use overload fallback => 1, -X => sub { my ($s, $op) = @_; if (index("rwxRWX", $op) >= 0) { (caller 0)[8] & HINT_FILETEST_ACCESS and warnif("File::stat ignores use filetest 'access'"); $^O eq "VMS" and warnif("File::stat ignores VMS ACLs"); # It would be nice to have a warning about using -l on a # non-lstat, but that would require an extra member in the # object. } if ($op{$op}) { return $op{$op}->($_[0]); } else { croak "-$op is not implemented on a File::stat object"; } }; # 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 defined $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"; } if ( -x $st ) { print "$file is executable\n"; } use Fcntl "S_IRUSR"; if ( $st->cando(S_IRUSR, 1) ) { print "My effective uid can read $file\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. As of version 1.02 (provided with perl 5.12) the object provides C<"-X"> overloading, so you can call filetest operators (C<-f>, C<-x>, and so on) on it. It also provides a C<< ->cando >> method, called like $st->cando( ACCESS, EFFECTIVE ) where I is one of C, C or C from the L module, and I indicates whether to use effective (true) or real (false) ids. The method interprets the C, C and C fields, and returns whether or not the current process would be allowed the specified access. If you don't want to use the objects, you may import the C<< ->cando >> method into your namespace as a regular function called C. This takes an arrayref containing the return values of C or C as its first argument, and interprets it for you. 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 in front their method names. Thus, C<$stat_obj-Edev()> corresponds to $st_dev if you import the fields. To access this functionality without the core overrides, pass the C 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 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 ERRORS =over 4 =item -%s is not implemented on a File::stat object The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as they require more information than just a stat buffer. =back =head1 WARNINGS These can all be disabled with no warnings "File::stat"; =over 4 =item File::stat ignores use filetest 'access' You have tried to use one of the C<-rwxRWX> filetests with C in effect. C will ignore the pragma, and just use the information in the C member as usual. =item File::stat ignores VMS ACLs VMS systems have a permissions structure that cannot be completely represented in a stat buffer, and unlike on other systems the builtin filetest operators respect this. The C overloads, however, do not, since the information required is not available. =back =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 Basename.pm000064400000025672152342777310006644 0ustar00=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: C and C 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's C and C 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; # File::Basename is used during the Perl build, when the re extension may # not be available, but we only actually need it if running under tainting. BEGIN { if (${^TAINT}) { require re; re->import('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.85"; fileparse_set_fstype($^O); =over 4 =item C X my($filename, $dirs, $suffix) = fileparse($path); my($filename, $dirs, $suffix) = fileparse($path, @suffixes); my $filename = fileparse($path, @suffixes); The C routine divides a file path into its $dirs, $filename and (optionally) the filename $suffix. $dirs 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) 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 L) 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<$dirs . $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 propagated from the path to its pieces. $tail .= $taint; wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) : ($basename .= $taint); } =item C X X my $filename = basename($path); my $filename = basename($path, @suffixes); This function is provided for compatibility with the Unix shell command C. It does B 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. C returns the last level of a filepath even if the last level is clearly directory. In effect, it is acting like C for paths. This differs from C's behaviour. # Both return "bar" basename("/foo/bar"); basename("/foo/bar/"); @suffixes work as in C 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 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 X This function is provided for compatibility with the Unix shell command C and has inherited some of its quirks. In spite of its name it does B always return the directory name as you might expect. To be safe, if you want the directory name of a path use C. 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 work like C, returning just the $dirs. # On VMS and AmigaOS my $dirs = dirname($path); When using Unix or MSDOS syntax this emulates the C shell function which is subtly different from how C 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 for file paths. Also unlike C, C 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 X 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, L, L Copy.pm000064400000037434152342777310006042 0ustar00# File/Copy.pm. Written in 1994 by Aaron Sherman . 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; no warnings 'newline'; use File::Spec; use Config; # During perl build, we need File::Copy but Scalar::Util might not be built yet # And then we need these games to avoid loading overload, as that will # confuse miniperl during the bootstrap of perl. my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); sub copy; sub syscopy; sub cp; sub mv; $VERSION = '2.32'; 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; } sub _catname { my($from, $to) = @_; if (not defined &basename) { require File::Basename; import File::Basename 'basename'; } return File::Spec->catfile($to, basename($from)); } # _eq($from, $to) tells whether $from and $to are identical sub _eq { my ($from, $to) = map { $Scalar_Util_loaded && Scalar::Util::blessed($_) && overload::Method($_, q{""}) ? "$_" : $_ } (@_); return '' if ( (ref $from) xor (ref $to) ); return $from == $to if ref $from; return $from eq $to; } sub copy { croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") unless(@_ == 2 || @_ == 3); my $from = shift; my $to = shift; my $size; if (@_) { $size = shift(@_) + 0; croak("Bad buffer size for copy: $size\n") unless ($size > 0); } my $from_a_handle = (ref($from) ? (ref($from) eq 'GLOB' || UNIVERSAL::isa($from, 'GLOB') || UNIVERSAL::isa($from, 'IO::Handle')) : (ref(\$from) eq 'GLOB')); my $to_a_handle = (ref($to) ? (ref($to) eq 'GLOB' || UNIVERSAL::isa($to, 'GLOB') || UNIVERSAL::isa($to, 'IO::Handle')) : (ref(\$to) eq 'GLOB')); if (_eq($from, $to)) { # works for references, too carp("'$from' and '$to' are identical (not copied)"); return 0; } if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { $to = _catname($from, $to); } 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] && !-p $from) { carp("'$from' and '$to' are identical (not copied)"); return 0; } } } elsif (_eq($from, $to)) { carp("'$from' and '$to' are identical (not copied)"); return 0; } 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 'MSWin32') && !($from_a_handle && $^O eq 'NetWare') ) { if ($^O eq 'VMS' && -e $from && ! -d $to && ! -d $from) { # VMS natively inherits path components from the source of a # copy, but we want the Unixy behavior of inheriting from # the current working directory. Also, default in a trailing # dot for null file types. $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.'); # Get rid of the old versions to be like UNIX 1 while unlink $to; } return syscopy($from, $to) || 0; } my $closefrom = 0; my $closeto = 0; my ($status, $r, $buf); local($\) = ''; my $from_h; if ($from_a_handle) { $from_h = $from; } else { 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_h = \do { local *FH }; # XXX is this line obsolete? 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 cp { my($from,$to) = @_; my(@fromstat) = stat $from; my(@tostat) = stat $to; my $perm; return 0 unless copy(@_) and @fromstat; if (@tostat) { $perm = $tostat[2]; } else { $perm = $fromstat[2] & ~(umask || 0); @tostat = stat $to; } # Might be more robust to look for S_I* in Fcntl, but we're # trying to avoid dependence on any XS-containing modules, # since File::Copy is used during the Perl build. $perm &= 07777; if ($perm & 06000) { croak("Unable to check setuid/setgid permissions for $to: $!") unless @tostat; if ($perm & 04000 and # setuid $fromstat[4] != $tostat[4]) { # owner must match $perm &= ~06000; } if ($perm & 02000 && $> != 0) { # if not root, setgid my $ok = $fromstat[5] == $tostat[5]; # group must match if ($ok) { # and we must be in group $ok = grep { $_ == $fromstat[5] } split /\s+/, $) } $perm &= ~06000 unless $ok; } } return 0 unless @tostat; return 1 if $perm == ($tostat[2] & 07777); return eval { chmod $perm, $to; } ? 1 : 0; } sub _move { croak("Usage: move(FROM, TO) ") unless @_ == 3; my($from,$to,$fallback) = @_; 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; } if ($^O eq 'VMS' && -e $from && ! -d $to && ! -d $from) { # VMS natively inherits path components from the source of a # copy, but we want the Unixy behavior of inheriting from # the current working directory. Also, default in a trailing # dot for null file types. $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.'); # Get rid of the old versions to be like UNIX 1 while unlink $to; } return 1 if rename $from, $to; # Did rename return an error even though it succeeded, because $to # is on a remote NFS file system, and NFS lost the server's ack? return 1 if defined($fromsz) && !-e $from && # $from disappeared (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there ((!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__}; $fallback->($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; } sub move { _move(@_,\©); } sub mv { _move(@_,\&cp); } # &syscopy is an XSUB under OS/2 unless (defined &syscopy) { if ($^O eq 'VMS') { *syscopy = \&rmscopy; } 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); }; } else { $Syscopy_is_copy = 1; *syscopy = \© } } 1; __END__ =head1 NAME File::Copy - Copy files or filehandles =head1 SYNOPSIS use File::Copy; copy("sourcefile","destinationfile") or die "Copy failed: $!"; copy("Copy.pm",\*STDOUT); move("/dev1/sourcefile","/dev2/destinationfile"); use File::Copy "cp"; $n = FileHandle->new("/a/file","r"); cp($n,"x"); =head1 DESCRIPTION The File::Copy module provides two basic functions, C and C, which are useful for getting the contents of a file from one place to another. =over 4 =item copy X X The C 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 it will be opened for reading. Likewise, the second argument will be written to. If the second argument does not exist but the parent directory does exist, then it will be created. Trying to copy a file into a non-existent directory is an error. Trying to copy a file on top of itself is also an error. C will not overwrite read-only files. If the destination (second argument) already exists and is a directory, and the source (first argument) is not a filehandle, then the source file will be copied into the directory specified by the destination, using the same base name as the source file. It's a failure to have a filehandle as the source when the destination is a directory. B Files are opened in binary mode where applicable. To get a consistent behaviour when copying from a filehandle to a file, use C 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 to get at the C alias for this function. The syntax is I the same. The behavior is nearly the same as well: as of version 2.15, C will preserve the source file's permission bits like the shell utility C would do, while C uses the default permissions for the target file (which may depend on the process' C, file ownership, inherited ACLs, etc.). If an error occurs in setting permissions, C will return 0, regardless of whether the file was successfully copied. =item move X X X The C 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 C alias for this function in the same way that you may use the C alias for C. =item syscopy X File::Copy also provides the C 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 routine, which doesn't preserve OS-specific attributes. For VMS systems, this calls the C routine (see below). For OS/2 systems, this calls the C XSUB directly. For Win32 systems, this calls C. B is defined (OS/2, VMS and Win32)>: If both arguments to C are not file handles, then C will perform a "system copy" of the input file to a new output file, in order to preserve file attributes, indexed file structure, I The buffer size parameter is ignored. If either argument to C 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 (or under VMS as C, which is the routine that does the actual work for syscopy). =item rmscopy($from,$to[,$date_flag]) X 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 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 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 returns, not the newly created version.) The third parameter is an integer flag, which tells C how to handle timestamps. If it is E 0, none of the input file's timestamps are propagated to the output file. If it is E 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 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. C is VMS specific and cannot be exported; it must be referenced by its full name, e.g.: File::Copy::rmscopy($from, $to) or die $!; Like C, C 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 Before calling copy() or move() on a filehandle, the caller should close or flush() the file to avoid writes being lost. Note that this is the case even for move(), because it may actually copy the file, depending on the OS-specific inplementation, and the underlying filesystem(s). =head1 AUTHOR File::Copy was written by Aaron Sherman Iajs@ajs.comE> in 1995, and updated by Charles Bailey Ibailey@newman.upenn.eduE> in 1996. =cut Find.pm000064400000102144152342777310005777 0ustar00package File::Find; use 5.006; use strict; use warnings; use warnings::register; our $VERSION = '1.34'; require Exporter; require Cwd; our @ISA = qw(Exporter); our @EXPORT = qw(find finddepth); use strict; my $Is_VMS; my $Is_Win32; 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; } sub PathCombine($$) { my ($Base,$Name) = @_; my $AbsName; 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; return unless @_; 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 reversible, # 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 = $Is_Win32 ? 0 : $wanted->{follow}; $follow = $Is_Win32 ? 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; $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS; ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; if ($Is_Win32) { $top_item =~ s|[/\\]\z|| unless $top_item =~ m{^(?:\w:)?[/\\]$}; } else { $top_item =~ s|/\z|| unless $top_item eq '/'; } $Is_Dir= 0; if ($follow) { 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)) { ($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_Win32) { $dir_pref = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? $p_dir : "$p_dir/" ); } elsif ($Is_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; 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) { die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted"; } else { # $untaint_skip == 1 next; } } } unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { warnings::warnif "Can't cd to (" . ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n"; next; } $CdLvl++; } $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 specified # (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 (thus ensuring # 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_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_Win32) { $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 ( 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; $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; 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; } } $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) { $fullname = undef; if (ref $dangling_symlinks eq 'CODE') { $dangling_symlinks->($FN, $dir_pref); } else { warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; } } else { $fullname = $loc_pref . $FN; } $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; $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 ( 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' ) { # RT #122547 my %valid_options = map {$_ => 1} qw( wanted bydepth preprocess postprocess follow follow_fast follow_skip dangling_symlinks no_chdir untaint untaint_pattern untaint_skip ); my @invalid_options = (); for my $v (keys %{$wanted}) { push @invalid_options, $v unless exists $valid_options{$v}; } warn "Invalid option(s): @invalid_options" if @invalid_options; unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) { die 'no &wanted subroutine given'; } if ( $wanted->{follow} || $wanted->{follow_fast}) { $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; } if ( $wanted->{untaint} ) { $wanted->{untaint_pattern} = $File::Find::untaint_pattern unless defined $wanted->{untaint_pattern}; $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; } return $wanted; } elsif( ref( $wanted ) eq 'CODE' ) { return { wanted => $wanted }; } else { die 'no &wanted subroutine given'; } } sub find { my $wanted = shift; _find_opt(wrap_wanted($wanted), @_); } sub finddepth { my $wanted = wrap_wanted(shift); $wanted->{bydepth} = 1; _find_opt($wanted, @_); } # default $File::Find::skip_pattern = qr/^\.{1,2}\z/; $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|; # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { $Is_VMS = 1; $File::Find::dont_use_nlink = 1; } elsif ($^O eq 'MSWin32') { $Is_Win32 = 1; } # 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' || $Is_Win32 || $^O eq 'interix' || $^O eq 'cygwin' || $^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/haiku.sh for Haiku. 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; __END__ =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 command. File::Find exports two functions, C and C. They work similarly but have subtle differences. =over 4 =item B find(\&wanted, @directories); find(\%options, @directories); C 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 into that directory and continue the search, invoking the C<&wanted> function on each file or subdirectory in the directory. =item B finddepth(\&wanted, @directories); finddepth(\%options, @directories); C works just like C except that it invokes the C<&wanted> function for a directory I 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 works from the top of the tree down. =back =head2 %options The first argument to C 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 below. Here are the possible keys for the hash: =over 3 =item C The value should be a code reference. This code reference is described in L below. The C<&wanted> subroutine is mandatory. =item C Reports the name of a directory only AFTER all its entries have been reported. Entry point C is a shortcut for specifying C<< { bydepth => 1 } >> in the first argument of C. =item C 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, but before the loop that calls the C 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 or I are in effect, C is a no-op. =item C 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 or I are in effect, C is a no-op. =item C 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 L and L below. If either I or I is in effect: =over 6 =item * It is guaranteed that an I has been called before the user's C function is called. This enables fast file checks involving C<_>. Note that this guarantee no longer holds if I or I 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. =back This is a no-op on Win32. =item C This is similar to I 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 function) is worse than just taking time, the option I should be used. This is also a no-op on Win32. =item C C, 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 causes File::Find to die if any file is about to be processed a second time. C causes File::Find to ignore any duplicate files and directories but to proceed normally otherwise. =item C Specifies what to do with symbolic links whose target doesn't exist. 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, a warning of the form C<"symbolic_link_name is a dangling symbolic link\n"> will be issued. If false, the dangling symbolic link will be silently ignored. =item C Does not C to each directory as it recurses. The C 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 If find is used in L (-T command line switch or if EUID != UID or if EGID != GID), then internally directory names have to be untainted before they can be C'd to. Therefore they are checked against a regular expression I. Note that all names passed to the user's C function are still tainted. If this option is used while not in taint-mode, C is a no-op. =item C See above. This should be set using the C quoting operator. The default is set to C. Note that the parentheses are vital. =item C If set, a directory which fails the I is skipped, including all its sub-directories. The default is to C in such a case. =back =head2 The wanted function The C function does whatever verifications you want on each file and directory. Note that despite its name, the C function is a generic callback function, and does B 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 affecting data outside of the wanted function. For example, when examining the file F 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 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 or C 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 was specified. Unless C or C 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 tool (distributed as part of the App-find2perl CPAN distribution), 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: the C<_> is a magical filehandle that caches the information from the preceding C, C, 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"; } Note that you may mix directories and (non-directory) files in the list of directories to be searched by the C function. find(\&wanted, "./foo", "./bar", "./baz/epsilon"); In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be evaluated by C. See also the script C 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 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 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 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 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 BUGS AND CAVEATS Despite the name of the C function, both C and C perform a depth-first search of the directory hierarchy. =head1 HISTORY File::Find used to produce incorrect results if called recursively. During the development of perl 5.8 this bug was fixed. The first fixed version of File::Find was 1.01. =head1 SEE ALSO L, find2perl. =cut Compare.pm000064400000010354152342777310006506 0ustar00package File::Compare; use 5.006; use strict; use warnings; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); require Exporter; $VERSION = '1.1006'; @ISA = qw(Exporter); @EXPORT = qw(compare); @EXPORT_OK = qw(cmp compare_text); $Too_Big = 1024 * 1024 * 2; sub croak { require Carp; goto &Carp::croak; } sub compare { croak("Usage: compare( file1, file2 [, buffersize]) ") unless(@_ == 2 || @_ == 3); my ($from,$to,$size) = @_; my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); my ($fromsize,$closefrom,$closeto); local (*FROM, *TO); croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); if (ref($from) && (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { *FROM = *$from; } elsif (ref(\$from) eq 'GLOB') { *FROM = $from; } else { open(FROM,"<",$from) or goto fail_open1; unless ($text_mode) { binmode FROM; $fromsize = -s FROM; } $closefrom = 1; } if (ref($to) && (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { *TO = *$to; } elsif (ref(\$to) eq 'GLOB') { *TO = $to; } else { open(TO,"<",$to) or goto fail_open2; binmode TO unless $text_mode; $closeto = 1; } if (!$text_mode && $closefrom && $closeto) { # If both are opened files we know they differ if their size differ goto fail_inner if $fromsize != -s TO; } if ($text_mode) { local $/ = "\n"; my ($fline,$tline); while (defined($fline = )) { goto fail_inner unless defined($tline = ); 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 = ); } 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 DosGlob.pm000064400000017472152343532150006451 0ustar00#!perl -w # # Documentation at the __END__ # package File::DosGlob; our $VERSION = '1.12'; use strict; use warnings; require XSLoader; XSLoader::load(); sub doglob { my $cond = shift; my @retval = (); my $fix_drive_relative_paths; 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 . "./"; $fix_drive_relative_paths = 1; } if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { ($head, $sepchr, $tail) = ($1,$2,$3); 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; # VMS-format filespecs, especially if they contain extended characters, # are unlikely to match patterns correctly, so Unixify them. if ($^O eq 'VMS') { require VMS::Filespec; @leaves = map {$_ =~ s/\.$//; VMS::Filespec::unixify($_)} @leaves; } $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; 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; } if ($fix_drive_relative_paths) { s|^([A-Za-z]:)\./|$1| for @retval; } return @retval; } # # this can be used to override CORE::glob in a specific # package by saying C in that # namespace. # # context (keyed by second cxix arg provided by core) our %entries; sub glob { my($pat,$cxix) = ($_[0], _callsite()); my @pat; # glob without args defaults to $_ $pat = $_ unless defined $pat; # if we're just beginning, do it all first if (!$entries{$cxix}) { # 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 easiest way, not nearly the best. REHASH: { my @appendpat = (); for (@pat) { # There must be a "," I.E. abc{efg} is not what we want. while ( /^(.*)(?; # 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 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, or C. The argument is tokenized using C, so see L for details of the quoting rules used. Extending it to csh patterns is left as an exercise to the reader. =head1 EXPORTS (by request only) glob() =head1 BUGS Should probably be built into the core, and needs to stop pandering to DOS habits. Needs a dose of optimization too. =head1 AUTHOR Gurusamy Sarathy =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 Glob.pm000064400000031533152343532150005775 0ustar00package File::Glob; use strict; our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS); require XSLoader; @ISA = qw(Exporter); # NOTE: The glob() export is only here for compatibility with 5.6.0. # csh_glob() should not be used directly, unless you know what you're doing. %EXPORT_TAGS = ( 'glob' => [ qw( GLOB_ABEND GLOB_ALPHASORT GLOB_ALTDIRFUNC GLOB_BRACE GLOB_CSH GLOB_ERR GLOB_ERROR GLOB_LIMIT GLOB_MARK GLOB_NOCASE GLOB_NOCHECK GLOB_NOMAGIC GLOB_NOSORT GLOB_NOSPACE GLOB_QUOTE GLOB_TILDE bsd_glob glob ) ], ); $EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}]; pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); $VERSION = '1.28'; sub import { require Exporter; local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; Exporter::import(grep { my $passthrough; if ($_ eq ':case') { $DEFAULT_FLAGS &= ~GLOB_NOCASE() } elsif ($_ eq ':nocase') { $DEFAULT_FLAGS |= GLOB_NOCASE(); } elsif ($_ eq ':globally') { no warnings 'redefine'; *CORE::GLOBAL::glob = \&File::Glob::csh_glob; } elsif ($_ eq ':bsd_glob') { no strict; *{caller."::glob"} = \&bsd_glob_override; $passthrough = 1; } else { $passthrough = 1; } $passthrough; } @_); } XSLoader::load(); $DEFAULT_FLAGS = GLOB_CSH(); if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) { $DEFAULT_FLAGS |= GLOB_NOCASE(); } # File::Glob::glob() is deprecated because its prototype is different from # CORE::glob() (use bsd_glob() instead) sub glob { use 5.024; use warnings (); warnings::warnif (deprecated => "File::Glob::glob() will disappear in perl 5.30. " . "Use File::Glob::bsd_glob() instead.") unless state $warned ++; splice @_, 1; # no flags goto &bsd_glob; } 1; __END__ =head1 NAME File::Glob - Perl extension for BSD glob routine =head1 SYNOPSIS use File::Glob ':bsd_glob'; @list = bsd_glob('*.[ch]'); $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); if (GLOB_ERROR) { # an error occurred reading $homedir } ## override the core glob (CORE::glob() does this automatically ## by default anyway, since v5.6.0) use File::Glob ':globally'; my @sources = <*.{c,h,y}>; ## override the core glob, forcing case sensitivity use File::Glob qw(:globally :case); my @sources = <*.{c,h,y}>; ## override the core glob forcing case insensitivity use File::Glob qw(:globally :nocase); my @sources = <*.{c,h,y}>; ## glob on all files in home directory use File::Glob ':globally'; my @sources = <~gnat/*>; =head1 DESCRIPTION The glob angle-bracket operator C<< <> >> is a pathname generator that implements the rules for file name pattern matching used by Unix-like shells such as the Bourne shell or C shell. File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). bsd_glob() takes a mandatory C argument, and an optional C argument, and returns a list of filenames matching the pattern, with interpretation of the pattern modified by the C variable. Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). Note that they don't share the same prototype--CORE::glob() only accepts a single argument. Due to historical reasons, CORE::glob() will also split its argument on whitespace, treating it as multiple patterns, whereas bsd_glob() considers them as one pattern. But see C<:bsd_glob> under L, below. =head2 META CHARACTERS \ Quote the next metacharacter [] Character class {} Multiple pattern * Match any string of characters ? Match any single character ~ User name home directory The metanotation C is a shorthand for C. Left to right order is preserved, with results of matches being sorted separately at a low level to preserve this order. As a special case C<{>, C<}>, and C<{}> are passed undisturbed. =head2 EXPORTS See also the L below, which can be exported individually. =head3 C<:bsd_glob> The C<:bsd_glob> export tag exports bsd_glob() and the constants listed below. It also overrides glob() in the calling package with one that behaves like bsd_glob() with regard to spaces (the space is treated as part of a file name), but supports iteration in scalar context; i.e., it preserves the core function's feature of returning the next item each time it is called. =head3 C<:glob> The C<:glob> tag, now discouraged, is the old version of C<:bsd_glob>. It exports the same constants and functions, but its glob() override does not support iteration; it returns the last file name in scalar context. That means this will loop forever: use File::Glob ':glob'; while (my $file = <* copy.txt>) { ... } =head3 C This function, which is included in the two export tags listed above, takes one or two arguments. The first is the glob pattern. The second, if given, is a set of flags ORed together. The available flags and the default set of flags are listed below under L. Remember that to use the named constants for flags you must import them, for example with C<:bsd_glob> described above. If not imported, and C is not in effect, then the constants will be treated as bareword strings, which won't do what you what. =head3 C<:nocase> and C<:case> These two export tags globally modify the default flags that bsd_glob() and, except on VMS, Perl's built-in C operator use. C is turned on or off, respectively. =head3 C The csh_glob() function can also be exported, but you should not use it directly unless you really know what you are doing. It splits the pattern into words and feeds each one to bsd_glob(). Perl's own glob() function uses this internally. =head2 POSIX FLAGS If no flags argument is give then C is set, and on VMS and Windows systems, C too. Otherwise the flags to use are determined solely by the flags argument. The POSIX defined flags are: =over 4 =item C Force bsd_glob() to return an error when it encounters a directory it cannot open or read. Ordinarily bsd_glob() continues to find matches. =item C Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands to a size bigger than the system constant C (usually found in limits.h). If your system does not define this constant, bsd_glob() uses C or C<_POSIX_ARG_MAX> where available (in that order). You can inspect these values using the standard C extension. =item C Each pathname that is a directory that matches the pattern has a slash appended. =item C By default, file names are assumed to be case sensitive; this flag makes bsd_glob() treat case differences as not significant. =item C If the pattern does not match any pathname, then bsd_glob() returns a list consisting of only the pattern. If C is set, its effect is present in the pattern returned. =item C By default, the pathnames are sorted in ascending ASCII order; this flag prevents that sorting (speeding up bsd_glob()). =back The FreeBSD extensions to the POSIX standard are the following flags: =over 4 =item C Pre-process the string to expand C<{pat,pat,...}> strings like csh(1). The pattern '{}' is left unexpanded for historical reasons (and csh(1) does the same thing to ease typing of find(1) patterns). =item C Same as C but it only returns the pattern if it does not contain any of the special characters "*", "?" or "[". C is provided to simplify implementing the historic csh(1) globbing behaviour and should probably not be used anywhere else. =item C Use the backslash ('\') character for quoting: every occurrence of a backslash followed by a character in the pattern is replaced by that character, avoiding any special interpretation of the character. (But see below for exceptions on DOSISH systems). =item C Expand patterns that start with '~' to user name home directories. =item C For convenience, C is a synonym for C. =back The POSIX provided C, C, and the FreeBSD extensions C, and C flags have not been implemented in the Perl version because they involve more complex interaction with the underlying C structures. The following flag has been added in the Perl implementation for csh compatibility: =over 4 =item C If C is not in effect, sort filenames is alphabetical order (case does not matter) rather than in ASCII order. =back =head1 DIAGNOSTICS bsd_glob() returns a list of matching paths, possibly zero length. If an error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, or one of the following values otherwise: =over 4 =item C An attempt to allocate memory failed. =item C The glob was stopped because an error was encountered. =back In the case where bsd_glob() has found some matching paths, but is interrupted by an error, it will return a list of filenames B set &File::Glob::ERROR. Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour by not considering C and C as errors - bsd_glob() will continue processing despite those errors, unless the C flag is set. Be aware that all filenames returned from File::Glob are tainted. =head1 NOTES =over 4 =item * If you want to use multiple patterns, e.g. C, you should probably throw them in a set as in C. This is because the argument to bsd_glob() isn't subjected to parsing by the C shell. Remember that you can use a backslash to escape things. =item * On DOSISH systems, backslash is a valid directory separator character. In this case, use of backslash as a quoting character (via GLOB_QUOTE) interferes with the use of backslash as a directory separator. The best (simplest, most portable) solution is to use forward slashes for directory separators, and backslashes for quoting. However, this does not match "normal practice" on these systems. As a concession to user expectation, therefore, backslashes (under GLOB_QUOTE) only quote the glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. All other backslashes are passed through unchanged. =item * Win32 users should use the real slash. If you really want to use backslashes, consider using Sarathy's File::DosGlob, which comes with the standard Perl distribution. =back =head1 SEE ALSO L, glob(3) =head1 AUTHOR The Perl interface was written by Nathan Torkington Egnat@frii.comE, and is released under the artistic license. Further modifications were made by Greg Bacon Egbacon@cs.uah.eduE, Gurusamy Sarathy Egsar@activestate.comE, and Thomas Wegner Ewegner_thomas@yahoo.comE. The C glob code has the following copyright: Copyright (c) 1989, 1993 The Regents of the University of California. All rights reserved. This code is derived from software contributed to Berkeley by Guido van Rossum. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: =over 4 =item 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. =item 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. =item 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. =back THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =cut DosGlob/DosGlob.so000075500000017120152343721440010002 0ustar00ELF>@@8 @ h h h   888$$p p p Stdp p p PtdT T T 44QtdRtdh h h GNU1vCP g> @  BE|8{qX  e, F"| 0  ` $ __gmon_start___ITM_deregisterTMCloneTable_ITM_registerTMCloneTable__cxa_finalizelibpthread.so.0Perl_hv_common_key_lenPerl_get_hvPerl_newSVpvnPerl_sv_2mortalboot_File__DosGlobPerl_xs_handshakePerl_newXS_deffilePerl_my_cxt_initPerl_xs_boot_epiloglibperl.so.5.26libc.so.6_edata__bss_start_endGLIBC_2.2.5ui 5h @ p  x x                   HH HtH5" %# hhhhhhhhqha% D% D%} D%u D%m D%e D%] D%U D%M DH=q Hj H9tH6 Ht H=A H5: H)HHH?HHtH HtfD= u+UH= Ht H=V Id ]wUSHHt$tTHc H HH,HuHtBHT$HE1HjADXZHEHt Ht$HH[]DH5>1HHEHtff.USHHHGxHPHWxHjHcP H4RHHpH0-HHHKHcHHCHHH[]DULH1SH HH HHHUH5wHߺH5H CH HHc0 HHHHPHcHH[]HHFile::DosGlob::entries1.12v5.26.0DosGlob.cFile::DosGlob::_callsite;0 Lt zRx $FJ w?:*3$"D04\hEAD0u8H@Q8A0W AAF $kEAG [AA$EMZ lAAGNU@ x U 8 h p o`0 A  ` ooooro pGA$3a18 GA$3p1113P GA*GA$annobin gcc 8.5.0 20210514GA$plugin name: gcc-annobinGA$running gcc 8.5.0 20210514GA*GA*GA! GA*FORTIFYGA+GLIBCXX_ASSERTIONS GA*GOW*GA*cf_protectionGA+omit_frame_pointerGA+stack_clashGA!stack_realign GA*FORTIFYP GA+GLIBCXX_ASSERTIONSDosGlob.so-5.26.3-423.el8_10.x86_64.debug#57zXZִF!t/o*]?Eh=ڊ2NߵN jfy򸗨F{!> /!ܙ s`(KgKCcҁWd,_~N͜^GϣBiuX{LA:B#UgO/H$D;&X<\Tnͻ1^aa  ~0x{AZZOat"N^\ MA$ih ETÁJet `W,!)&O0D̥= ( rAt9b1`\yzHv?69r]UVfmivBo_[3 ܹ߿ʊwDM2C\x6s;_Q!'A7M@mw|5V=@8TL3x|wHbu*4{#^N:źT?%qiGcuCY~Gx@y@8 @YY ii i  kk k 888$$YYY StdYYY Ptd R R RQtdRtdii i GNU[SzRW-**E@  EGIBE|qXC^: ^qbs W 4\BpBi1lJeS 2gyIIf,  XF".Wp jp ^p  6it May 5,__gmon_start___ITM_deregisterTMCloneTable_ITM_registerTMCloneTable__cxa_finalizelibpthread.so.0strcmpPL_charclassreaddir64__lxstat64__stack_chk_fail__xstat64Perl_safesysreallocPerl_safesysmallocPerl_safesysfreesysconfPL_memory_wrapPerl_croak_nocontext__errno_locationPerl_my_strlcpy__ctype_tolower_locopendirclosedirgetpwnamqsortgetenvgetuidgetpwuidbsd_globbsd_globfreePerl_hv_common_key_lenPerl_croak_xs_usagePerl_newSVpvn_flagsPerl_newSVpvf_nocontextPerl_sv_2mortalPerl_croak_svPerl_sv_dup_incPerl_newSVPerl_sv_newmortalPerl_sv_setiv_mgstrlenPerl_sv_magicPerl_stack_growPerl_get_svPerl_sv_2iv_flagsPerl_sv_upgradePerl_av_pushPerl_block_gimmePerl_markstack_growPerl_sv_2pv_flagsmemchrPerl_av_shiftmemcpyPerl_newSV_typePerl_ck_warnerPerl_mg_getPerl_gv_add_by_typePerl_sv_catpvn_flagsPerl_sv_setpvnPerl_newSVpvnPerl_sv_free2boot_File__GlobPerl_xs_handshakePerl_newXS_deffilePerl_my_cxt_initPL_thr_keypthread_getspecificPerl_get_hvPerl_newCONSTSUBPerl_newSVivPerl_mro_method_changed_inPerl_xs_boot_epilogPerl_croaklibperl.so.5.26libc.so.6_edata__bss_start_endGLIBC_2.2.5GLIBC_2.3GLIBC_2.14GLIBC_2.4U ui oMii {ii ui oi  i @ j j j P8j PPj Phj Qj Qj Qj "Qj ,Qj 8Qj EQk RQ(k ^Q@k kQXk vQpk Qo o o o  o $o =o Am m m m m m m m  m  n  n  n  n  n (n 0n 8n @n Hn Pn Xn `n hn pn xn n n n n !n "n #n %n &n 'n (n )n *n +n ,n -n .o /o 0o 1o 2 o 3(o 40o 58o 6@o 7Ho 8Po 9Xo :`o Hho ;po <xo >o Jo ?o @o Ao Bo Co DHH!X HtH5U %U hhhhhhhhqhah Qh Ah 1h !h hhhhhhhhhhqhahQhAh1h!hhhh h!h"h#h$h%h&h'qh(ah)Qh*Ah+1h,!h-h.h/h0h1h2h3h4h5h6h7qh8ah9Qh:Ah;1h<!h=h>h?%Q D%Q D%Q D%Q D%Q D%Q D%Q D%Q D%Q D%Q D%Q D%Q D%}Q D%uQ D%mQ D%eQ D%]Q D%UQ D%MQ D%EQ D%=Q D%5Q D%-Q D%%Q D%Q D%Q D% Q D%Q D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%P D%}P D%uP D%mP D%eP D%]P D%UP D%MP D%EP D%=P D%5P D%-P D%%P D%P D%P D% P D%P D%O D%O D%O D%O DH=1P H*P H9tHO Ht H=P H5O H)HHH?HHtHO HtfD=O u+UH=O Ht H=I )dO ]wH6H?ULO SH?H6HHEu$o@HEHtUEtMH A@DA@ADDGDJ EA@A@AD9t EA@H A@DEJ A@A@D)t[][]HH $HdH%(H$1ILMDHD@Et/HL9uH$dH3 %(u0HfD@t L@HLyfHH $HdH%(H$1ILMDHD@Et/HL9uH$dH3 %(u0HfD@t L@HLfHAWAVIAUIATUHSHvAuI}HcL$HI9HIEHHHH/IMLHfuL)HL$HHH]HHL$I1MuAFAHtH9uL5AEPAEHAUL7 (H HЃL`Mt(H$HD$HHT$HpHIľHHcMH Hc 6 H@H HHoB@HRL`HPHHCHDHHD$(dH3%(u H0[]A\?ff.@AVAUATUSHHHCxH3HPHSxHSHchHH)HHH Hc 16 L4HC@#t[HHHCL$AD$ HcLlIcVuIt@IT$AD$ MeHCHH[]A\A]A^H`HSILHH5'AVfAUATUHHSH`Hcq5 LedH%(HD$X1H Ll$LHHs)D$)D$ )D$0)D$@HD$PT$CHcʅHE L)HH9~P1DHT$ HcL4L|LHHiu@II$9\$LeLHD$XdH3%(uUH`[]A\A]A^fDHE1E1t1HHD$HD$@LLHBT$I;AWAVAUIH5ATIԺUHSHHP  HP HExHHExH;HH+uHH0LH]!HExLeL}HPHUxHcHE@"<AEt>LeHD[]A\A]A^A_HH0cf LI\HI9rfDHLHH@HSI9sHbHT$ |T$ AWAVAUATUSHHHHc2 H/Ht$dH%(HD$81H HHD$HGHD$HG@"LmLuD$HD$HpH5HE1A0HjHSAYAZL8A AF uo<tk t[HHFL0MlAF u0<t, tHD$0E1L E1 u0IAMNALbDLd$0L$'tEC]?Eh=ڊ2N` Ӭ1vVQ}1}H/gؾ"^`h}|dwd}rw;gfq8Z'z^Tm%1L$JH o|m9$Bw,6ݡk y)Q^p[M$oS.@ac.HA ;z{},nD/:PܬμV8 u ]9@ӈң:77{ݦ|JB]pE.DkthL X2$+/xƏҍ 'Win32', os2 => 'OS2', VMS => 'VMS', 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', amigaos => 'AmigaOS'); my $module = $module{$^O} || 'Unix'; require "File/Spec/$module.pm"; our @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 KEnig, 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 provides convenient functional forms of these methods. =head1 METHODS =over 2 =item canonpath X 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 sections into F. This is by design. If F on your system is a symlink to F, then F is actually F, not F as a naive F<../>-removal would give you. If you want to do this kind of processing, you probably want C's C function to actually traverse the filesystem cleaning up paths like this. =item catdir X 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 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 Returns a string representation of the current directory. $curdir = File::Spec->curdir(); =item devnull X Returns a string representation of the null device. $devnull = File::Spec->devnull(); =item rootdir X Returns a string representation of the root directory. $rootdir = File::Spec->rootdir(); =item tmpdir X 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. $tmpdir = File::Spec->tmpdir(); =item updir X Returns a string representation of the parent directory. $updir = File::Spec->updir(); =item no_upwards Given a list of files in a directory (such as from C), strip out C<'.'> and C<'..'>. B This does NOT filter paths containing C<'..'>, like C<'../../../../etc/passwd'>, only literal matches to C<'.'> and C<'..'>. @paths = File::Spec->no_upwards( readdir $dirhandle ); =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 drive argument. $is_case_tolerant = File::Spec->case_tolerant(); =item file_name_is_absolute Takes as its argument a path, and returns true if it is an absolute path. $is_absolute = File::Spec->file_name_is_absolute( $path ); This does not consult the local filesystem on Unix, Win32, OS/2, or Mac OS (Classic). It does consult the working environment for VMS (see L). =item path X Takes no argument. Returns the environment variable C (or the local platform's equivalent) as a list. @PATH = File::Spec->path(); =item join X join is the same as catfile. =item splitpath X X 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 to get back a path equivalent to (usually identical to) the original path. =item splitdir X X The opposite of L. @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 X X 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 is used. If C<$base> is relative, then it is converted to absolute form using L. This means that it is taken to be relative to L. 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. This means that it is taken to be relative to L. 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 X X 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 is used. If C<$base> is relative, then it is converted to absolute form using L. This means that it is taken to be relative to L. 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. 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, L, L, L, or L. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Currently maintained by Ken Williams C<< >>. The vast majority of the code was written by Kenneth Albanowski C<< >>, Andy Dougherty C<< >>, Andreas KEnig C<< >>, Tim Bunce C<< >>. VMS support by Charles Bailey C<< >>. OS/2 support by Ilya Zakharevich C<< >>. Mac support by Paul Schinder C<< >>, and Thomas Wegner C<< >>. abs2rel() and rel2abs() written by Shigio Yamaguchi C<< >>, modified by Barrie Slaymaker C<< >>. splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. =head1 COPYRIGHT Copyright (c) 2004-2013 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 Spec/Epoc.pm000064400000003043152344761320006671 0ustar00package File::Spec::Epoc; use strict; our $VERSION = '3.74'; $VERSION =~ tr/_//d; require File::Spec::Unix; our @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 a 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 and L. This package overrides the implementation of these methods, not the semantics. =cut 1; Spec/Cygwin.pm000064400000007032152344761320007245 0ustar00package File::Spec::Cygwin; use strict; require File::Spec::Unix; our $VERSION = '3.74'; $VERSION =~ tr/_//d; our @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 and L. 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, 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 If running under taint mode, and if the environment variables are tainted, they are not used. =cut sub tmpdir { my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP'); return $cached if defined $cached; $_[0]->_cache_tmpdir( $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' ), qw 'TMPDIR TMP TEMP' ); } =item case_tolerant Override Unix. Cygwin case-tolerance depends on managed mount settings and as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, indicating the case significance when comparing file specifications. Default: 1 =cut sub case_tolerant { return 1 unless $^O eq 'cygwin' and defined &Cygwin::mount_flags; my $drive = shift; if (! $drive) { my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); my $prefix = pop(@flags); if (! $prefix || $prefix eq 'cygdrive') { $drive = '/cygdrive/c'; } elsif ($prefix eq '/') { $drive = '/c'; } else { $drive = "$prefix/c"; } } my $mntopts = Cygwin::mount_flags($drive); if ($mntopts and ($mntopts =~ /,managed/)) { return 0; } eval { local @INC = @INC; pop @INC if $INC[-1] eq '.'; require Win32API::File; } or return 1; my $osFsType = "\0"x256; my $osVolName = "\0"x256; my $ouFsFlags = 0; Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } else { return 1; } } =back =head1 COPYRIGHT Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Spec/Mac.pm000064400000053402152344761320006507 0ustar00package File::Spec::Mac; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.74'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); 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 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 Beginning with version 1.3 of this module, the resulting path is relative by default and I absolute. This decision was made due to portability reasons. Since Ccatdir()> 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. 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 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; 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 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 L ). 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. =item 7. Passing an empty string "" as the first argument to C is like passingCrootdir()> as the first argument, i.e. catdir("","a","b") is the same as catdir(rootdir(),"a","b"). This is true on Unix, where C yields "/a/b" and C is "/". Note that C 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 L. 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 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 (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 is still suitable for the concatenation of I, you are encouraged to use C to concatenate I and I. 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 by default, but can be forced to be absolute (but avoid this). B Beginning with version 1.3 of this module, the resulting path is relative by default and I absolute. This decision was made due to portability reasons. Since Ccatfile()> 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 uses C (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 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, I and I, you are encouraged to use C (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 the empty string. Mac OS has no real root directory. =cut sub rootdir { '' } =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 sub tmpdir { my $cached = $_[0]->_cached_tmpdir('TMPDIR'); return $cached if defined $cached; $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), '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 a leading ":". Empty portions are returned as empty string ''. The results can be passed to C 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. @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 otherwise. Unlike just splitting the directories on the separator, empty directory names (C<"">) can be returned. Since C 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. 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. 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 = Cwd::getcwd(); } 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. 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 = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute($base) ) { $base = $self->rel2abs($base) ; } # Split up paths # ignore $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. Mac OS support by Paul Schinder and Thomas Wegner . =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 and L. This package overrides the implementation of these methods, not the semantics. =cut 1; Spec/Win32.pm000064400000025721152344761320006714 0ustar00package File::Spec::Win32; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.74'; $VERSION =~ tr/_//d; our @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). If running under taint mode, and if the environment variables are tainted, they are not used. =cut sub tmpdir { my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP)); return $tmpdir if defined $tmpdir; $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), 'SYS:/temp', 'C:\system\temp', 'C:/temp', '/tmp', '/' ); $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP)); } =item case_tolerant MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, indicating the case significance when comparing file specifications. Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. See http://cygwin.com/ml/cygwin/2007-07/msg00891.html Default: 1 =cut sub case_tolerant { eval { local @INC = @INC; pop @INC if $INC[-1] eq '.'; require Win32API::File; } or return 1; my $drive = shift || "C:"; my $osFsType = "\0"x256; my $osVolName = "\0"x256; my $ouFsFlags = 0; Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } else { return 1; } } =item file_name_is_absolute As of right now, this returns 2 if the path is absolute with a volume, 1 if it's absolute with no volume, 0 otherwise. =cut sub file_name_is_absolute { my ($self,$file) = @_; if ($file =~ m{^($VOL_RX)}o) { my $vol = $1; return ($vol =~ m{^$UNC_RX}o ? 2 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 : 0); } return $file =~ m{^[\\/]} ? 1 : 0; } =item catfile Concatenate one or more directory names and a filename to form a complete path ending with a filename =cut sub catfile { shift; # Legacy / compatibility support # shift, return _canon_cat( "/", @_ ) if $_[0] eq ""; # Compatibility with File::Spec <= 3.26: # catfile('A:', 'foo') should return 'A:\foo'. return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) if $_[0] =~ m{^$DRIVE_RX\z}o; return _canon_cat( @_ ); } sub catdir { shift; # Legacy / compatibility support # return "" unless @_; shift, return _canon_cat( "/", @_ ) if $_[0] eq ""; # Compatibility with File::Spec <= 3.26: # catdir('A:', 'foo') should return 'A:\foo'. return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) if $_[0] =~ m{^$DRIVE_RX\z}o; return _canon_cat( @_ ); } sub path { my @path = split(';', $ENV{PATH}); s/"//g for @path; @path = grep length, @path; unshift(@path, "."); return @path; } =item canonpath No physical check on the filesystem, but a logical cleanup of a path. On UNIX eliminated successive slashes and successive "/.". On Win32 makes dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even dir1\dir2\dir3\...\dir4 -> \dir\dir4 =cut sub canonpath { # Legacy / compatibility support # return $_[1] if !defined($_[1]) or $_[1] eq ''; return _canon_cat( $_[1] ); } =item splitpath ($volume,$directories,$file) = File::Spec->splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); Splits a path into volume, directory, and filename portions. Assumes that the last file is a path unless the path ends in '\\', '\\.', '\\..' or $no_file is true. On Win32 this means that $no_file true makes this return ( $volume, $path, '' ). Separators accepted are \ and /. Volumes can be drive letters or UNC sharenames (\\server\share). The results can be passed to L 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. @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( Cwd::getcwd() ))[0]; return $self->canonpath( $vol . $path ); } if ( !defined( $base ) || $base eq '' ) { $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; $base = Cwd::getcwd() 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 and L. This package overrides the implementation of these methods, not the semantics. =cut sub _canon_cat # @path -> path { my ($first, @rest) = @_; my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter ? ucfirst( $1 ).( $2 ? "\\" : "" ) : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) (?: [\\/] ([^\\/]+) )? [\\/]? }{}xs # UNC volume ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" : $first =~ s{ \A [\\/] }{}x # root dir ? "\\" : ""; my $path = join "\\", $first, @rest; $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy # xx/././yy --> xx/yy $path =~ s{(?: (?:\A|\\) # at begin or after a slash \. (?:\\\.)* # and more (?:\\|\z) # at end or followed by slash )+ # performance boost -- I do not know why }{\\}gx; # XXX I do not know whether more dots are supported by the OS supporting # this ... annotation (NetWare or symbian but not MSWin32). # Then .... could easily become ../../.. etc: # Replace \.\.\. by (\.\.\.+) and substitute with # { $1 . ".." . "\\.." x (length($2)-2) }gex # ... --> ../.. $path =~ s{ (\A|\\) # at begin or after a slash \.\.\. (?=\\|\z) # at end or followed by slash }{$1..\\..}gx; # xx\yy\..\zz --> xx\zz while ( $path =~ s{(?: (?:\A|\\) # at begin or after a slash [^\\]+ # rip this 'yy' off \\\.\. (? xx NOTE: this is *not* root $path =~ s#\\\z##; # xx\ --> xx if ( $volume =~ m#\\\z# ) { # \.. --> \ $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; Spec/AmigaOS.pm000064400000001726152344761320007271 0ustar00package File::Spec::AmigaOS; use strict; require File::Spec::Unix; our $VERSION = '3.74'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); =head1 NAME File::Spec::AmigaOS - File::Spec for AmigaOS =head1 SYNOPSIS require File::Spec::AmigaOS; # Done automatically by File::Spec # if needed =head1 DESCRIPTION Methods for manipulating file specifications. =head1 METHODS =over 2 =item tmpdir Returns $ENV{TMPDIR} or if that is unset, "/t". =cut my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/t" ); } =item file_name_is_absolute Returns true if there's a colon in the file name, or if it begins with a slash. =cut sub file_name_is_absolute { my ($self, $file) = @_; # Not 100% robust as a "/" must not preceded a ":" # but this cannot happen in a well formed path. return $file =~ m{^/|:}s; } =back All the other methods are from L. =cut 1; Spec/Functions.pm000064400000004454152344761320007762 0ustar00package File::Spec::Functions; use File::Spec; use strict; our $VERSION = '3.74'; $VERSION =~ tr/_//d; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw( canonpath catdir catfile curdir rootdir updir no_upwards file_name_is_absolute path ); our @EXPORT_OK = qw( devnull tmpdir splitpath splitdir catpath abs2rel rel2abs case_tolerant ); our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); require File::Spec::Unix; my %udeps = ( canonpath => [], catdir => [qw(canonpath)], catfile => [qw(canonpath catdir)], case_tolerant => [], curdir => [], devnull => [], rootdir => [], updir => [], ); foreach my $meth (@EXPORT, @EXPORT_OK) { my $sub = File::Spec->can($meth); no strict 'refs'; if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) && !(grep { File::Spec->can($_) != File::Spec::Unix->can($_) } @{$udeps{$meth}}) && defined(&{"File::Spec::Unix::_fn_$meth"})) { *{$meth} = \&{"File::Spec::Unix::_fn_$meth"}; } else { *{$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, which contains the entire set, and which is inherited by the modules for other platforms. For further information, please see L, L, L, or L. =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 Spec/Unix.pm000064400000037021152344761320006731 0ustar00package File::Spec::Unix; use strict; use Cwd (); our $VERSION = '3.74'; $VERSION =~ tr/_//d; =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 sections into F. This is by design. If F on your system is a symlink to F, then F is actually F, not F as a naive F<../>-removal would give you. If you want to do this kind of processing, you probably want C's C function to actually traverse the filesystem cleaning up paths like this. =cut sub _pp_canonpath { my ($self,$path) = @_; return unless defined $path; # Handle POSIX-style node names beginning with double slash (qnx, nto) # (POSIX says: "a pathname that begins with two successive slashes # may be interpreted in an implementation-defined manner, although # more than two leading slashes shall be treated as a single slash.") my $node = ''; my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; if ( $double_slashes_special && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { $node = $1; } # This used to be # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail # (Mainly because trailing "" directories didn't get stripped). # Why would cygwin avoid collapsing multiple slashes into one? --jhi $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx $path =~ s|^/\.\.$|/|; # /.. -> / $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx return "$node$path"; } *canonpath = \&_pp_canonpath unless defined &canonpath; =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 _pp_catdir { my $self = shift; $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' } *catdir = \&_pp_catdir unless defined &catdir; =item catfile Concatenate one or more directory names and a filename to form a complete path ending with a filename =cut sub _pp_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; } *catfile = \&_pp_catfile unless defined &catfile; =item curdir Returns a string representation of the current directory. "." on UNIX. =cut sub curdir { '.' } use constant _fn_curdir => "."; =item devnull Returns a string representation of the null device. "/dev/null" on UNIX. =cut sub devnull { '/dev/null' } use constant _fn_devnull => "/dev/null"; =item rootdir Returns a string representation of the root directory. "/" on UNIX. =cut sub rootdir { '/' } use constant _fn_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 If running under taint mode, and if $ENV{TMPDIR} is tainted, it is not used. =cut my ($tmpdir, %tmpenv); # Cache and return the calculated tmpdir, recording which env vars # determined it. sub _cache_tmpdir { @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; return $tmpdir = $_[1]; } # Retrieve the cached tmpdir, checking first whether relevant env vars have # changed and invalidated the cache. sub _cached_tmpdir { shift; local $^W; return if grep $ENV{$_} ne $tmpenv{$_}, @_; return $tmpdir; } sub _tmpdir { my $self = shift; my @dirlist = @_; my $taint = do { no strict 'refs'; ${"\cTAINT"} }; if ($taint) { # Check for taint mode on perl >= 5.8.0 require Scalar::Util; @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; } elsif ($] < 5.007) { # No ${^TAINT} before 5.8 @dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } } @dirlist; } foreach (@dirlist) { next unless defined && -d && -w _; $tmpdir = $_; last; } $tmpdir = $self->curdir unless defined $tmpdir; $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); if ( !$self->file_name_is_absolute($tmpdir) ) { # See [perl #120593] for the full details # If possible, return a full path, rather than '.' or 'lib', but # jump through some hoops to avoid returning a tainted value. ($tmpdir) = grep { $taint ? ! Scalar::Util::tainted($_) : $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 } $self->rel2abs($tmpdir), $tmpdir; } return $tmpdir; } sub tmpdir { my $cached = $_[0]->_cached_tmpdir('TMPDIR'); return $cached if defined $cached; $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); } =item updir Returns a string representation of the parent directory. ".." on UNIX. =cut sub updir { '..' } use constant _fn_updir => ".."; =item no_upwards Given a list of file names, strip out those that refer to a parent directory. (Does not strip symlinks, only '.', '..', and equivalents.) =cut sub no_upwards { my $self = shift; return grep(!/^\.{1,2}\z/s, @_); } =item case_tolerant Returns a true or false value indicating, respectively, that alphabetic is not or is significant when comparing file specifications. =cut sub case_tolerant { 0 } use constant _fn_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). =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 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. @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 is used. If $base is relative, then it is converted to absolute form using L. This means that it is taken to be relative to L. 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. This means that it is taken to be relative to L. No checks against the filesystem are made, so the result may not be correct if C<$base> contains symbolic links. (Apply L beforehand if that is a concern.) 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 = Cwd::getcwd() unless defined $base and length $base; ($path, $base) = map $self->canonpath($_), $path, $base; my $path_directories; my $base_directories; if (grep $self->file_name_is_absolute($_), $path, $base) { ($path, $base) = map $self->rel2abs($_), $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; $path_directories = ($self->splitpath($path, 1))[1]; $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; } } else { my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1]; $path_directories = $self->catdir($wd, $path); $base_directories = $self->catdir($wd, $base); } # 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) { return $self->curdir if $path_directories eq $self->rootdir; shift @pathchunks; return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); } my @common; while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { push @common, shift @pathchunks ; shift @basechunks ; } return $self->curdir unless @pathchunks || @basechunks; # @basechunks now contains the directories the resulting relative path # must ascend out of before it can descend to $path_directory. If there # are updir components, we must descend into the corresponding directories # (this only works if they are no symlinks). my @reverse_base; while( defined(my $dir= shift @basechunks) ) { if( $dir ne $self->updir ) { unshift @reverse_base, $self->updir; push @common, $dir; } elsif( @common ) { if( @reverse_base && $reverse_base[0] eq $self->updir ) { shift @reverse_base; pop @common; } else { unshift @reverse_base, pop @common; } } } my $result_dirs = $self->catdir( @reverse_base, @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 is used. If $base is relative, then it is converted to absolute form using L. This means that it is taken to be relative to L. 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. 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 = Cwd::getcwd(); } 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. Please submit bug reports and patches to perlbug@perl.org. =head1 SEE ALSO L =cut # 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; Spec/OS2.pm000064400000015156152344761320006416 0ustar00package File::Spec::OS2; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.74'; $VERSION =~ tr/_//d; our @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 tmpdir { my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); return $cached if defined $cached; my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy $_[0]->_cache_tmpdir( $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP 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 = Cwd::getcwd(); } 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 = Cwd::getcwd(); } 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 and L. 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 Developers.pod000064400000050166152345131700007371 0ustar00=head1 NAME DBD::File::Developers - Developers documentation for DBD::File =head1 SYNOPSIS package DBD::myDriver; use base qw( DBD::File ); sub driver { ... my $drh = $proto->SUPER::driver ($attr); ... return $drh->{class}; } sub CLONE { ... } package DBD::myDriver::dr; @ISA = qw( DBD::File::dr ); sub data_sources { ... } ... package DBD::myDriver::db; @ISA = qw( DBD::File::db ); sub init_valid_attributes { ... } sub init_default_attributes { ... } sub set_versions { ... } sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } sub get_myd_versions { ... } package DBD::myDriver::st; @ISA = qw( DBD::File::st ); sub FETCH { ... } sub STORE { ... } package DBD::myDriver::Statement; @ISA = qw( DBD::File::Statement ); package DBD::myDriver::Table; @ISA = qw( DBD::File::Table ); my %reset_on_modify = ( myd_abc => "myd_foo", myd_mno => "myd_bar", ); __PACKAGE__->register_reset_on_modify (\%reset_on_modify); my %compat_map = ( abc => 'foo_abc', xyz => 'foo_xyz', ); __PACKAGE__->register_compat_map (\%compat_map); sub bootstrap_table_meta { ... } sub init_table_meta { ... } sub table_meta_attr_changed { ... } sub open_data { ... } sub fetch_row { ... } sub push_row { ... } sub push_names { ... } # optimize the SQL engine by add one or more of sub update_current_row { ... } # or sub update_specific_row { ... } # or sub update_one_row { ... } # or sub insert_new_row { ... } # or sub delete_current_row { ... } # or sub delete_one_row { ... } =head1 DESCRIPTION This document describes how DBD developers can write DBD::File based DBI drivers. It supplements L and L, which you should read first. =head1 CLASSES Each DBI driver must provide a package global C method and three DBI related classes: =over 4 =item DBD::File::dr Driver package, contains the methods DBI calls indirectly via DBI interface: DBI->connect ('DBI:DBM:', undef, undef, {}) # invokes package DBD::DBM::dr; @DBD::DBM::dr::ISA = qw( DBD::File::dr ); sub connect ($$;$$$) { ... } Similar for C<< data_sources >> and C<< disconnect_all >>. Pure Perl DBI drivers derived from DBD::File do not usually need to override any of the methods provided through the DBD::XXX::dr package however if you need additional initialization in the connect method you may need to. =item DBD::File::db Contains the methods which are called through DBI database handles (C<< $dbh >>). e.g., $sth = $dbh->prepare ("select * from foo"); # returns the f_encoding setting for table foo $dbh->csv_get_meta ("foo", "f_encoding"); DBD::File provides the typical methods required here. Developers who write DBI drivers based on DBD::File need to override the methods C<< set_versions >> and C<< init_valid_attributes >>. =item DBD::File::st Contains the methods to deal with prepared statement handles. e.g., $sth->execute () or die $sth->errstr; =back =head2 DBD::File This is the main package containing the routines to initialize DBD::File based DBI drivers. Primarily the C<< DBD::File::driver >> method is invoked, either directly from DBI when the driver is initialized or from the derived class. package DBD::DBM; use base qw( DBD::File ); sub driver { my ($class, $attr) = @_; ... my $drh = $class->SUPER::driver ($attr); ... return $drh; } It is not necessary to implement your own driver method as long as additional initialization (e.g. installing more private driver methods) is not required. You do not need to call C<< setup_driver >> as DBD::File takes care of it. =head2 DBD::File::dr The driver package contains the methods DBI calls indirectly via the DBI interface (see L). DBD::File based DBI drivers usually do not need to implement anything here, it is enough to do the basic initialization: package DBD:XXX::dr; @DBD::XXX::dr::ISA = qw (DBD::File::dr); $DBD::XXX::dr::imp_data_size = 0; $DBD::XXX::dr::data_sources_attr = undef; $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; =head2 DBD::File::db This package defines the database methods, which are called via the DBI database handle C<< $dbh >>. Methods provided by DBD::File: =over 4 =item ping Simply returns the content of the C<< Active >> attribute. Override when your driver needs more complicated actions here. =item prepare Prepares a new SQL statement to execute. Returns a statement handle, C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor recommended to override this method. =item FETCH Fetches an attribute of a DBI database object. Private handle attributes must have a prefix (this is mandatory). If a requested attribute is detected as a private attribute without a valid prefix, the driver prefix (written as C<$drv_prefix>) is added. The driver prefix is extracted from the attribute name and verified against C<< $dbh->{$drv_prefix . "valid_attrs"} >> (when it exists). If the requested attribute value is not listed as a valid attribute, this method croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ $drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the attribute value is returned. So it's not possible to modify C from outside of DBD::File::db or a derived class. =item STORE Stores a database private attribute. Private handle attributes must have a prefix (this is mandatory). If a requested attribute is detected as a private attribute without a valid prefix, the driver prefix (written as C<$drv_prefix>) is added. If the database handle has an attribute C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in that hash, this method croaks. If the database handle has an attribute C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there can be stored (once they are initialized). Trying to overwrite such an immutable attribute forces this method to croak. An example of a valid attributes list can be found in C<< DBD::File::db::init_valid_attributes >>. =item set_versions This method sets the attribute C with the version of DBD::File. This method is called at the begin of the C phase. When overriding this method, do not forget to invoke the superior one. =item init_valid_attributes This method is called after the database handle is instantiated as the first attribute initialization. C<< DBD::File::db::init_valid_attributes >> initializes the attributes C and C. When overriding this method, do not forget to invoke the superior one, preferably before doing anything else. Compatibility table attribute access must be initialized here to allow DBD::File to instantiate the map tie: # for DBD::CSV $dbh->{csv_meta} = "csv_tables"; # for DBD::DBM $dbh->{dbm_meta} = "dbm_tables"; # for DBD::AnyData $dbh->{ad_meta} = "ad_tables"; =item init_default_attributes This method is called after the database handle is instantiated to initialize the default attributes. C<< DBD::File::db::init_default_attributes >> initializes the attributes C, C, C, C. When the derived implementor class provides the attribute to validate attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} = {...}; >>), the attributes C, C, C and C are added (when available) to the list of valid and immutable attributes (where C is interpreted as the driver prefix). If C is set, an attribute with the name in C is initialized providing restricted read/write access to the meta data of the tables using C in the first (table) level and C for the meta attribute level. C uses C to initialize the second level tied hash on FETCH/STORE. The C class uses C to FETCH attribute values and C to STORE attribute values. This allows it to map meta attributes for compatibility reasons. =item get_single_table_meta =item get_file_meta Retrieve an attribute from a table's meta information. The method signature is C<< get_file_meta ($dbh, $table, $attr) >>. This method is called by the injected db handle method C<< ${drv_prefix}get_meta >>. While get_file_meta allows C<$table> or C<$attr> to be a list of tables or attributes to retrieve, get_single_table_meta allows only one table name and only one attribute name. A table name of C<'.'> (single dot) is interpreted as the default table and this will retrieve the appropriate attribute globally from the dbh. This has the same restrictions as C<< $dbh->{$attrib} >>. get_file_meta allows C<'+'> and C<'*'> as wildcards for table names and C<$table> being a regular expression matching against the table names (evaluated without the default table). The table name C<'*'> is I. The table name C<'+'> is I (/^[_A-Za-z0-9]+$/). The table meta information is retrieved using the get_table_meta and get_table_meta_attr methods of the table class of the implementation. =item set_single_table_meta =item set_file_meta Sets an attribute in a table's meta information. The method signature is C<< set_file_meta ($dbh, $table, $attr, $value) >>. This method is called by the injected db handle method C<< ${drv_prefix}set_meta >>. While set_file_meta allows C<$table> to be a list of tables and C<$attr> to be a hash of several attributes to set, set_single_table_meta allows only one table name and only one attribute name/value pair. The wildcard characters for the table name are the same as for get_file_meta. The table meta information is updated using the get_table_meta and set_table_meta_attr methods of the table class of the implementation. =item clear_file_meta Clears all meta information cached about a table. The method signature is C<< clear_file_meta ($dbh, $table) >>. This method is called by the injected db handle method C<< ${drv_prefix}clear_meta >>. =back =head2 DBD::File::st Contains the methods to deal with prepared statement handles: =over 4 =item FETCH Fetches statement handle attributes. Supported attributes (for full overview see L) are C, C, C and C in case that SQL::Statement is used as SQL execution engine and a statement is successful prepared. When SQL::Statement has additional information about a table, those information are returned. Otherwise, the same defaults as in L are used. This method usually requires extending in a derived implementation. See L or L for some example. =back =head2 DBD::File::TableSource::FileSystem Provides data sources and table information on database driver and database handle level. package DBD::File::TableSource::FileSystem; sub data_sources ($;$) { my ($class, $drh, $attrs) = @_; ... } sub avail_tables { my ($class, $drh) = @_; ... } The C method is called when the user invokes any of the following: @ary = DBI->data_sources ($driver); @ary = DBI->data_sources ($driver, \%attr); @ary = $dbh->data_sources (); @ary = $dbh->data_sources (\%attr); The C method is called when the user invokes any of the following: @names = $dbh->tables ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type); $sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr); $dbh->func ("list_tables"); Every time where an C<\%attr> argument can be specified, this C<\%attr> object's C attribute is preferred over the C<$dbh> attribute or the driver default. =head2 DBD::File::DataSource::Stream package DBD::File::DataSource::Stream; @DBD::File::DataSource::Stream::ISA = 'DBI::DBD::SqlEngine::DataSource'; sub complete_table_name { my ($self, $meta, $file, $respect_case) = @_; ... } Clears all meta attributes identifying a file: C, C and C. The table name is set according to C<$respect_case> and C<< $meta->{sql_identifier_case} >> (SQL_IC_LOWER, SQL_IC_UPPER). package DBD::File::DataSource::Stream; sub apply_encoding { my ($self, $meta, $fn) = @_; ... } Applies the encoding from I (C<< $meta->{f_encoding} >>) to the file handled opened in C. package DBD::File::DataSource::Stream; sub open_data { my ($self, $meta, $attrs, $flags) = @_; ... } Opens (C) the file handle provided in C<< $meta->{f_file} >>. package DBD::File::DataSource::Stream; sub can_flock { ... } Returns whether C is available or not (avoids retesting in subclasses). =head2 DBD::File::DataSource::File package DBD::File::DataSource::File; sub complete_table_name ($$;$) { my ($self, $meta, $table, $respect_case) = @_; ... } The method C tries to map a filename to the associated table name. It is called with a partially filled meta structure for the resulting table containing at least the following attributes: C<< f_ext >>, C<< f_dir >>, C<< f_lockfile >> and C<< sql_identifier_case >>. If a file/table map can be found then this method sets the C<< f_fqfn >>, C<< f_fqbn >>, C<< f_fqln >> and C<< table_name >> attributes in the meta structure. If a map cannot be found the table name will be undef. package DBD::File::DataSource::File; sub open_data ($) { my ($self, $meta, $attrs, $flags) = @_; ... } Depending on the attributes set in the table's meta data, the following steps are performed. Unless C<< f_dontopen >> is set to a true value, C<< f_fqfn >> must contain the full qualified file name for the table to work on (file2table ensures this). The encoding in C<< f_encoding >> is applied if set and the file is opened. If C<> (full qualified lock name) is set, this file is opened, too. Depending on the value in C<< f_lock >>, the appropriate lock is set on the opened data file or lock file. =head2 DBD::File::Statement Derives from DBI::SQL::Nano::Statement to provide following method: =over 4 =item open_table Implements the open_table method required by L and L. All the work for opening the file(s) belonging to the table is handled and parametrized in DBD::File::Table. Unless you intend to add anything to the following implementation, an empty DBD::XXX::Statement package satisfies DBD::File. sub open_table ($$$$$) { my ($self, $data, $table, $createMode, $lockMode) = @_; my $class = ref $self; $class =~ s/::Statement/::Table/; my $flags = { createMode => $createMode, lockMode => $lockMode, }; $self->{command} eq "DROP" and $flags->{dropMode} = 1; return $class->new ($data, { table => $table }, $flags); } # open_table =back =head2 DBD::File::Table Derives from DBI::SQL::Nano::Table and provides physical file access for the table data which are stored in the files. =over 4 =item bootstrap_table_meta Initializes a table meta structure. Can be safely overridden in a derived class, as long as the C<< SUPER >> method is called at the end of the overridden method. It copies the following attributes from the database into the table meta data C<< f_dir >>, C<< f_ext >>, C<< f_encoding >>, C<< f_lock >>, C<< f_schema >> and C<< f_lockfile >> and makes them sticky to the table. This method should be called before you attempt to map between file name and table name to ensure the correct directory, extension etc. are used. =item init_table_meta Initializes more attributes of the table meta data - usually more expensive ones (e.g. those which require class instantiations) - when the file name and the table name could mapped. =item get_table_meta Returns the table meta data. If there are none for the required table, a new one is initialized. When it fails, nothing is returned. On success, the name of the table and the meta data structure is returned. =item get_table_meta_attr Returns a single attribute from the table meta data. If the attribute name appears in C<%compat_map>, the attribute name is updated from there. =item set_table_meta_attr Sets a single attribute in the table meta data. If the attribute name appears in C<%compat_map>, the attribute name is updated from there. =item table_meta_attr_changed Called when an attribute of the meta data is modified. If the modified attribute requires to reset a calculated attribute, the calculated attribute is reset (deleted from meta data structure) and the I flag is removed, too. The decision is made based on C<%register_reset_on_modify>. =item register_reset_on_modify Allows C to reset meta attributes when special attributes are modified. For DBD::File, modifying one of C, C, C or C will reset C. DBD::DBM extends the list for C and C to reset the value of C. If your DBD has calculated values in the meta data area, then call C: my %reset_on_modify = (xxx_foo => "xxx_bar"); __PACKAGE__->register_reset_on_modify (\%reset_on_modify); =item register_compat_map Allows C and C to update the attribute name to the current favored one: # from DBD::DBM my %compat_map = (dbm_ext => "f_ext"); __PACKAGE__->register_compat_map (\%compat_map); =item open_file Called to open the table's data file. Depending on the attributes set in the table's meta data, the following steps are performed. Unless C<< f_dontopen >> is set to a true value, C<< f_fqfn >> must contain the full qualified file name for the table to work on (file2table ensures this). The encoding in C<< f_encoding >> is applied if set and the file is opened. If C<> (full qualified lock name) is set, this file is opened, too. Depending on the value in C<< f_lock >>, the appropriate lock is set on the opened data file or lock file. After this is done, a derived class might add more steps in an overridden C<< open_file >> method. =item new Instantiates the table. This is done in 3 steps: 1. get the table meta data 2. open the data file 3. bless the table data structure using inherited constructor new It is not recommended to override the constructor of the table class. Find a reasonable place to add you extensions in one of the above four methods. =item drop Implements the abstract table method for the C<< DROP >> command. Discards table meta data after all files belonging to the table are closed and unlinked. Overriding this method might be reasonable in very rare cases. =item seek Implements the abstract table method used when accessing the table from the engine. C<< seek >> is called every time the engine uses dumb algorithms for iterating over the table content. =item truncate Implements the abstract table method used when dumb table algorithms for C<< UPDATE >> or C<< DELETE >> need to truncate the table storage after the last written row. =back You should consult the documentation of C<< SQL::Eval::Table >> (see L) to get more information about the abstract methods of the table's base class you have to override and a description of the table meta information expected by the SQL engines. =head1 AUTHOR The module DBD::File is currently maintained by H.Merijn Brand < h.m.brand at xs4all.nl > and Jens Rehsack < rehsack at googlemail.com > The original author is Jochen Wiedmann. =head1 COPYRIGHT AND LICENSE Copyright (C) 2010-2013 by H.Merijn Brand & Jens Rehsack All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =cut Roadmap.pod000064400000013473152345131700006644 0ustar00=head1 NAME DBD::File::Roadmap - Planned Enhancements for DBD::File and pure Perl DBD's Jens Rehsack - May 2010 =head1 SYNOPSIS This document gives a high level overview of the future of the DBD::File DBI driver and groundwork for pure Perl DBI drivers. The planned enhancements cover features, testing, performance, reliability, extensibility and more. =head1 CHANGES AND ENHANCEMENTS =head2 Features There are some features missing we would like to add, but there is no time plan: =over 4 =item LOCK TABLE The newly implemented internal common table meta storage area would allow us to implement LOCK TABLE support based on file system C support. =item Transaction support While DBD::AnyData recommends explicitly committing by importing and exporting tables, DBD::File might be enhanced in a future version to allow transparent transactions using the temporary tables of SQL::Statement as shadow (dirty) tables. Transaction support will heavily rely on lock table support. =item Data Dictionary Persistence SQL::Statement provides dictionary information when a "CREATE TABLE ..." statement is executed. This dictionary is preserved for some statement handle attribute fetches (as C or C). It is planned to extend DBD::File to support data dictionaries to work on the tables in it. It is not planned to support one table in different dictionaries, but you can have several dictionaries in one directory. =item SQL Engine selecting on connect Currently the SQL engine selected is chosen during the loading of the module L. Ideally end users should be able to select the engine used in C<< DBI->connect () >> with a special DBD::File attribute. =back Other points of view to the planned features (and more features for the SQL::Statement engine) are shown in L. =head2 Testing DBD::File and the dependent DBD::DBM requires a lot more automated tests covering API stability and compatibility with optional modules like SQL::Statement. =head2 Performance Several arguments for support of features like indexes on columns and cursors are made for DBD::CSV (which is a DBD::File based driver, too). Similar arguments could be made for DBD::DBM, DBD::AnyData, DBD::RAM or DBD::PO etc. To improve the performance of the underlying SQL engines, a clean re-implementation seems to be required. Currently both engines are prematurely optimized and therefore it is not trivial to provide further optimization without the risk of breaking existing features. Join the DBI developers IRC channel at L to participate or post to the DBI Developers Mailing List. =head2 Reliability DBD::File currently lacks the following points: =over 4 =item duplicate table names It is currently possible to access a table quoted with a relative path (a) and additionally using an absolute path (b). If (a) and (b) are the same file that is not recognized (except for flock protection handled by the Operating System) and two independent tables are handled. =item invalid table names The current implementation does not prevent someone choosing a directory name as a physical file name for the table to open. =back =head2 Extensibility I (Jens Rehsack) have some (partially for example only) DBD's in mind: =over 4 =item DBD::Sys Derive DBD::Sys from a common code base shared with DBD::File which handles all the emulation DBI needs (as getinfo, SQL engine handling, ...) =item DBD::Dir Provide a DBD::File derived to work with fixed table definitions through the file system to demonstrate how DBI / Pure Perl DBDs could handle databases with hierarchical structures. =item DBD::Join Provide a DBI driver which is able to manage multiple connections to other Databases (as DBD::Multiplex), but allow them to point to different data sources and allow joins between the tables of them: # Example # Let table 'lsof' being a table in DBD::Sys giving a list of open files using lsof utility # Let table 'dir' being a atable from DBD::Dir $sth = $dbh->prepare( "select * from dir,lsof where path='/documents' and dir.entry = lsof.filename" ) $sth->execute(); # gives all open files in '/documents' ... # Let table 'filesys' a DBD::Sys table of known file systems on current host # Let table 'applications' a table of your Configuration Management Database # where current applications (relocatable, with mountpoints for filesystems) # are stored $sth = dbh->prepare( "select * from applications,filesys where " . "application.mountpoint = filesys.mountpoint and ". "filesys.mounted is true" ); $sth->execute(); # gives all currently mounted applications on this host =back =head1 PRIORITIES Our priorities are focused on current issues. Initially many new test cases for DBD::File and DBD::DBM should be added to the DBI test suite. After that some additional documentation on how to use the DBD::File API will be provided. Any additional priorities will come later and can be modified by (paying) users. =head1 RESOURCES AND CONTRIBUTIONS See L for I. If your company has benefited from DBI, please consider if it could make a donation to The Perl Foundation "DBI Development" fund at L to secure future development. Alternatively, if your company would benefit from a specific new DBI feature, please consider sponsoring it's development through the options listed in the section "Commercial Support from the Author" on L. Using such targeted financing allows you to contribute to DBI development and rapidly get something specific and directly valuable to you in return. My company also offers annual support contracts for the DBI, which provide another way to support the DBI and get something specific in return. Contact me for details. Thank you. =cut HowTo.pod000064400000011624152345131700006315 0ustar00=head1 NAME DBD::File::HowTo - Guide to create DBD::File based driver =head1 SYNOPSIS perldoc DBD::File::HowTo perldoc DBI perldoc DBI::DBD perldoc DBD::File::Developers perldoc DBI::DBD::SqlEngine::Developers perldoc DBI::DBD::SqlEngine perldoc SQL::Eval perldoc DBI::DBD::SqlEngine::HowTo perldoc SQL::Statement::Embed perldoc DBD::File perldoc DBD::File::HowTo perldoc DBD::File::Developers =head1 DESCRIPTION This document provides a step-by-step guide, how to create a new C based DBD. It expects that you carefully read the L documentation and that you're familiar with L and had read and understood L. This document addresses experienced developers who are really sure that they need to invest time when writing a new DBI Driver. Writing a DBI Driver is neither a weekend project nor an easy job for hobby coders after work. Expect one or two man-month of time for the first start. Those who are still reading, should be able to sing the rules of L. Of course, DBD::File is a DBI::DBD::SqlEngine and you surely read L before continuing here. =head1 CREATING DRIVER CLASSES Do you have an entry in DBI's DBD registry? For this guide, a prefix of C is assumed. =head2 Sample Skeleton package DBD::Foo; use strict; use warnings; use vars qw(@ISA $VERSION); use base qw(DBD::File); use DBI (); $VERSION = "0.001"; package DBD::Foo::dr; use vars qw(@ISA $imp_data_size); @ISA = qw(DBD::File::dr); $imp_data_size = 0; package DBD::Foo::db; use vars qw(@ISA $imp_data_size); @ISA = qw(DBD::File::db); $imp_data_size = 0; package DBD::Foo::st; use vars qw(@ISA $imp_data_size); @ISA = qw(DBD::File::st); $imp_data_size = 0; package DBD::Foo::Statement; use vars qw(@ISA); @ISA = qw(DBD::File::Statement); package DBD::Foo::Table; use vars qw(@ISA); @ISA = qw(DBD::File::Table); 1; Tiny, eh? And all you have now is a DBD named foo which will is able to deal with temporary tables, as long as you use L. In L environments, this DBD can do nothing. =head2 Start over Based on L, we're now having a driver which could do basic things. Of course, it should now derive from DBD::File instead of DBI::DBD::SqlEngine, shouldn't it? DBD::File extends DBI::DBD::SqlEngine to deal with any kind of files. In principle, the only extensions required are to the table class: package DBD::Foo::Table; sub bootstrap_table_meta { my ( $self, $dbh, $meta, $table ) = @_; # initialize all $meta attributes which might be relevant for # file2table return $self->SUPER::bootstrap_table_meta($dbh, $meta, $table); } sub init_table_meta { my ( $self, $dbh, $meta, $table ) = @_; # called after $meta contains the results from file2table # initialize all missing $meta attributes $self->SUPER::init_table_meta( $dbh, $meta, $table ); } In case C doesn't open the files as the driver needs that, override it! sub open_file { my ( $self, $meta, $attrs, $flags ) = @_; # ensure that $meta->{f_dontopen} is set $self->SUPER::open_file( $meta, $attrs, $flags ); # now do what ever needs to be done } Combined with the methods implemented using the L guide, the table is full working and you could try a start over. =head2 User comfort C since C<0.39> consolidates all persistent meta data of a table into a single structure stored in C<< $dbh->{f_meta} >>. With C version C<0.41> and C version C<0.05>, this consolidation moves to L. It's still the C<< $dbh->{$drv_prefix . "_meta"} >> attribute which cares, so what you learned at this place before, is still valid. sub init_valid_attributes { my $dbh = $_[0]; $dbh->SUPER::init_valid_attributes (); $dbh->{foo_valid_attrs} = { ... }; $dbh->{foo_readonly_attrs} = { ... }; $dbh->{foo_meta} = "foo_tables"; return $dbh; } See updates at L. =head2 Testing Now you should have your own DBD::File based driver. Was easy, wasn't it? But does it work well? Prove it by writing tests and remember to use dbd_edit_mm_attribs from L to ensure testing even rare cases. =head1 AUTHOR This guide is written by Jens Rehsack. DBD::File is written by Jochen Wiedmann and Jeff Zucker. The module DBD::File is currently maintained by H.Merijn Brand < h.m.brand at xs4all.nl > and Jens Rehsack < rehsack at googlemail.com > =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack All rights reserved. You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in the Perl README file. =cut to_path-i.ri000064400000001567152345532360007005 0ustar00U:RDoc::AnyMethod[iI" to_path:ETI"File#to_path;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"GReturns the pathname used to create file as a string. Does ;TI"not normalize the name.;To:RDoc::Markup::BlankLineo; ; [I"JThe pathname may not point to the file corresponding to file. ;TI"DFor instance, the pathname becomes void when the file has been ;TI"moved or deleted.;T@o; ; [I"@This method raises IOError for a file created using ;TI"AFile::Constants::TMPFILE because they don't have a pathname.;T@o:RDoc::Markup::Verbatim; [I" "testfile" ;TI"BFile.new("/tmp/../tmp/xxx", "w").path #=> "/tmp/../tmp/xxx";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below000[I"();T@FI" File;TcRDoc::NormalClass0[@ FI" path;Trealpath-c.ri000064400000001316152345532360007131 0ustar00U:RDoc::AnyMethod[iI" realpath:ETI"File::realpath;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"FReturns the real (absolute) pathname of _pathname_ in the actual ;TI"8filesystem not containing symlinks or useless dots.;To:RDoc::Markup::BlankLineo; ; [I">If _dir_string_ is given, it is used as a base directory ;TI"Ifor interpreting relative pathname instead of the current directory.;T@o; ; [I"CAll components of the pathname must exist when this method is ;TI" called.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"?File.realpath(pathname [, dir_string]) -> real_pathname ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00fnmatch%3f-c.ri000064400000000407152345532360007247 0ustar00U:RDoc::AnyMethod[iI" fnmatch?:ETI"File::fnmatch?;TT: privateo:RDoc::Markup::Document: @parts[: @fileI" dir.rb;T:0@omit_headings_from_table_of_contents_below000[I"(pattern, path, flags = 0);T@ FI" File;TcRDoc::NormalClass0[@TI" fnmatch;Treadable_real%3f-c.ri000064400000001172152345532360010371 0ustar00U:RDoc::AnyMethod[iI"readable_real?:ETI"File::readable_real?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"IReturns true if the named file is readable by the real ;TI"6user and group id of this process. See access(3).;To:RDoc::Markup::BlankLineo; ; [I"MNote that some OS-level security features may cause this to return true ;TI"Aeven though the file is not readable by the real user/group.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"7File.readable_real?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00chown-i.ri000064400000001447152345532360006462 0ustar00U:RDoc::AnyMethod[iI" chown:ETI"File#chown;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"EChanges the owner and group of file to the given numeric ;TI"Howner and group id's. Only a process with superuser privileges may ;TI"Hchange the owner of a file. The current owner of a file may change ;TI"Athe file's group to any group to which the owner belongs. A ;TI"Bnil or -1 owner or group id is ignored. Follows ;TI"*symbolic links. See also File#lchown.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"*File.new("testfile").chown(502, 1000);T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I".file.chown(owner_int, group_int ) -> 0 ;T0[I" (p1, p2);T@FI" File;TcRDoc::NormalClass00birthtime-i.ri000064400000001050152345532360007321 0ustar00U:RDoc::AnyMethod[iI"birthtime:ETI"File#birthtime;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I",Returns the birth time for file.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"GFile.new("testfile").birthtime #=> Wed Apr 09 08:53:14 CDT 2003 ;T: @format0o; ; [I"HIf the platform doesn't have birthtime, raises NotImplementedError.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"file.birthtime -> time ;T0[I"();T@FI" File;TcRDoc::NormalClass00flock-i.ri000064400000003452152345532360006440 0ustar00U:RDoc::AnyMethod[iI" flock:ETI"File#flock;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [ I"ELocks or unlocks a file according to locking_constant (a ;TI"or of the values in the table below). ;TI"FReturns false if File::LOCK_NB is specified and the ;TI"Boperation would otherwise have blocked. Not available on all ;TI"platforms.;To:RDoc::Markup::BlankLineo; ; [I"'Locking constants (in class File):;T@o:RDoc::Markup::Verbatim; [I">LOCK_EX | Exclusive lock. Only one process may hold an ;TI"< | exclusive lock for a given file at a time. ;TI"A----------+------------------------------------------------ ;TI";LOCK_NB | Don't block when locking. May be combined ;TI"; | with other lock options using logical or. ;TI"A----------+------------------------------------------------ ;TI"ALOCK_SH | Shared lock. Multiple processes may each hold a ;TI"@ | shared lock for a given file at the same time. ;TI"A----------+------------------------------------------------ ;TI"LOCK_UN | Unlock. ;T: @format0o; ; [I" Example:;T@o; ; [I")# update a counter using write lock ;TI"@# don't use "w" because it truncates the file before lock. ;TI"=File.open("counter", File::RDWR|File::CREAT, 0644) {|f| ;TI" f.flock(File::LOCK_EX) ;TI" value = f.read.to_i + 1 ;TI" f.rewind ;TI" f.write("#{value}\n") ;TI" f.flush ;TI" f.truncate(f.pos) ;TI"} ;TI" ;TI"(# read the counter using read lock ;TI"$File.open("counter", "r") {|f| ;TI" f.flock(File::LOCK_SH) ;TI" p f.read ;TI"};T; 0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"0file.flock(locking_constant) -> 0 or false ;T0[I" (p1);T@7FI" File;TcRDoc::NormalClass00link-c.ri000064400000001257152345532360006272 0ustar00U:RDoc::AnyMethod[iI" link:ETI"File::link;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"ICreates a new name for an existing file using a hard link. Will not ;TI"Hoverwrite new_name if it already exists (raising a subclass ;TI"9of SystemCallError). Not available on all platforms.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"0File.link("testfile", ".testfile") #=> 0 ;TI"BIO.readlines(".testfile")[0] #=> "This is line one\n";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"+File.link(old_name, new_name) -> 0 ;T0[I" (p1, p2);T@FI" File;TcRDoc::NormalClass00atime-c.ri000064400000001032152345532360006423 0ustar00U:RDoc::AnyMethod[iI" atime:ETI"File::atime;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"FReturns the last access time for the named file as a Time object.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I">File.atime("testfile") #=> Wed Apr 09 08:51:48 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%File.atime(file_name) -> time ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00delete-c.ri000064400000001415152345532360006573 0ustar00U:RDoc::AnyMethod[iI" delete:ETI"File::delete;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"unlink(2) system call, the type of ;TI"5exception raised depends on its error type (see ;TI"=https://linux.die.net/man/2/unlink) and has the form of ;TI"e.g. Errno::ENOENT.;To:RDoc::Markup::BlankLineo; ; [I"See also Dir::rmdir.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"UFile.delete(file_name, ...) -> integer File.unlink(file_name, ...) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00Stat/executable_real%3f-i.ri000064400000000637152345532360011701 0ustar00U:RDoc::AnyMethod[iI"executable_real?:ETI" File::Stat#executable_real?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"ISame as executable?, but tests using the real owner of ;TI"the process.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"/stat.executable_real? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/uid-i.ri000064400000000700152345532360007027 0ustar00U:RDoc::AnyMethod[iI"uid:ETI"File::Stat#uid;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"=Returns the numeric user id of the owner of stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"(File.stat("testfile").uid #=> 501;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.uid -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/symlink%3f-i.ri000064400000001502152345532360010233 0ustar00U:RDoc::AnyMethod[iI" symlink?:ETI"File::Stat#symlink?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"BReturns true if stat is a symbolic link, ;TI"Gfalse if it isn't or if the operating system doesn't ;TI"Hsupport this feature. As File::stat automatically follows symbolic ;TI"Flinks, #symlink? will always be false for an object ;TI"returned by File::stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"/File.symlink("testfile", "alink") #=> 0 ;TI"3File.stat("alink").symlink? #=> false ;TI"1File.lstat("alink").symlink? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'stat.symlink? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/world_readable%3f-i.ri000064400000001402152345532360011512 0ustar00U:RDoc::AnyMethod[iI"world_readable?:ETI"File::Stat#world_readable?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I">If stat is readable by others, returns an integer ;TI"Crepresenting the file permission bits of stat. Returns ;TI"Enil otherwise. The meaning of the bits is platform ;TI":dependent; on Unix systems, see stat(2).;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I";m = File.stat("/etc/passwd").world_readable? #=> 420 ;TI" "644";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I",stat.world_readable? -> integer or nil ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/readable_real%3f-i.ri000064400000001032152345532360011305 0ustar00U:RDoc::AnyMethod[iI"readable_real?:ETI"File::Stat#readable_real?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FReturns true if stat is readable by the real ;TI"user id of this process.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"4File.stat("testfile").readable_real? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I",stat.readable_real? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/ftype-i.ri000064400000001322152345532360007376 0ustar00U:RDoc::AnyMethod[iI" ftype:ETI"File::Stat#ftype;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"FIdentifies the type of stat. The return string is one of: ;TI"8``file'', ``directory'', ;TI"G``characterSpecial'', ``blockSpecial'', ;TI"3``fifo'', ``link'', ;TI":``socket'', or ``unknown''.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"9File.stat("/dev/tty").ftype #=> "characterSpecial";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.ftype -> string ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/executable%3f-i.ri000064400000001222152345532360010665 0ustar00U:RDoc::AnyMethod[iI"executable?:ETI"File::Stat#executable?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"FReturns true if stat is executable or if the ;TI"@operating system doesn't distinguish executable files from ;TI"Jnonexecutable files. The tests are made using the effective owner of ;TI"the process.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"2File.stat("testfile").executable? #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"*stat.executable? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/birthtime-i.ri000064400000001676152345532360010252 0ustar00U:RDoc::AnyMethod[iI"birthtime:ETI"File::Stat#birthtime;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I",Returns the birth time for stat.;To:RDoc::Markup::BlankLineo; ; [I"HIf the platform doesn't have birthtime, raises NotImplementedError.;T@o:RDoc::Markup::Verbatim; [I"#File.write("testfile", "foo") ;TI"sleep 10 ;TI"#File.write("testfile", "bar") ;TI"sleep 10 ;TI""File.chmod(0644, "testfile") ;TI"sleep 10 ;TI"File.read("testfile") ;TI"EFile.stat("testfile").birthtime #=> 2014-02-24 11:19:17 +0900 ;TI"EFile.stat("testfile").mtime #=> 2014-02-24 11:19:27 +0900 ;TI"EFile.stat("testfile").ctime #=> 2014-02-24 11:19:37 +0900 ;TI"DFile.stat("testfile").atime #=> 2014-02-24 11:19:47 +0900;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.birthtime -> aTime ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/sticky%3f-i.ri000064400000001110152345532360010046 0ustar00U:RDoc::AnyMethod[iI" sticky?:ETI"File::Stat#sticky?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FReturns true if stat has its sticky bit set, ;TI"Ifalse if it doesn't or if the operating system doesn't ;TI"support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I".File.stat("testfile").sticky? #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"&stat.sticky? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/inspect-i.ri000064400000001457152345532360007725 0ustar00U:RDoc::AnyMethod[iI" inspect:ETI"File::Stat#inspect;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I";Produce a nicely formatted description of stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [ I"&File.stat("/etc/passwd").inspect ;TI"D #=> "#";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.inspect -> string ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/dev_minor-i.ri000064400000001034152345532360010231 0ustar00U:RDoc::AnyMethod[iI"dev_minor:ETI"File::Stat#dev_minor;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"=Returns the minor part of File_Stat#dev or ;TI"nil.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"-File.stat("/dev/fd1").dev_minor #=> 1 ;TI",File.stat("/dev/tty").dev_minor #=> 0;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"!stat.dev_minor -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/file%3f-i.ri000064400000001001152345532360007456 0ustar00U:RDoc::AnyMethod[iI" file?:ETI"File::Stat#file?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"EReturns true if stat is a regular file (not ;TI"(a device file, pipe, socket, etc.).;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"+File.stat("testfile").file? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$stat.file? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/new-c.ri000064400000000625152345532360007037 0ustar00U:RDoc::AnyMethod[iI"new:ETI"File::Stat::new;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"DCreate a File::Stat object for the given file name (raising an ;TI"*exception if the file doesn't exist).;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"(File::Stat.new(file_name) -> stat ;T0[I" (p1);T@FI" Stat;TcRDoc::NormalClass00Stat/blksize-i.ri000064400000001041152345532360007710 0ustar00U:RDoc::AnyMethod[iI" blksize:ETI"File::Stat#blksize;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"OReturns the native file system's block size. Will return nil ;TI"6on platforms that don't support this information.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"-File.stat("testfile").blksize #=> 4096;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"&stat.blksize -> integer or nil ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/ino-i.ri000064400000000664152345532360007044 0ustar00U:RDoc::AnyMethod[iI"ino:ETI"File::Stat#ino;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I".Returns the inode number for stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I",File.stat("testfile").ino #=> 1083669;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.ino -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/writable_real%3f-i.ri000064400000001032152345532360011357 0ustar00U:RDoc::AnyMethod[iI"writable_real?:ETI"File::Stat#writable_real?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FReturns true if stat is writable by the real ;TI"user id of this process.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"4File.stat("testfile").writable_real? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I",stat.writable_real? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/blockdev%3f-i.ri000064400000001171152345532360010340 0ustar00U:RDoc::AnyMethod[iI"blockdev?:ETI"File::Stat#blockdev?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I">Returns true if the file is a block device, ;TI"Gfalse if it isn't or if the operating system doesn't ;TI"support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"2File.stat("testfile").blockdev? #=> false ;TI"0File.stat("/dev/hda1").blockdev? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'stat.blockdev? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/cdesc-Stat.ri000064400000003344152345532360010021 0ustar00U:RDoc::NormalClass[iI" Stat:ETI"File::Stat;TI" Object;To:RDoc::Markup::Document: @parts[o;;[o:RDoc::Markup::Paragraph;[ I"GObjects of class File::Stat encapsulate common status information ;TI"Efor File objects. The information is recorded at the moment the ;TI"GFile::Stat object is created; changes made to the file after that ;TI"Epoint will not be reflected. File::Stat objects are returned by ;TI"EIO#stat, File::stat, File#lstat, and File::lstat. Many of these ;TI"Emethods return platform-specific values, and not all values are ;TI"5meaningful on all systems. See also Kernel#test.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0; 0; 0[[[[I"Comparable;To;;[; @; 0I" file.c;T[[I" class;T[[: public[[:protected[[: private[[I"new;T@[I" instance;T[[; [[; [[;[0[I"<=>;T@[I" atime;T@[I"birthtime;T@[I" blksize;T@[I"blockdev?;T@[I" blocks;T@[I" chardev?;T@[I" ctime;T@[I"dev;T@[I"dev_major;T@[I"dev_minor;T@[I"directory?;T@[I"executable?;T@[I"executable_real?;T@[I" file?;T@[I" ftype;T@[I"gid;T@[I"grpowned?;T@[I"ino;T@[I" inspect;T@[I" mode;T@[I" mtime;T@[I" nlink;T@[I" owned?;T@[I" pipe?;T@[I" rdev;T@[I"rdev_major;T@[I"rdev_minor;T@[I"readable?;T@[I"readable_real?;T@[I" setgid?;T@[I" setuid?;T@[I" size;T@[I" size?;T@[I" socket?;T@[I" sticky?;T@[I" symlink?;T@[I"uid;T@[I"world_readable?;T@[I"world_writable?;T@[I"writable?;T@[I"writable_real?;T@[I" zero?;T@[[U:RDoc::Context::Section[i0o;;[; 0; 0[I" file.c;TI"lib/pp.rb;TI" File;TcRDoc::NormalClassStat/gid-i.ri000064400000000700152345532360007011 0ustar00U:RDoc::AnyMethod[iI"gid:ETI"File::Stat#gid;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I">Returns the numeric group id of the owner of stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"(File.stat("testfile").gid #=> 500;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.gid -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/directory%3f-i.ri000064400000001144152345532360010553 0ustar00U:RDoc::AnyMethod[iI"directory?:ETI"File::Stat#directory?;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"AReturns true if the named file is a directory, ;TI"Eor a symlink that points at a directory, and false ;TI"otherwise.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I"File.directory?(".");T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"4File.directory?(file_name) -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/grpowned%3f-i.ri000064400000001162152345532360010374 0ustar00U:RDoc::AnyMethod[iI"grpowned?:ETI"File::Stat#grpowned?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"JReturns true if the effective group id of the process is the same as ;TI"Lthe group id of stat. On Windows NT, returns false.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"3File.stat("testfile").grpowned? #=> true ;TI"3File.stat("/etc/passwd").grpowned? #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'stat.grpowned? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/size-i.ri000064400000000664152345532360007231 0ustar00U:RDoc::AnyMethod[iI" size:ETI"File::Stat#size;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I".Returns the size of stat in bytes.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"(File.stat("testfile").size #=> 66;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.size -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/blocks-i.ri000064400000001071152345532360007525 0ustar00U:RDoc::AnyMethod[iI" blocks:ETI"File::Stat#blocks;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"HReturns the number of native file system blocks allocated for this ;TI"?file, or nil if the operating system doesn't ;TI"support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I")File.stat("testfile").blocks #=> 2;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"&stat.blocks -> integer or nil ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/world_writable%3f-i.ri000064400000001404152345532360011566 0ustar00U:RDoc::AnyMethod[iI"world_writable?:ETI"File::Stat#world_writable?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I">If stat is writable by others, returns an integer ;TI"Crepresenting the file permission bits of stat. Returns ;TI"Enil otherwise. The meaning of the bits is platform ;TI":dependent; on Unix systems, see stat(2).;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I";m = File.stat("/tmp").world_writable? #=> 511 ;TI" "777";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I".stat.world_writable? -> integer or nil ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/mtime-i.ri000064400000000723152345532360007366 0ustar00U:RDoc::AnyMethod[iI" mtime:ETI"File::Stat#mtime;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"2Returns the modification time of stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"CFile.stat("testfile").mtime #=> Wed Apr 09 08:53:14 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.mtime -> aTime ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/chardev%3f-i.ri000064400000001105152345532360010160 0ustar00U:RDoc::AnyMethod[iI" chardev?:ETI"File::Stat#chardev?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"BReturns true if the file is a character device, ;TI"Gfalse if it isn't or if the operating system doesn't ;TI"support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I".File.stat("/dev/tty").chardev? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'stat.chardev? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/socket%3f-i.ri000064400000001073152345532360010040 0ustar00U:RDoc::AnyMethod[iI" socket?:ETI"File::Stat#socket?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I";Returns true if stat is a socket, ;TI"Gfalse if it isn't or if the operating system doesn't ;TI"support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I".File.stat("testfile").socket? #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"&stat.socket? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/rdev_major-i.ri000064400000001042152345532360010376 0ustar00U:RDoc::AnyMethod[iI"rdev_major:ETI"File::Stat#rdev_major;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I">Returns the major part of File_Stat#rdev or ;TI"nil.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I".File.stat("/dev/fd1").rdev_major #=> 2 ;TI"-File.stat("/dev/tty").rdev_major #=> 5;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I""stat.rdev_major -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/size%3f-i.ri000064400000001035152345532360007520 0ustar00U:RDoc::AnyMethod[iI" size?:ETI"File::Stat#size?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"EReturns +nil+ if stat is a zero-length file, the size of ;TI"the file otherwise.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"*File.stat("testfile").size? #=> 66 ;TI"*File.stat("/dev/null").size? #=> nil;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%stat.size? -> Integer or nil ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/rdev_minor-i.ri000064400000001042152345532360010412 0ustar00U:RDoc::AnyMethod[iI"rdev_minor:ETI"File::Stat#rdev_minor;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I">Returns the minor part of File_Stat#rdev or ;TI"nil.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I".File.stat("/dev/fd1").rdev_minor #=> 1 ;TI"-File.stat("/dev/tty").rdev_minor #=> 0;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I""stat.rdev_minor -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/writable%3f-i.ri000064400000001013152345532360010353 0ustar00U:RDoc::AnyMethod[iI"writable?:ETI"File::Stat#writable?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"AReturns true if stat is writable by the ;TI"'effective user id of this process.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"/File.stat("testfile").writable? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'stat.writable? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/setuid%3f-i.ri000064400000001126152345532360010044 0ustar00U:RDoc::AnyMethod[iI" setuid?:ETI"File::Stat#setuid?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"BReturns true if stat has the set-user-id ;TI"Dpermission bit set, false if it doesn't or if the ;TI"3operating system doesn't support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I",File.stat("/bin/su").setuid? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"&stat.setuid? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/dev_major-i.ri000064400000001034152345532360010215 0ustar00U:RDoc::AnyMethod[iI"dev_major:ETI"File::Stat#dev_major;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"=Returns the major part of File_Stat#dev or ;TI"nil.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"-File.stat("/dev/fd1").dev_major #=> 2 ;TI",File.stat("/dev/tty").dev_major #=> 5;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"!stat.dev_major -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/owned%3f-i.ri000064400000001102152345532360007655 0ustar00U:RDoc::AnyMethod[iI" owned?:ETI"File::Stat#owned?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"JReturns true if the effective user id of the process is ;TI"*the same as the owner of stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"0File.stat("testfile").owned? #=> true ;TI"0File.stat("/etc/passwd").owned? #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%stat.owned? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/dev-i.ri000064400000000727152345532360007035 0ustar00U:RDoc::AnyMethod[iI"dev:ETI"File::Stat#dev;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"EReturns an integer representing the device on which stat ;TI" resides.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"(File.stat("testfile").dev #=> 774;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.dev -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/nlink-i.ri000064400000001061152345532360007362 0ustar00U:RDoc::AnyMethod[iI" nlink:ETI"File::Stat#nlink;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"5Returns the number of hard links to stat.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"3File.stat("testfile").nlink #=> 1 ;TI"3File.link("testfile", "testfile.bak") #=> 0 ;TI"2File.stat("testfile").nlink #=> 2;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.nlink -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/mode-i.ri000064400000001212152345532360007171 0ustar00U:RDoc::AnyMethod[iI" mode:ETI"File::Stat#mode;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"stat. The meaning of the bits is platform dependent; on ;TI",Unix systems, see stat(2).;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"*File.chmod(0644, "testfile") #=> 1 ;TI"s = File.stat("testfile") ;TI"0sprintf("%o", s.mode) #=> "100644";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.mode -> integer ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/readable%3f-i.ri000064400000001014152345532360010302 0ustar00U:RDoc::AnyMethod[iI"readable?:ETI"File::Stat#readable?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"AReturns true if stat is readable by the ;TI"'effective user id of this process.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"/File.stat("testfile").readable? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"(stat.readable? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/rdev-i.ri000064400000001152152345532360007210 0ustar00U:RDoc::AnyMethod[iI" rdev:ETI"File::Stat#rdev;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I">Returns an integer representing the device type on which ;TI"Dstat resides. Returns nil if the operating ;TI")system doesn't support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"*File.stat("/dev/fd1").rdev #=> 513 ;TI"*File.stat("/dev/tty").rdev #=> 1280;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$stat.rdev -> integer or nil ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/pipe%3f-i.ri000064400000000647152345532360007513 0ustar00U:RDoc::AnyMethod[iI" pipe?:ETI"File::Stat#pipe?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"JReturns true if the operating system supports pipes and ;TI"9stat is a pipe; false otherwise.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$stat.pipe? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/ctime-i.ri000064400000001207152345532360007352 0ustar00U:RDoc::AnyMethod[iI" ctime:ETI"File::Stat#ctime;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"@Returns the change time for stat (that is, the time ;TI"Ddirectory information about the file was changed, not the file ;TI" itself).;To:RDoc::Markup::BlankLineo; ; [I"ENote that on Windows (NTFS), returns creation time (birth time).;T@o:RDoc::Markup::Verbatim; [I"CFile.stat("testfile").ctime #=> Wed Apr 09 08:53:14 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.ctime -> aTime ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/atime-i.ri000064400000000762152345532360007355 0ustar00U:RDoc::AnyMethod[iI" atime:ETI"File::Stat#atime;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FReturns the last access time for this file as an object of class ;TI" Time.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"CFile.stat("testfile").atime #=> Wed Dec 31 18:00:00 CST 1969;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"stat.atime -> time ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/setgid%3f-i.ri000064400000001134152345532360010025 0ustar00U:RDoc::AnyMethod[iI" setgid?:ETI"File::Stat#setgid?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"CReturns true if stat has the set-group-id ;TI"Dpermission bit set, false if it doesn't or if the ;TI"3operating system doesn't support this feature.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"2File.stat("/usr/sbin/lpc").setgid? #=> true;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%stat.setgid? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/zero%3f-i.ri000064400000000774152345532360007536 0ustar00U:RDoc::AnyMethod[iI" zero?:ETI"File::Stat#zero?;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"EReturns true if stat is a zero-length file; ;TI""false otherwise.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I",File.stat("testfile").zero? #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$stat.zero? -> true or false ;T0[I"();T@FI" Stat;TcRDoc::NormalClass00Stat/%3c%3d%3e-i.ri000064400000001204152345532360007411 0ustar00U:RDoc::AnyMethod[iI"<=>:ETI"File::Stat#<=>;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"LCompares File::Stat objects by comparing their respective modification ;TI" times.;To:RDoc::Markup::BlankLineo; ; [I"A+nil+ is returned if +other_stat+ is not a File::Stat object;T@o:RDoc::Markup::Verbatim; [ I"f1 = File.new("f1", "w") ;TI" sleep 1 ;TI"f2 = File.new("f2", "w") ;TI"!f1.stat <=> f2.stat #=> -1;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"-stat <=> other_stat -> -1, 0, 1, nil ;T0[I" (p1);T@FI" Stat;TcRDoc::NormalClass00path-c.ri000064400000000767152345532360006276 0ustar00U:RDoc::AnyMethod[iI" path:ETI"File::path;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"2Returns the string representation of the path;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"5File.path("/dev/null") #=> "/dev/null" ;TI"/File.path(Pathname.new("/tmp")) #=> "/tmp";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"!File.path(path) -> string ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00lstat-c.ri000064400000001250152345532360006455 0ustar00U:RDoc::AnyMethod[iI" lstat:ETI"File::lstat;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"ESame as File::stat, but does not follow the last symbolic link. ;TI")Instead, reports on the link itself.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [ I"3File.symlink("testfile", "link2test") #=> 0 ;TI"4File.stat("testfile").size #=> 66 ;TI"3File.lstat("link2test").size #=> 8 ;TI"3File.stat("link2test").size #=> 66;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%File.lstat(file_name) -> stat ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00setuid%3f-c.ri000064400000000702152345532360007122 0ustar00U:RDoc::AnyMethod[iI" setuid?:ETI"File::setuid?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"HReturns true if the named file has the setuid bit set.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"1File.setuid?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00stat-c.ri000064400000000753152345532370006311 0ustar00U:RDoc::AnyMethod[iI" stat:ETI"File::stat;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"EReturns a File::Stat object for the named file (see File::Stat).;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"CFile.stat("testfile").mtime #=> Tue Apr 08 12:58:04 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%File.stat(file_name) -> stat ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00new-c.ri000064400000002273152345532370006126 0ustar00U:RDoc::AnyMethod[iI"new:ETI"File::new;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"JOpens the file named by +filename+ according to the given +mode+ and ;TI"returns a new File object.;To:RDoc::Markup::BlankLineo; ; [I"6See IO.new for a description of +mode+ and +opt+.;T@o; ; [I"PIf a file is being created, permission bits may be given in +perm+. These ;TI"Kmode and permission bits are platform dependent; on Unix systems, see ;TI"0open(2) and chmod(2) man pages for details.;T@o; ; [I"EThe new File object is buffered mode (or non-sync mode), unless ;TI"+filename+ is a tty. ;TI"HSee IO#flush, IO#fsync, IO#fdatasync, and IO#sync= about sync mode.;T@S:RDoc::Markup::Heading: leveli: textI" Examples;T@o:RDoc::Markup::Verbatim; [I"#f = File.new("testfile", "r") ;TI"$f = File.new("newfile", "w+") ;TI"Ff = File.new("newfile", File::CREAT|File::TRUNC|File::RDWR, 0644);T: @format0: @fileI" io.c;T:0@omit_headings_from_table_of_contents_below0I"uFile.new(filename, mode="r" [, opt]) -> file File.new(filename [, mode [, perm]] [, opt]) -> file ;T0[I" (*args);T@$FI" File;TcRDoc::NormalClass00pipe%3f-c.ri000064400000000657152345532370006574 0ustar00U:RDoc::AnyMethod[iI" pipe?:ETI"File::pipe?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I";Returns true if the named file is a pipe.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"/File.pipe?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00ctime-c.ri000064400000001274152345532370006436 0ustar00U:RDoc::AnyMethod[iI" ctime:ETI"File::ctime;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"CReturns the change time for the named file (the time at which ;TI"Ddirectory information about the file was changed, not the file ;TI" itself).;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o; ; [I"ENote that on Windows (NTFS), returns creation time (birth time).;T@o:RDoc::Markup::Verbatim; [I">File.ctime("testfile") #=> Wed Apr 09 08:53:13 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$File.ctime(file_name) -> time ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00chmod-i.ri000064400000001233152345532370006430 0ustar00U:RDoc::AnyMethod[iI" chmod:ETI"File#chmod;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"?Changes permission bits on file to the bit pattern ;TI"Arepresented by mode_int. Actual effects are platform ;TI"Hdependent; on Unix systems, see chmod(2) for details. ;TI"2Follows symbolic links. Also see File#lchmod.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"f = File.new("out", "w"); ;TI"f.chmod(0644) #=> 0;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"!file.chmod(mode_int) -> 0 ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00readable%3f-c.ri000064400000001166152345532370007372 0ustar00U:RDoc::AnyMethod[iI"readable?:ETI"File::readable?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"NReturns true if the named file is readable by the effective ;TI"7user and group id of this process. See eaccess(3).;To:RDoc::Markup::BlankLineo; ; [I"MNote that some OS-level security features may cause this to return true ;TI"Feven though the file is not readable by the effective user/group.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"2File.readable?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00owned%3f-c.ri000064400000001006152345532370006740 0ustar00U:RDoc::AnyMethod[iI" owned?:ETI"File::owned?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"@Returns true if the named file exists and the ;TI">effective used id of the calling process is the owner of ;TI"the file.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"/File.owned?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00grpowned%3f-c.ri000064400000001067152345532370007460 0ustar00U:RDoc::AnyMethod[iI"grpowned?:ETI"File::grpowned?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"@Returns true if the named file exists and the ;TI"?effective group id of the calling process is the owner of ;TI"5the file. Returns false on Windows.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"2File.grpowned?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00cdesc-File.ri000064400000036241152345532370007055 0ustar00U:RDoc::NormalClass[iI" File:ET@I"IO;To:RDoc::Markup::Document: @parts[o;;[.o:RDoc::Markup::Paragraph;[ I"CA File is an abstraction of any file object accessible by the ;TI"Eprogram and is closely associated with class IO. File includes ;TI"Fthe methods of module FileTest as class methods, allowing you to ;TI"9write (for example) File.exist?("foo").;To:RDoc::Markup::BlankLineo; ;[ I")In the description of File methods, ;TI"6permission bits are a platform-specific ;TI"Dset of bits that indicate permissions of a file. On Unix-based ;TI"Gsystems, permissions are viewed as a set of three octets, for the ;TI"Downer, the group, and the rest of the world. For each of these ;TI"Eentities, permissions may be set to read, write, or execute the ;TI" file:;T@o; ;[ I"DThe permission bits 0644 (in octal) would thus be ;TI"Finterpreted as read/write for owner, and read-only for group and ;TI"Gother. Higher-order bits may also be used to indicate the type of ;TI"Hfile (plain, directory, pipe, socket, and so on) and various other ;TI"Cspecial features. If the permissions are for a directory, the ;TI"Gmeaning of the execute bit changes; when set the directory can be ;TI"searched.;T@o; ;[ I"FOn non-Posix operating systems, there may be only the ability to ;TI"Fmake a file read-only or read-write. In this case, the remaining ;TI"Ipermission bits will be synthesized to resemble typical values. For ;TI"=instance, on Windows NT the default permission bits are ;TI"H0644, which means read/write for owner, read-only for ;TI"Fall others. The only change that can be made is to make the file ;TI"7read-only, which is reported as 0444.;T@o; ;[I"OVarious constants for the methods in File can be found in File::Constants.;T@S:RDoc::Markup::Heading: leveli: textI"What's Here;T@o; ;[I"+First, what's elsewhere. \Class \File:;T@o:RDoc::Markup::List: @type: BULLET: @items[o:RDoc::Markup::ListItem: @label0;[o; ;[I"EInherits from {class IO}[IO.html#class-IO-label-What-27s+Here], ;TI"Din particular, methods for creating, reading, and writing files;To;;0;[o; ;[I"TIncludes {module FileTest}[FileTest.html#module-FileTest-label-What-27s+Here]. ;TI"1which provides dozens of additional methods.;T@o; ;[I"Returns whether the given path is the absolute file path.;To;;0;[o;;;;[o;;[I"::basename;T;[o; ;[I"7Returns the last component of the given file path.;To;;0;[o;;;;[o;;[I"::dirname;T;[o; ;[I"?Returns all but the last component of the given file path.;To;;0;[o;;;;[o;;[I"::expand_path;T;[o; ;[I"8Returns the absolute file path for the given path, ;TI"/expanding ~ for a home directory.;To;;0;[o;;;;[o;;[I"::extname;T;[o; ;[I"8Returns the file extension for the given file path.;To;;0;[o;;;;[o;;[I"&::fnmatch? (aliased as ::fnmatch);T;[o; ;[I")Returns whether the given file path ;TI"matches the given pattern.;To;;0;[o;;;;[o;;[I" ::join;T;[o; ;[I"5Joins path components into a single path string.;To;;0;[o;;;;[o;;[I" ::path;T;[o; ;[I"9Returns the string representation of the given path.;To;;0;[o;;;;[o;;[I"::readlink;T;[o; ;[I"=Returns the path to the file at the given symbolic link.;To;;0;[o;;;;[o;;[I"::realdirpath;T;[o; ;[I"4Returns the real path for the given file path, ;TI"-where the last component need not exist.;To;;0;[o;;;;[o;;[I"::realpath;T;[o; ;[I"4Returns the real path for the given file path, ;TI"%where all components must exist.;To;;0;[o;;;;[o;;[I" ::split;T;[o; ;[I"FReturns an array of two strings: the directory name and basename ;TI"#of the file at the given path.;To;;0;[o;;;;[o;;[I" #path (aliased as #to_path);T;[o; ;[I"9Returns the string representation of the given path.;T@o; ;[I" _Times_;T@o;;;;[ o;;0;[o;;;;[o;;[I" ::atime;T;[o; ;[I"BReturns a \Time for the most recent access to the given file.;To;;0;[o;;;;[o;;[I"::birthtime;T;[o; ;[I"9Returns a \Time for the creation of the given file.;To;;0;[o;;;;[o;;[I" ::ctime;T;[o; ;[I"@Returns a \Time for the metadata change of the given file.;To;;0;[o;;;;[o;;[I" ::mtime;T;[o; ;[I">Returns a \Time for the most recent data modification to ;TI"#the content of the given file.;To;;0;[o;;;;[o;;[I" #atime;T;[o; ;[I":Returns a \Time for the most recent access to +self+.;To;;0;[o;;;;[o;;[I"#birthtime;T;[o; ;[I".Returns a \Time the creation for +self+.;To;;0;[o;;;;[o;;[I" #ctime;T;[o; ;[I"7Returns a \Time for the metadata change of +self+.;To;;0;[o;;;;[o;;[I" #mtime;T;[o; ;[I";Returns a \Time for the most recent data modification ;TI"to the content of +self+.;T@o; ;[I" _Types_;T@o;;;;[ o;;0;[o;;;;[o;;[I"::blockdev?;T;[o; ;[I"BReturns whether the file at the given path is a block device.;To;;0;[o;;;;[o;;[I"::chardev?;T;[o; ;[I"FReturns whether the file at the given path is a character device.;To;;0;[o;;;;[o;;[I"::directory?;T;[o; ;[I">Returns whether the file at the given path is a diretory.;To;;0;[o;;;;[o;;[I"::executable?;T;[o; ;[I">Returns whether the file at the given path is executable ;TI"Returns whether the file at the given path is executable ;TI"7by the real user and group of the current process.;To;;0;[o;;;;[o;;[I" ::exist?;T;[o; ;[I"7Returns whether the file at the given path exists.;To;;0;[o;;;;[o;;[I" ::file?;T;[o; ;[I"BReturns whether the file at the given path is a regular file.;To;;0;[o;;;;[o;;[I" ::ftype;T;[o; ;[I"DReturns a string giving the type of the file at the given path.;To;;0;[o;;;;[o;;[I"::grpowned?;T;[o; ;[I"@Returns whether the effective group of the current process ;TI"%owns the file at the given path.;To;;0;[o;;;;[o;;[I"::identical?;T;[o; ;[I"@Returns whether the files at two given paths are identical.;To;;0;[o;;;;[o;;[I" ::lstat;T;[o; ;[I">Returns the File::Stat object for the last symbolic link ;TI"in the given path.;To;;0;[o;;;;[o;;[I" ::owned?;T;[o; ;[I"?Returns whether the effective user of the current process ;TI"%owns the file at the given path.;To;;0;[o;;;;[o;;[I" ::pipe?;T;[o; ;[I":Returns whether the file at the given path is a pipe.;To;;0;[o;;;;[o;;[I"::readable?;T;[o; ;[I"Returns the File::Stat object for the last symbolic link ;TI"in the path for +self+.;T@o; ;[I"_Contents_;T@o;;;;[ o;;0;[o;;;;[o;;[I""::empty? (aliased as ::zero?);T;[o; ;[I"0Returns whether the file at the given path ;TI"exists and is empty.;To;;0;[o;;;;[o;;[I" ::size;T;[o; ;[I"true if the named files are identical.;To:RDoc::Markup::BlankLineo; ; [I"/_file_1_ and _file_2_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I"open("a", "w") {} ;TI"/p File.identical?("a", "a") #=> true ;TI"/p File.identical?("a", "./a") #=> true ;TI"File.link("a", "b") ;TI"/p File.identical?("a", "b") #=> true ;TI"File.symlink("a", "c") ;TI"/p File.identical?("a", "c") #=> true ;TI"open("d", "w") {} ;TI"/p File.identical?("a", "d") #=> false;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"9File.identical?(file_1, file_2) -> true or false ;T0[I" (p1, p2);T@FI" File;TcRDoc::NormalClass00rename-c.ri000064400000001013152345532370006573 0ustar00U:RDoc::AnyMethod[iI" rename:ETI"File::rename;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FRenames the given file to the new name. Raises a SystemCallError ;TI"#if the file cannot be renamed.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I".File.rename("afile", "afile.bak") #=> 0;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I",File.rename(old_name, new_name) -> 0 ;T0[I" (p1, p2);T@FI" File;TcRDoc::NormalClass00symlink-c.ri000064400000001142152345532370007015 0ustar00U:RDoc::AnyMethod[iI" symlink:ETI"File::symlink;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"JCreates a symbolic link called new_name for the existing file ;TI";old_name. Raises a NotImplemented exception on ;TI"2platforms that do not support symbolic links.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"2File.symlink("testfile", "link2test") #=> 0;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"-File.symlink(old_name, new_name) -> 0 ;T0[I" (p1, p2);T@FI" File;TcRDoc::NormalClass00realdirpath-c.ri000064400000001332152345532370007627 0ustar00U:RDoc::AnyMethod[iI"realdirpath:ETI"File::realdirpath;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"RReturns the real (absolute) pathname of _pathname_ in the actual filesystem. ;TI"@The real pathname doesn't contain symlinks or useless dots.;To:RDoc::Markup::BlankLineo; ; [I">If _dir_string_ is given, it is used as a base directory ;TI"Ifor interpreting relative pathname instead of the current directory.;T@o; ; [I"@The last component of the real pathname can be nonexistent.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"BFile.realdirpath(pathname [, dir_string]) -> real_pathname ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00size-i.ri000064400000000324152345532370006310 0ustar00U:RDoc::AnyMethod[iI" size:ETI"File#size;TF: privateo:RDoc::Markup::Document: @parts[: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below000[I"();T@ FI" File;TcRDoc::NormalClass00truncate-i.ri000064400000001260152345532370007163 0ustar00U:RDoc::AnyMethod[iI" truncate:ETI"File#truncate;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"ETruncates file to at most integer bytes. The file ;TI"@must be opened for writing. Not available on all platforms.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [ I"f = File.new("out", "w") ;TI"'f.syswrite("1234567890") #=> 10 ;TI"&f.truncate(5) #=> 0 ;TI"(f.close() #=> nil ;TI"%File.size("out") #=> 5;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$file.truncate(integer) -> 0 ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00expand_path-c.ri000064400000003027152345532370007626 0ustar00U:RDoc::AnyMethod[iI"expand_path:ETI"File::expand_path;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"EConverts a pathname to an absolute pathname. Relative paths are ;TI"Ireferenced from the current working directory of the process unless ;TI"A+dir_string+ is given, in which case it will be used as the ;TI"9starting point. The given pathname may start with a ;TI"C``~'', which expands to the process owner's home ;TI"~user'' expands to the named ;TI"user's home directory.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"FFile.expand_path("~oracle/bin") #=> "/home/oracle/bin" ;T: @format0o; ; [I":A simple example of using +dir_string+ is as follows.;To; ; [I"CFile.expand_path("ruby", "/usr/bin") #=> "/usr/bin/ruby" ;T; 0o; ; [I"PA more complex example which also resolves parent directory is as follows. ;TI"LSuppose we are in bin/mygem and want the absolute path of lib/mygem.rb.;T@o; ; [I"6File.expand_path("../../lib/mygem.rb", __FILE__) ;TI",#=> ".../path/to/project/lib/mygem.rb" ;T; 0o; ; [I"OSo first it resolves the parent of __FILE__, that is bin/, then go to the ;TI"@parent, the root of the project and appends +lib/mygem.rb+.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"DFile.expand_path(file_name [, dir_string] ) -> abs_file_name ;T0[I" (*args);T@+FI" File;TcRDoc::NormalClass00mtime-i.ri000064400000000714152345532370006454 0ustar00U:RDoc::AnyMethod[iI" mtime:ETI"File#mtime;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"3Returns the modification time for file.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"BFile.new("testfile").mtime #=> Wed Apr 09 08:53:14 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"file.mtime -> time ;T0[I"();T@FI" File;TcRDoc::NormalClass00lchown-c.ri000064400000001067152345532370006627 0ustar00U:RDoc::AnyMethod[iI" lchown:ETI"File::lchown;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"=Equivalent to File::chown, but does not follow symbolic ;TI"Jlinks (so it will change the owner associated with the link, not the ;TI"Gfile referenced by the link). Often not available. Returns number ;TI"#of files in the argument list.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"@File.lchown(owner_int, group_int, file_name,..) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00unlink-c.ri000064400000001415152345532370006632 0ustar00U:RDoc::AnyMethod[iI" unlink:ETI"File::unlink;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"unlink(2) system call, the type of ;TI"5exception raised depends on its error type (see ;TI"=https://linux.die.net/man/2/unlink) and has the form of ;TI"e.g. Errno::ENOENT.;To:RDoc::Markup::BlankLineo; ; [I"See also Dir::rmdir.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"UFile.delete(file_name, ...) -> integer File.unlink(file_name, ...) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00umask-c.ri000064400000001405152345532370006451 0ustar00U:RDoc::AnyMethod[iI" umask:ETI"File::umask;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"GReturns the current umask value for this process. If the optional ;TI"Cargument is given, set the umask to that value and return the ;TI"Cprevious value. Umask values are subtracted from the ;TI"Gdefault permissions, so a umask of 0222 would make a ;TI"!file read-only for everyone.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"File.umask(0006) #=> 18 ;TI"File.umask #=> 6;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"GFile.umask() -> integer File.umask(integer) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00File/Constants/cdesc-Constants.ri000064400000012312152345532370012776 0ustar00U:RDoc::NormalModule[iI"File::Constants:ETI"File::File::Constants;T0o:RDoc::Markup::Document: @parts[o;;[ o:RDoc::Markup::Paragraph;[I"%Document-module: File::Constants;To:RDoc::Markup::BlankLineo; ;[I"DFile::Constants provides file-related constants. All possible ;TI"Ifile constants are listed in the documentation but they may not all ;TI"!be present on your platform.;T@o; ;[I"LIf the underlying platform doesn't define a constant the corresponding ;TI""Ruby constant is not defined.;T@o; ;[I"GYour platform documentations (e.g. man open(2)) may describe more ;TI"detailed information.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0; 0; 0[[#U:RDoc::Constant[iI"FNM_NOESCAPE;TI"(File::File::Constants::FNM_NOESCAPE;T: public0o;;[o; ;[I";Disables escapes in File.fnmatch and Dir.glob patterns;T; I" dir.c;T; 0@*@cRDoc::NormalModule0U; [iI"FNM_PATHNAME;TI"(File::File::Constants::FNM_PATHNAME;T;0o;;[o; ;[I"LWildcards in File.fnmatch and Dir.glob patterns do not match directory ;TI"separators;T; @*; 0@*@@+0U; [iI"FNM_DOTMATCH;TI"(File::File::Constants::FNM_DOTMATCH;T;0o;;[o; ;[I"JThe '*' wildcard matches filenames starting with "." in File.fnmatch ;TI"and Dir.glob patterns;T; @*; 0@*@@+0U; [iI"FNM_CASEFOLD;TI"(File::File::Constants::FNM_CASEFOLD;T;0o;;[o; ;[I"DMakes File.fnmatch patterns case insensitive (but not Dir.glob ;TI"patterns).;T; @*; 0@*@@+0U; [iI"FNM_EXTGLOB;TI"'File::File::Constants::FNM_EXTGLOB;T;0o;;[o; ;[I"CAllows file globbing through "{a,b}" in File.fnmatch patterns.;T; @*; 0@*@@+0U; [iI"FNM_SYSCASE;TI"'File::File::Constants::FNM_SYSCASE;T;0o;;[o; ;[I"DSystem default case insensitiveness, equals to FNM_CASEFOLD or ;TI"0.;T; @*; 0@*@@+0U; [iI"FNM_SHORTNAME;TI")File::File::Constants::FNM_SHORTNAME;T;0o;;[o; ;[I"BMakes patterns to match short names if existing. Valid only ;TI"on Microsoft Windows.;T; @*; 0@*@@+0U; [iI" RDONLY;TI""File::File::Constants::RDONLY;T;0o;;[o; ;[I"open for reading only;T@; @; 0@@@+0U; [iI" WRONLY;TI""File::File::Constants::WRONLY;T;0o;;[o; ;[I"open for writing only;T@; @; 0@@@+0U; [iI" RDWR;TI" File::File::Constants::RDWR;T;0o;;[o; ;[I"!open for reading and writing;T@; @; 0@@@+0U; [iI" APPEND;TI""File::File::Constants::APPEND;T;0o;;[o; ;[I"append on each write;T@; @; 0@@@+0U; [iI" CREAT;TI"!File::File::Constants::CREAT;T;0o;;[o; ;[I"%create file if it does not exist;T@; @; 0@@@+0U; [iI" EXCL;TI" File::File::Constants::EXCL;T;0o;;[o; ;[I"'error if CREAT and the file exists;T@; @; 0@@@+0U; [iI" NONBLOCK;TI"$File::File::Constants::NONBLOCK;T;0o;;[o; ;[I"9do not block on open or for data to become available;T@; @; 0@@@+0U; [iI" TRUNC;TI"!File::File::Constants::TRUNC;T;0o;;[o; ;[I"truncate size to 0;T@; @; 0@@@+0U; [iI" NOCTTY;TI""File::File::Constants::NOCTTY;T;0o;;[o; ;[I":not to make opened IO the controlling terminal device;T@; @; 0@@@+0U; [iI" BINARY;TI""File::File::Constants::BINARY;T;0o;;[o; ;[I"!disable line code conversion;T@; @; 0@@@+0U; [iI"SHARE_DELETE;TI"(File::File::Constants::SHARE_DELETE;T;0o;;[o; ;[I"can delete opened file;T@; @; 0@@@+0U; [iI" SYNC;TI" File::File::Constants::SYNC;T;0o;;[o; ;[I".any write operation perform synchronously;T@; @; 0@@@+0U; [iI" DSYNC;TI"!File::File::Constants::DSYNC;T;0o;;[o; ;[I"Dany write operation perform synchronously except some meta data;T@; @; 0@@@+0U; [iI" RSYNC;TI"!File::File::Constants::RSYNC;T;0o;;[o; ;[I"Gany read operation perform synchronously. used with SYNC or DSYNC.;T@; @; 0@@@+0U; [iI" NOFOLLOW;TI"$File::File::Constants::NOFOLLOW;T;0o;;[o; ;[I"do not follow symlinks;T@; @; 0@@@+0U; [iI" NOATIME;TI"#File::File::Constants::NOATIME;T;0o;;[o; ;[I"do not change atime;T@; @; 0@@@+0U; [iI" DIRECT;TI""File::File::Constants::DIRECT;T;0o;;[o; ;[I"DTry to minimize cache effects of the I/O to and from this file.;T@; @; 0@@@+0U; [iI" TMPFILE;TI"#File::File::Constants::TMPFILE;T;0o;;[o; ;[I"%Create an unnamed temporary file;T@; @; 0@@@+0U; [iI" LOCK_SH;TI"#File::File::Constants::LOCK_SH;T;0o;;[o; ;[I" shared lock. see File#flock;T@; @; 0@@@+0U; [iI" LOCK_EX;TI"#File::File::Constants::LOCK_EX;T;0o;;[o; ;[I"#exclusive lock. see File#flock;T@; @; 0@@@+0U; [iI" LOCK_UN;TI"#File::File::Constants::LOCK_UN;T;0o;;[o; ;[I"unlock. see File#flock;T@; @; 0@@@+0U; [iI" LOCK_NB;TI"#File::File::Constants::LOCK_NB;T;0o;;[o; ;[I"Enon-blocking lock. used with LOCK_SH or LOCK_EX. see File#flock ;T@; @; 0@@@+0U; [iI" NULL;TI" File::File::Constants::NULL;T;0o;;[o; ;[I"Name of the null device;T@; @; 0@@@+0[[[I" class;T[[;[[:protected[[: private[[I" instance;T[[;[[;[[;[[[U:RDoc::Context::Section[i0o;;[; 0; 0[I" dir.c;TI" file.c;TI" File;TcRDoc::NormalClasssize-c.ri000064400000000632152345532370006304 0ustar00U:RDoc::AnyMethod[iI" size:ETI"File::size;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"0Returns the size of file_name.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'File.size(file_name) -> integer ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00absolute_path%3f-c.ri000064400000001102152345532370010453 0ustar00U:RDoc::AnyMethod[iI"absolute_path?:ETI"File::absolute_path?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"GReturns true if +file_name+ is an absolute path, and ;TI""false otherwise.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"NFile.absolute_path?("c:/foo") #=> false (on Linux), true (on Windows);T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"7File.absolute_path?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00setgid%3f-c.ri000064400000000702152345532370007105 0ustar00U:RDoc::AnyMethod[iI" setgid?:ETI"File::setgid?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"HReturns true if the named file has the setgid bit set.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"1File.setgid?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00executable_real%3f-c.ri000064400000001513152345532370010753 0ustar00U:RDoc::AnyMethod[iI"executable_real?:ETI"File::executable_real?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"KReturns true if the named file is executable by the real ;TI"6user and group id of this process. See access(3).;To:RDoc::Markup::BlankLineo; ; [I"GWindows does not support execute permissions separately from read ;TI"Qpermissions. On Windows, a file is only considered executable if it ends in ;TI".bat, .cmd, .com, or .exe.;T@o; ; [I"MNote that some OS-level security features may cause this to return true ;TI"Ceven though the file is not executable by the real user/group.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"9File.executable_real?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00chardev%3f-c.ri000064400000000704152345532370007244 0ustar00U:RDoc::AnyMethod[iI" chardev?:ETI"File::chardev?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"GReturns true if the named file is a character device.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"2File.chardev?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00path-i.ri000064400000001655152345532370006302 0ustar00U:RDoc::AnyMethod[iI" path:ETI"File#path;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"GReturns the pathname used to create file as a string. Does ;TI"not normalize the name.;To:RDoc::Markup::BlankLineo; ; [I"JThe pathname may not point to the file corresponding to file. ;TI"DFor instance, the pathname becomes void when the file has been ;TI"moved or deleted.;T@o; ; [I"@This method raises IOError for a file created using ;TI"AFile::Constants::TMPFILE because they don't have a pathname.;T@o:RDoc::Markup::Verbatim; [I" "testfile" ;TI"BFile.new("/tmp/../tmp/xxx", "w").path #=> "/tmp/../tmp/xxx";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"8file.path -> filename file.to_path -> filename ;T0[[I" to_path;T@ I"();T@FI" File;TcRDoc::NormalClass00readlink-c.ri000064400000001111152345532370007114 0ustar00U:RDoc::AnyMethod[iI" readlink:ETI"File::readlink;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"@Returns the name of the file referenced by the given link. ;TI"$Not available on all platforms.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"3File.symlink("testfile", "link2test") #=> 0 ;TI";File.readlink("link2test") #=> "testfile";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"-File.readlink(link_name) -> file_name ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00executable%3f-c.ri000064400000001507152345532370007753 0ustar00U:RDoc::AnyMethod[iI"executable?:ETI"File::executable?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"PReturns true if the named file is executable by the effective ;TI"7user and group id of this process. See eaccess(3).;To:RDoc::Markup::BlankLineo; ; [I"GWindows does not support execute permissions separately from read ;TI"Qpermissions. On Windows, a file is only considered executable if it ends in ;TI".bat, .cmd, .com, or .exe.;T@o; ; [I"MNote that some OS-level security features may cause this to return true ;TI"Heven though the file is not executable by the effective user/group.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"4File.executable?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00truncate-c.ri000064400000001253152345532370007157 0ustar00U:RDoc::AnyMethod[iI" truncate:ETI"File::truncate;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FTruncates the file file_name to be at most integer ;TI"0bytes long. Not available on all platforms.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [ I"f = File.new("out", "w") ;TI"&f.write("1234567890") #=> 10 ;TI"'f.close #=> nil ;TI"%File.truncate("out", 5) #=> 0 ;TI"$File.size("out") #=> 5;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"-File.truncate(file_name, integer) -> 0 ;T0[I" (p1, p2);T@FI" File;TcRDoc::NormalClass00mtime-c.ri000064400000001033152345532370006441 0ustar00U:RDoc::AnyMethod[iI" mtime:ETI"File::mtime;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"GReturns the modification time for the named file as a Time object.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I">File.mtime("testfile") #=> Tue Apr 08 12:58:04 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"%File.mtime(file_name) -> time ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00chown-c.ri000064400000001466152345532370006456 0ustar00U:RDoc::AnyMethod[iI" chown:ETI"File::chown;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"CChanges the owner and group of the named file(s) to the given ;TI"Anumeric owner and group id's. Only a process with superuser ;TI"Gprivileges may change the owner of a file. The current owner of a ;TI"Ffile may change the file's group to any group to which the owner ;TI"Ebelongs. A nil or -1 owner or group id is ignored. ;TI"+Returns the number of files processed.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"%File.chown(nil, 100, "testfile");T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"CFile.chown(owner_int, group_int, file_name, ...) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00mkfifo-c.ri000064400000001024152345532370006601 0ustar00U:RDoc::AnyMethod[iI" mkfifo:ETI"File::mkfifo;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"@Creates a FIFO special file with name _file_name_. _mode_ ;TI"Gspecifies the FIFO's permissions. It is modified by the process's ;TI"Eumask in the usual way: the permissions of the created file are ;TI"(mode & ~umask).;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"-File.mkfifo(file_name, mode=0666) => 0 ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00sticky%3f-c.ri000064400000000702152345532370007134 0ustar00U:RDoc::AnyMethod[iI" sticky?:ETI"File::sticky?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"HReturns true if the named file has the sticky bit set.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"1File.sticky?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00zero%3f-c.ri000064400000000706152345532370006611 0ustar00U:RDoc::AnyMethod[iI" zero?:ETI"File::zero?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"@Returns true if the named file exists and has ;TI"a zero size.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I".File.zero?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00utime-c.ri000064400000001151152345532370006452 0ustar00U:RDoc::AnyMethod[iI" utime:ETI"File::utime;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"FSets the access and modification times of each named file to the ;TI"Hfirst two arguments. If a file is a symlink, this method acts upon ;TI"?its referent rather than the link itself; for the inverse ;TI":behavior see File.lutime. Returns the number of file ;TI" names in the argument list.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I" integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00open-c.ri000064400000002074152345532370006275 0ustar00U:RDoc::AnyMethod[iI" open:ETI"File::open;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [ I":With no associated block, File.open is a synonym for ;TI" file File.open(filename [, mode [, perm]] [, opt]) -> file File.open(filename, mode="r" [, opt]) {|file| block } -> obj File.open(filename [, mode [, perm]] [, opt]) {|file| block } -> obj ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00chmod-c.ri000064400000001335152345532370006425 0ustar00U:RDoc::AnyMethod[iI" chmod:ETI"File::chmod;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"EChanges permission bits on the named file(s) to the bit pattern ;TI"Irepresented by mode_int. Actual effects are operating system ;TI"Idependent (see the beginning of this section). On Unix systems, see ;TI"Dchmod(2) for details. Returns the number of files ;TI"processed.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"0File.chmod(0644, "testfile", "out") #=> 2;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"8File.chmod(mode_int, file_name, ... ) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00lutime-c.ri000064400000001156152345532370006633 0ustar00U:RDoc::AnyMethod[iI" lutime:ETI"File::lutime;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"FSets the access and modification times of each named file to the ;TI"Hfirst two arguments. If a file is a symlink, this method acts upon ;TI"Athe link itself as opposed to its referent; for the inverse ;TI":behavior, see File.utime. Returns the number of file ;TI" names in the argument list.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"=File.lutime(atime, mtime, file_name, ...) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00ftype-c.ri000064400000001512152345532370006457 0ustar00U:RDoc::AnyMethod[iI" ftype:ETI"File::ftype;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"HIdentifies the type of the named file; the return string is one of ;TI"8``file'', ``directory'', ;TI"G``characterSpecial'', ``blockSpecial'', ;TI"3``fifo'', ``link'', ;TI":``socket'', or ``unknown''.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"2File.ftype("testfile") #=> "file" ;TI">File.ftype("/dev/tty") #=> "characterSpecial" ;TI"3File.ftype("/tmp/.X11-unix/X0") #=> "socket";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'File.ftype(file_name) -> string ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00writable%3f-c.ri000064400000001166152345532370007444 0ustar00U:RDoc::AnyMethod[iI"writable?:ETI"File::writable?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"NReturns true if the named file is writable by the effective ;TI"7user and group id of this process. See eaccess(3).;To:RDoc::Markup::BlankLineo; ; [I"MNote that some OS-level security features may cause this to return true ;TI"Feven though the file is not writable by the effective user/group.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"2File.writable?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00birthtime-c.ri000064400000000341152345532370007316 0ustar00U:RDoc::AnyMethod[iI"birthtime:ETI"File::birthtime;TT: privateo:RDoc::Markup::Document: @parts[: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below000[I" (p1);T@ FI" File;TcRDoc::NormalClass00split-c.ri000064400000001123152345532370006461 0ustar00U:RDoc::AnyMethod[iI" split:ETI"File::split;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"GSplits the given string into a directory and a file component and ;TI"Ereturns them in a two-element array. See also File::dirname and ;TI"File::basename.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"IFile.split("/home/gumby/.profile") #=> ["/home/gumby", ".profile"];T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"&File.split(file_name) -> array ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00basename-c.ri000064400000002011152345532370007076 0ustar00U:RDoc::AnyMethod[iI" basename:ETI"File::basename;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"9Returns the last component of the filename given in ;TI"Cfile_name (after first stripping trailing separators), ;TI"8which can be formed using both File::SEPARATOR and ;TI"FFile::ALT_SEPARATOR as the separator when File::ALT_SEPARATOR is ;TI"Hnot nil. If suffix is given and present at the ;TI"Gend of file_name, it is removed. If suffix is ".*", ;TI"#any extension will be removed.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"FFile.basename("/home/gumby/work/ruby.rb") #=> "ruby.rb" ;TI"CFile.basename("/home/gumby/work/ruby.rb", ".rb") #=> "ruby" ;TI"BFile.basename("/home/gumby/work/ruby.rb", ".*") #=> "ruby";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"9File.basename(file_name [, suffix] ) -> base_name ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00blockdev%3f-c.ri000064400000000703152345532370007420 0ustar00U:RDoc::AnyMethod[iI"blockdev?:ETI"File::blockdev?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"CReturns true if the named file is a block device.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"3File.blockdev?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00empty%3f-c.ri000064400000000710152345532370006763 0ustar00U:RDoc::AnyMethod[iI" empty?:ETI"File::empty?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"@Returns true if the named file exists and has ;TI"a zero size.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I".File.zero?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00writable_real%3f-c.ri000064400000001172152345532370010444 0ustar00U:RDoc::AnyMethod[iI"writable_real?:ETI"File::writable_real?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"IReturns true if the named file is writable by the real ;TI"6user and group id of this process. See access(3).;To:RDoc::Markup::BlankLineo; ; [I"MNote that some OS-level security features may cause this to return true ;TI"Aeven though the file is not writable by the real user/group.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"7File.writable_real?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00exist%3f-c.ri000064400000001005152345532370006757 0ustar00U:RDoc::AnyMethod[iI" exist?:ETI"File::exist?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"7Return true if the named file exists.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o; ; [I"J"file exists" means that stat() or fstat() system call is successful.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"1File.exist?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00ctime-i.ri000064400000001170152345532370006437 0ustar00U:RDoc::AnyMethod[iI" ctime:ETI"File#ctime;TF: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"JReturns the change time for file (that is, the time directory ;TI"Binformation about the file was changed, not the file itself).;To:RDoc::Markup::BlankLineo; ; [I"ENote that on Windows (NTFS), returns creation time (birth time).;T@o:RDoc::Markup::Verbatim; [I"BFile.new("testfile").ctime #=> Wed Apr 09 08:53:14 CDT 2003;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"file.ctime -> time ;T0[I"();T@FI" File;TcRDoc::NormalClass00atime-i.ri000064400000001022152345532370006431 0ustar00U:RDoc::AnyMethod[iI" atime:ETI"File#atime;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"FReturns the last access time (a Time object) for file, or ;TI"0epoch if file has not been accessed.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"BFile.new("testfile").atime #=> Wed Dec 31 18:00:00 CST 1969;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"file.atime -> time ;T0[I"();T@FI" File;TcRDoc::NormalClass00absolute_path-c.ri000064400000001521152345532370010162 0ustar00U:RDoc::AnyMethod[iI"absolute_path:ETI"File::absolute_path;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [ I"EConverts a pathname to an absolute pathname. Relative paths are ;TI"Ireferenced from the current working directory of the process unless ;TI"Fdir_string is given, in which case it will be used as the ;TI"Lstarting point. If the given pathname starts with a ``~'' ;TI"Bit is NOT expanded, it is treated as a normal directory name.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"NFile.absolute_path("~oracle/bin") #=> "/~oracle/bin";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"FFile.absolute_path(file_name [, dir_string] ) -> abs_file_name ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00lstat-i.ri000064400000001271152345532370006467 0ustar00U:RDoc::AnyMethod[iI" lstat:ETI"File#lstat;TF: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"BSame as IO#stat, but does not follow the last symbolic link. ;TI")Instead, reports on the link itself.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [ I"3File.symlink("testfile", "link2test") #=> 0 ;TI"4File.stat("testfile").size #=> 66 ;TI"f = File.new("link2test") ;TI"3f.lstat.size #=> 8 ;TI"3f.stat.size #=> 66;T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"file.lstat -> stat ;T0[I"();T@FI" File;TcRDoc::NormalClass00join-c.ri000064400000000774152345532370006300 0ustar00U:RDoc::AnyMethod[iI" join:ETI"File::join;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I">Returns a new string formed by joining the strings using ;TI""/".;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"=File.join("usr", "mail", "gumby") #=> "usr/mail/gumby";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"(File.join(string, ...) -> string ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00file%3f-c.ri000064400000001071152345532370006545 0ustar00U:RDoc::AnyMethod[iI" file?:ETI"File::file?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"EReturns +true+ if the named +file+ exists and is a regular file.;To:RDoc::Markup::BlankLineo; ; [I" +file+ can be an IO object.;T@o; ; [I"RIf the +file+ argument is a symbolic link, it will resolve the symbolic link ;TI"-and use the file referenced by the link.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"'File.file?(file) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00directory%3f-c.ri000064400000001141152345532370007630 0ustar00U:RDoc::AnyMethod[iI"directory?:ETI"File::directory?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"AReturns true if the named file is a directory, ;TI"Eor a symlink that points at a directory, and false ;TI"otherwise.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I"File.directory?(".");T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"4File.directory?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00world_writable%3f-c.ri000064400000001557152345532370010657 0ustar00U:RDoc::AnyMethod[iI"world_writable?:ETI"File::world_writable?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [ I"CIf file_name is writable by others, returns an integer ;TI"Hrepresenting the file permission bits of file_name. Returns ;TI"Enil otherwise. The meaning of the bits is platform ;TI":dependent; on Unix systems, see stat(2).;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I";File.world_writable?("/tmp") #=> 511 ;TI"&m = File.world_writable?("/tmp") ;TI" "777";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"9File.world_writable?(file_name) -> integer or nil ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00lchmod-c.ri000064400000000777152345532370006612 0ustar00U:RDoc::AnyMethod[iI" lchmod:ETI"File::lchmod;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"GEquivalent to File::chmod, but does not follow symbolic links (so ;TI"Fit will change the permissions associated with the link, not the ;TI"7file referenced by the link). Often not available.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"7File.lchmod(mode_int, file_name, ...) -> integer ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00world_readable%3f-c.ri000064400000001566152345532370010605 0ustar00U:RDoc::AnyMethod[iI"world_readable?:ETI"File::world_readable?;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [ I"CIf file_name is readable by others, returns an integer ;TI"Hrepresenting the file permission bits of file_name. Returns ;TI"Enil otherwise. The meaning of the bits is platform ;TI":dependent; on Unix systems, see stat(2).;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T@o:RDoc::Markup::Verbatim; [I";File.world_readable?("/etc/passwd") #=> 420 ;TI"-m = File.world_readable?("/etc/passwd") ;TI" "644";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"9File.world_readable?(file_name) -> integer or nil ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00symlink%3f-c.ri000064400000000567152345532370007325 0ustar00U:RDoc::AnyMethod[iI" symlink?:ETI"File::symlink?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"DReturns true if the named file is a symbolic link.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"2File.symlink?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00extname-c.ri000064400000002224152345532370006772 0ustar00U:RDoc::AnyMethod[iI" extname:ETI"File::extname;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"?Returns the extension (the portion of file name in +path+ ;TI"$starting from the last period).;To:RDoc::Markup::BlankLineo; ; [I"HIf +path+ is a dotfile, or starts with a period, then the starting ;TI"6dot is not dealt with the start of the extension.;T@o; ; [I"QAn empty string will also be returned when the period is the last character ;TI"in +path+.;T@o; ; [I"-On Windows, trailing dots are truncated.;T@o:RDoc::Markup::Verbatim; [ I"/File.extname("test.rb") #=> ".rb" ;TI"/File.extname("a/b/d/test.rb") #=> ".rb" ;TI"/File.extname(".a/b/d/test.rb") #=> ".rb" ;TI"7File.extname("foo.") #=> "" on Windows ;TI" "." on non-Windows ;TI",File.extname("test") #=> "" ;TI",File.extname(".profile") #=> "" ;TI".File.extname(".profile.sh") #=> ".sh";T: @format0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"$File.extname(path) -> string ;T0[I" (p1);T@%FI" File;TcRDoc::NormalClass00size%3f-c.ri000064400000000734152345532370006605 0ustar00U:RDoc::AnyMethod[iI" size?:ETI"File::size?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"RReturns +nil+ if +file_name+ doesn't exist or has zero size, the size of the ;TI"file otherwise.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"/File.size?(file_name) -> Integer or nil ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00dirname-c.ri000064400000001740152345532370006752 0ustar00U:RDoc::AnyMethod[iI" dirname:ETI"File::dirname;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [ I"FReturns all components of the filename given in file_name ;TI"Fexcept the last one (after first stripping trailing separators). ;TI"?The filename can be formed using both File::SEPARATOR and ;TI"FFile::ALT_SEPARATOR as the separator when File::ALT_SEPARATOR is ;TI"not nil.;To:RDoc::Markup::BlankLineo:RDoc::Markup::Verbatim; [I"GFile.dirname("/home/gumby/work/ruby.rb") #=> "/home/gumby/work" ;T: @format0o; ; [I"HIf +level+ is given, removes the last +level+ components, not only ;TI" one.;T@o; ; [I"CFile.dirname("/home/gumby/work/ruby.rb", 2) #=> "/home/gumby" ;TI"8File.dirname("/home/gumby/work/ruby.rb", 4) #=> "/";T; 0: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"6File.dirname(file_name, level = 1) -> dir_name ;T0[I" (*args);T@FI" File;TcRDoc::NormalClass00fnmatch-c.ri000064400000012320152345532370006747 0ustar00U:RDoc::AnyMethod[iI" fnmatch:ETI"File::fnmatch;TT: privateo:RDoc::Markup::Document: @parts[ o:RDoc::Markup::Paragraph; [I"MReturns true if +path+ matches against +pattern+. The pattern is not a ;TI"Lregular expression; instead it follows rules similar to shell filename ;TI"*;T; [ o; ; [I"FMatches any file. Can be restricted by other values in the glob. ;TI"0Equivalent to /.*/x in regexp.;T@o; ; ;;[ o;;[I"*;T; [o; ; [I"Matches all regular files;To;;[I"c*;T; [o; ; [I"4Matches all files beginning with c;To;;[I"*c;T; [o; ; [I"1Matches all files ending with c;To;;[I"\*c*;T; [o; ; [I"8Matches all files that have c in them ;TI")(including at the beginning or end).;T@o; ; [I"FTo match hidden files (that start with a .) set the ;TI"File::FNM_DOTMATCH flag.;T@o;;[I"**;T; [o; ; [I":Matches directories recursively or files expansively.;T@o;;[I"?;T; [o; ; [I"LMatches any one character. Equivalent to /.{1}/ in regexp.;T@o;;[I"[set];T; [o; ; [I"NMatches any one character in +set+. Behaves exactly like character sets ;TI"=in Regexp, including set negation ([^a-z]).;T@o;;[I"\\;T; [o; ; [I"$Escapes the next metacharacter.;T@o;;[I"{a,b};T; [o; ; [I"KMatches pattern a and pattern b if File::FNM_EXTGLOB flag is enabled. ;TI"8Behaves like a Regexp union ((?:a|b)).;T@o; ; [I"M+flags+ is a bitwise OR of the FNM_XXX constants. The same ;TI"2glob pattern and flags are used by Dir::glob.;T@o; ; [I"Examples:;T@o:RDoc::Markup::Verbatim; [0I"MFile.fnmatch('cat', 'cat') #=> true # match entire string ;TI"SFile.fnmatch('cat', 'category') #=> false # only match partial string ;TI" ;TI"eFile.fnmatch('c{at,ub}s', 'cats') #=> false # { } isn't supported by default ;TI"fFile.fnmatch('c{at,ub}s', 'cats', File::FNM_EXTGLOB) #=> true # { } is supported on FNM_EXTGLOB ;TI" ;TI"TFile.fnmatch('c?t', 'cat') #=> true # '?' match only 1 character ;TI"?File.fnmatch('c??t', 'cat') #=> false # ditto ;TI"XFile.fnmatch('c*', 'cats') #=> true # '*' match 0 or more characters ;TI"?File.fnmatch('c*t', 'c/a/b/t') #=> true # ditto ;TI"VFile.fnmatch('ca[a-z]', 'cat') #=> true # inclusive bracket expression ;TI"cFile.fnmatch('ca[^t]', 'cat') #=> false # exclusive bracket expression ('^' or '!') ;TI" ;TI"OFile.fnmatch('cat', 'CAT') #=> false # case sensitive ;TI"QFile.fnmatch('cat', 'CAT', File::FNM_CASEFOLD) #=> true # case insensitive ;TI"fFile.fnmatch('cat', 'CAT', File::FNM_SYSCASE) #=> true or false # depends on the system default ;TI" ;TI"jFile.fnmatch('?', '/', File::FNM_PATHNAME) #=> false # wildcard doesn't match '/' on FNM_PATHNAME ;TI"EFile.fnmatch('*', '/', File::FNM_PATHNAME) #=> false # ditto ;TI"EFile.fnmatch('[/]', '/', File::FNM_PATHNAME) #=> false # ditto ;TI" ;TI"cFile.fnmatch('\?', '?') #=> true # escaped wildcard becomes ordinary ;TI"cFile.fnmatch('\a', 'a') #=> true # escaped ordinary remains ordinary ;TI"aFile.fnmatch('\a', '\a', File::FNM_NOESCAPE) #=> true # FNM_NOESCAPE makes '\' ordinary ;TI"fFile.fnmatch('[\?]', '?') #=> true # can escape inside bracket expression ;TI" ;TI"eFile.fnmatch('*', '.profile') #=> false # wildcard doesn't match leading ;TI"YFile.fnmatch('*', '.profile', File::FNM_DOTMATCH) #=> true # period by default. ;TI"CFile.fnmatch('.*', '.profile') #=> true ;TI" ;TI"CFile.fnmatch('**/*.rb', 'main.rb') #=> false ;TI"CFile.fnmatch('**/*.rb', './main.rb') #=> false ;TI"BFile.fnmatch('**/*.rb', 'lib/song.rb') #=> true ;TI"BFile.fnmatch('**.rb', 'main.rb') #=> true ;TI"CFile.fnmatch('**.rb', './main.rb') #=> false ;TI"BFile.fnmatch('**.rb', 'lib/song.rb') #=> true ;TI"BFile.fnmatch('*', 'dave/.profile') #=> true ;TI" ;TI"JFile.fnmatch('**/foo', 'a/b/c/foo', File::FNM_PATHNAME) #=> true ;TI"JFile.fnmatch('**/foo', '/a/b/c/foo', File::FNM_PATHNAME) #=> true ;TI"JFile.fnmatch('**/foo', 'c:/a/b/c/foo', File::FNM_PATHNAME) #=> true ;TI"KFile.fnmatch('**/foo', 'a/.b/c/foo', File::FNM_PATHNAME) #=> false ;TI"[File.fnmatch('**/foo', 'a/.b/c/foo', File::FNM_PATHNAME | File::FNM_DOTMATCH) #=> true;T: @format0: @fileI" dir.rb;T:0@omit_headings_from_table_of_contents_below0I"zFile.fnmatch( pattern, path, [flags] ) -> (true or false) File.fnmatch?( pattern, path, [flags] ) -> (true or false) ;T0[[I" fnmatch?;To;; [;@;0I"(pattern, path, flags = 0);T@FI" File;TcRDoc::NormalClass00socket%3f-c.ri000064400000000667152345532370007130 0ustar00U:RDoc::AnyMethod[iI" socket?:ETI"File::socket?;TT: privateo:RDoc::Markup::Document: @parts[o:RDoc::Markup::Paragraph; [I"=Returns true if the named file is a socket.;To:RDoc::Markup::BlankLineo; ; [I"%_file_name_ can be an IO object.;T: @fileI" file.c;T:0@omit_headings_from_table_of_contents_below0I"1File.socket?(file_name) -> true or false ;T0[I" (p1);T@FI" File;TcRDoc::NormalClass00Path.pm000064400000124363152345537030006016 0ustar00package File::Path; use 5.005_04; use strict; use Cwd 'getcwd'; use File::Basename (); use File::Spec (); BEGIN { if ( $] < 5.006 ) { # can't say 'opendir my $dh, $dirname' # need to initialise $dh eval 'use Symbol'; } } use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); $VERSION = '2.15'; $VERSION = eval $VERSION; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @EXPORT_OK = qw(make_path remove_tree); BEGIN { for (qw(VMS MacOS MSWin32 os2)) { no strict 'refs'; *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 }; } # These OSes complain if you want to remove a file that you have no # write permission to: *_FORCE_WRITABLE = ( grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2) ) ? sub () { 1 } : sub () { 0 }; # Unix-like systems need to stat each directory in order to detect # race condition. MS-Windows is immune to this particular attack. *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 }; } sub _carp { require Carp; goto &Carp::carp; } sub _croak { require Carp; goto &Carp::croak; } sub _error { my $arg = shift; my $message = shift; my $object = shift; if ( $arg->{error} ) { $object = '' unless defined $object; $message .= ": $!" if $!; push @{ ${ $arg->{error} } }, { $object => $message }; } else { _carp( defined($object) ? "$message for $object: $!" : "$message: $!" ); } } sub __is_arg { my ($arg) = @_; # If client code blessed an array ref to HASH, this will not work # properly. We could have done $arg->isa() wrapped in eval, but # that would be expensive. This implementation should suffice. # We could have also used Scalar::Util:blessed, but we choose not # to add this dependency return ( ref $arg eq 'HASH' ); } sub make_path { push @_, {} unless @_ and __is_arg( $_[-1] ); goto &mkpath; } sub mkpath { my $old_style = !( @_ and __is_arg( $_[-1] ) ); my $data; my $paths; if ($old_style) { my ( $verbose, $mode ); ( $paths, $verbose, $mode ) = @_; $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); $data->{verbose} = $verbose; $data->{mode} = defined $mode ? $mode : oct '777'; } else { my %args_permitted = map { $_ => 1 } ( qw| chmod error group mask mode owner uid user verbose | ); my %not_on_win32_args = map { $_ => 1 } ( qw| group owner uid user | ); my @bad_args = (); my @win32_implausible_args = (); my $arg = pop @_; for my $k (sort keys %{$arg}) { if (! $args_permitted{$k}) { push @bad_args, $k; } elsif ($not_on_win32_args{$k} and _IS_MSWIN32) { push @win32_implausible_args, $k; } else { $data->{$k} = $arg->{$k}; } } _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args") if @bad_args; _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args") if @win32_implausible_args; $data->{mode} = delete $data->{mask} if exists $data->{mask}; $data->{mode} = oct '777' unless exists $data->{mode}; ${ $data->{error} } = [] if exists $data->{error}; unless (@win32_implausible_args) { $data->{owner} = delete $data->{user} if exists $data->{user}; $data->{owner} = delete $data->{uid} if exists $data->{uid}; if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) { my $uid = ( getpwnam $data->{owner} )[2]; if ( defined $uid ) { $data->{owner} = $uid; } else { _error( $data, "unable to map $data->{owner} to a uid, ownership not changed" ); delete $data->{owner}; } } if ( exists $data->{group} and $data->{group} =~ /\D/ ) { my $gid = ( getgrnam $data->{group} )[2]; if ( defined $gid ) { $data->{group} = $gid; } else { _error( $data, "unable to map $data->{group} to a gid, group ownership not changed" ); delete $data->{group}; } } if ( exists $data->{owner} and not exists $data->{group} ) { $data->{group} = -1; # chown will leave group unchanged } if ( exists $data->{group} and not exists $data->{owner} ) { $data->{owner} = -1; # chown will leave owner unchanged } } $paths = [@_]; } return _mkpath( $data, $paths ); } sub _mkpath { my $data = shift; my $paths = shift; my ( @created ); foreach my $path ( @{$paths} ) { next unless defined($path) and length($path); $path .= '/' if _IS_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); # Coverage note: It's not clear how we would test the condition: # '-d $parent or $path eq $parent' unless ( -d $parent or $path eq $parent ) { push( @created, _mkpath( $data, [$parent] ) ); } print "mkdir $path\n" if $data->{verbose}; if ( mkdir( $path, $data->{mode} ) ) { push( @created, $path ); if ( exists $data->{owner} ) { # NB: $data->{group} guaranteed to be set during initialisation if ( !chown $data->{owner}, $data->{group}, $path ) { _error( $data, "Cannot change ownership of $path to $data->{owner}:$data->{group}" ); } } if ( exists $data->{chmod} ) { # Coverage note: It's not clear how we would trigger the next # 'if' block. Failure of 'chmod' might first result in a # system error: "Permission denied". if ( !chmod $data->{chmod}, $path ) { _error( $data, "Cannot change permissions of $path to $data->{chmod}" ); } } } else { my $save_bang = $!; # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented # as: # Error information specific to the current operating system. At the # moment, this differs from "$!" under only VMS, OS/2, and Win32 # (and for MacPerl). On all other platforms, $^E is always just the # same as $!. 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 ( $data->{error} ) { push @{ ${ $data->{error} } }, { $path => $e }; } else { _croak("mkdir $path: $e"); } } } } return @created; } sub remove_tree { push @_, {} unless @_ and __is_arg( $_[-1] ); goto &rmtree; } sub _is_subdir { my ( $dir, $test ) = @_; my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 ); my ( $tv, $td ) = File::Spec->splitpath( $test, 1 ); # not on same volume return 0 if $dv ne $tv; my @d = File::Spec->splitdir($dd); my @t = File::Spec->splitdir($td); # @t can't be a subdir if it's shorter than @d return 0 if @t < @d; return join( '/', @d ) eq join( '/', splice @t, 0, +@d ); } sub rmtree { my $old_style = !( @_ and __is_arg( $_[-1] ) ); my ($arg, $data, $paths); if ($old_style) { my ( $verbose, $safe ); ( $paths, $verbose, $safe ) = @_; $data->{verbose} = $verbose; $data->{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 { my %args_permitted = map { $_ => 1 } ( qw| error keep_root result safe verbose | ); my @bad_args = (); my $arg = pop @_; for my $k (sort keys %{$arg}) { if (! $args_permitted{$k}) { push @bad_args, $k; } else { $data->{$k} = $arg->{$k}; } } _carp("Unrecognized option(s) passed to remove_tree(): @bad_args") if @bad_args; ${ $data->{error} } = [] if exists $data->{error}; ${ $data->{result} } = [] if exists $data->{result}; # Wouldn't it make sense to do some validation on @_ before assigning # to $paths here? # In the $old_style case we guarantee that each path is both defined # and non-empty. We don't check that here, which means we have to # check it later in the first condition in this line: # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { # Granted, that would be a change in behavior for the two # non-old-style interfaces. $paths = [@_]; } $data->{prefix} = ''; $data->{depth} = 0; my @clean_path; $data->{cwd} = getcwd() or do { _error( $data, "cannot fetch initial working directory" ); return 0; }; for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint for my $p (@$paths) { # need to fixup case and map \ to / on Windows my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p; my $ortho_cwd = _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd}; my $ortho_root_length = length($ortho_root); $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']' if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { local $! = 0; _error( $data, "cannot remove path when cwd is $data->{cwd}", $p ); next; } if (_IS_MACOS) { $p = ":$p" unless $p =~ /:/; $p .= ":" unless $p =~ /:\z/; } elsif ( _IS_MSWIN32 ) { $p =~ s{[/\\]\z}{}; } else { $p =~ s{/\z}{}; } push @clean_path, $p; } @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do { _error( $data, "cannot stat initial working directory", $data->{cwd} ); return 0; }; return _rmtree( $data, \@clean_path ); } sub _rmtree { my $data = shift; my $paths = shift; my $count = 0; my $curdir = File::Spec->curdir(); my $updir = File::Spec->updir(); my ( @files, $root ); ROOT_DIR: foreach my $root (@$paths) { # since we chdir into each directory, it may not be obvious # to figure out where we are if we generate a message about # a file name. We therefore construct a semi-canonical # filename, anchored from the directory being unlinked (as # opposed to being truly canonical, anchored from the root (/). my $canon = $data->{prefix} ? File::Spec->catfile( $data->{prefix}, $root ) : $root; my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] or next ROOT_DIR; if ( -d _ ) { $root = VMS::Filespec::vmspath( 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) # This uses fchmod to avoid traversing outside of the proper # location (CVE-2017-6512) my $root_fh; if (open($root_fh, '<', $root)) { my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1]; $perm &= oct '7777'; my $nperm = $perm | oct '700'; local $@; if ( !( $data->{safe} or $nperm == $perm or !-d _ or $fh_dev ne $ldev or $fh_inode ne $lino or eval { chmod( $nperm, $root_fh ) } ) ) { _error( $data, "cannot make child directory read-write-exec", $canon ); next ROOT_DIR; } close $root_fh; } if ( !chdir($root) ) { _error( $data, "cannot chdir to child", $canon ); next ROOT_DIR; } } my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ] or do { _error( $data, "cannot stat current working directory", $canon ); next ROOT_DIR; }; if (_NEED_STAT_CHECK) { ( $ldev eq $cur_dev and $lino eq $cur_inode ) or _croak( "directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting." ); } $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits my $nperm = $perm | oct '700'; # 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 ( !( $data->{safe} or $nperm == $perm or chmod( $nperm, $curdir ) ) ) { _error( $data, "cannot make directory read+writeable", $canon ); $nperm = $perm; } my $d; $d = gensym() if $] < 5.006; if ( !opendir $d, $curdir ) { _error( $data, "cannot opendir", $canon ); @files = (); } else { if ( !defined ${^TAINT} or ${^TAINT} ) { # Blindly untaint dir names if taint mode is active @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; } @files = grep { $_ ne $updir and $_ ne $curdir } @files; if (@files) { # remove the contained files before the directory itself my $narg = {%$data}; @{$narg}{qw(device inode cwd prefix depth)} = ( $cur_dev, $cur_inode, $updir, $canon, $data->{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( $data, "cannot reset chmod", $canon ); } # don't leave the client code in an unexpected directory chdir( $data->{cwd} ) or _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting."); # ensure that a chdir upwards didn't take us somewhere other # than we expected (see CVE-2002-0435) ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ] or _croak( "cannot stat prior working directory $data->{cwd}: $!, aborting." ); if (_NEED_STAT_CHECK) { ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode ) or _croak( "previous directory $data->{cwd} " . "changed before entering $canon, " . "expected dev=$ldev ino=$lino, " . "actual dev=$cur_dev ino=$cur_inode, aborting." ); } if ( $data->{depth} or !$data->{keep_root} ) { if ( $data->{safe} && ( _IS_VMS ? !&VMS::Filespec::candelete($root) : !-w $root ) ) { print "skipped $root\n" if $data->{verbose}; next ROOT_DIR; } if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) { _error( $data, "cannot make directory writeable", $canon ); } print "rmdir $root\n" if $data->{verbose}; if ( rmdir $root ) { push @{ ${ $data->{result} } }, $root if $data->{result}; ++$count; } else { _error( $data, "cannot remove directory", $canon ); if ( _FORCE_WRITABLE && !chmod( $perm, ( _IS_VMS ? VMS::Filespec::fileify($root) : $root ) ) ) { _error( $data, 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 ( $data->{safe} && ( _IS_VMS ? !&VMS::Filespec::candelete($root) : !( -l $root || -w $root ) ) ) { print "skipped $root\n" if $data->{verbose}; next ROOT_DIR; } my $nperm = $perm & oct '7777' | oct '600'; if ( _FORCE_WRITABLE and $nperm != $perm and not chmod $nperm, $root ) { _error( $data, "cannot make file writeable", $canon ); } print "unlink $canon\n" if $data->{verbose}; # delete all versions under VMS for ( ; ; ) { if ( unlink $root ) { push @{ ${ $data->{result} } }, $root if $data->{result}; } else { _error( $data, "cannot unlink file", $canon ); _FORCE_WRITABLE and chmod( $perm, $root ) or _error( $data, sprintf( "cannot restore permissions to 0%o", $perm ), $canon ); last; } ++$count; last unless _IS_VMS && lstat $root; } } } return $count; } sub _slash_lc { # fix up slashes and case on MSWin32 so that we can determine that # c:\path\to\dir is underneath C:/Path/To my $path = shift; $path =~ tr{\\}{/}; return lc($path); } 1; __END__ =head1 NAME File::Path - Create or remove directory trees =head1 VERSION 2.15 - released June 07 2017. =head1 SYNOPSIS use File::Path qw(make_path remove_tree); @created = make_path('foo/bar/baz', '/zug/zwang'); @created = make_path('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711, }); make_path('foo/bar/baz', '/zug/zwang', { chmod => 0777, }); $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', { verbose => 1, error => \my $err_list, safe => 1, }); # legacy (interface promoted before v2.00) @created = mkpath('/foo/bar/baz'); @created = mkpath('/foo/bar/baz', 1, 0711); @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); $removed_count = rmtree('foo/bar/baz', 1, 1); $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); # legacy (interface promoted before v2.06) @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); =head1 DESCRIPTION This module provides a convenient way to create directories of arbitrary depth and to delete an entire directory subtree from the filesystem. The following functions are provided: =over =item make_path( $dir1, $dir2, .... ) =item make_path( $dir1, $dir2, ...., \%opts ) The C function creates the given directories if they don't exist before, much like the Unix command C. The function accepts a list of directories to be created. Its behaviour may be tuned by an optional hashref appearing as the last parameter on the call. The function returns the list of directories actually created during the call; in scalar context the number of directories created. The following keys are recognised in the option hash: =over =item mode => $num The numeric permissions mode to apply to each created directory (defaults to C<0777>), to be modified by the current C. If the directory already exists (and thus does not need to be created), the permissions will not be modified. C is recognised as an alias for this parameter. =item chmod => $num Takes a numeric mode to apply to each created directory (not modified by the current C). If the directory already exists (and thus does not need to be created), the permissions will not be modified. =item verbose => $bool If present, will cause C to print the name of each directory as it is created. By default nothing is printed. =item error => \$err If present, it should be a reference to a scalar. This scalar will be made to reference an array, which will be used to store any errors that are encountered. See the L section for more information. If this parameter is not used, certain error conditions may raise a fatal error that will cause the program to halt, unless trapped in an C block. =item owner => $owner =item user => $owner =item uid => $owner If present, will cause any created directory to be owned by C<$owner>. If the value is numeric, it will be interpreted as a uid; otherwise a username is assumed. An error will be issued if the username cannot be mapped to a uid, the uid does not exist or the process lacks the privileges to change ownership. Ownership of directories that already exist will not be changed. C and C are aliases of C. =item group => $group If present, will cause any created directory to be owned by the group C<$group>. If the value is numeric, it will be interpreted as a gid; otherwise a group name is assumed. An error will be issued if the group name cannot be mapped to a gid, the gid does not exist or the process lacks the privileges to change group ownership. Group ownership of directories that already exist will not be changed. make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'}; =back =item mkpath( $dir ) =item mkpath( $dir, $verbose, $mode ) =item mkpath( [$dir1, $dir2,...], $verbose, $mode ) =item mkpath( $dir1, $dir2,..., \%opt ) The C function provide the legacy interface of C with a different interpretation of the arguments passed. The behaviour and return value of the function is otherwise identical to C. =item remove_tree( $dir1, $dir2, .... ) =item remove_tree( $dir1, $dir2, ...., \%opts ) The C function deletes the given directories and any files and subdirectories they might contain, much like the Unix command C or the Windows commands C and C. The function accepts a list of directories to be removed. (In point of fact, it will also accept filesystem entries which are not directories, such as regular files and symlinks. But, as its name suggests, its intent is to remove trees rather than individual files.) C's behaviour may be tuned by an optional hashref appearing as the last parameter on the call. If an empty string is passed to C, an error will occur. B For security reasons, we strongly advise use of the hashref-as-final-argument syntax -- specifically, with a setting of the C element to a true value. remove_tree( $dir1, $dir2, ...., { safe => 1, ... # other key-value pairs }, ); The function returns the number of files successfully deleted. The following keys are recognised in the option hash: =over =item verbose => $bool If present, will cause C to print the name of each file as it is unlinked. By default nothing is printed. =item safe => $bool When set to a true value, will cause C to skip the files for which the process lacks the required privileges needed to delete files, such as delete privileges on VMS. In other words, the code will make no attempt to alter file permissions. Thus, if the process is interrupted, no filesystem object will be left in a more permissive mode. =item keep_root => $bool When set to a true value, will cause all files and subdirectories to be removed, except the initially specified directories. This comes in handy when cleaning out an application's scratch directory. remove_tree( '/tmp', {keep_root => 1} ); =item result => \$res If present, it should be a reference to a scalar. This scalar will be made to reference an array, which will be used to store all files and directories unlinked during the call. If nothing is unlinked, the array will be empty. remove_tree( '/tmp', {result => \my $list} ); print "unlinked $_\n" for @$list; This is a useful alternative to the C key. =item error => \$err If present, it should be a reference to a scalar. This scalar will be made to reference an array, which will be used to store any errors that are encountered. See the L section for more information. Removing things is a much more dangerous proposition than creating things. As such, there are certain conditions that C may encounter that are so dangerous that the only sane action left is to kill the program. Use C to trap all that is reasonable (problems with permissions and the like), and let it die if things get out of hand. This is the safest course of action. =back =item rmtree( $dir ) =item rmtree( $dir, $verbose, $safe ) =item rmtree( [$dir1, $dir2,...], $verbose, $safe ) =item rmtree( $dir1, $dir2,..., \%opt ) The C function provide the legacy interface of C with a different interpretation of the arguments passed. The behaviour and return value of the function is otherwise identical to C. B For security reasons, we strongly advise use of the hashref-as-final-argument syntax, specifically with a setting of the C element to a true value. rmtree( $dir1, $dir2, ...., { safe => 1, ... # other key-value pairs }, ); =back =head2 ERROR HANDLING =over 4 =item B The following error handling mechanism is consistent throughout all code paths EXCEPT in cases where the ROOT node is nonexistent. In version 2.11 the maintainers attempted to rectify this inconsistency but too many downstream modules encountered problems. In such case, if you require root node evaluation or error checking prior to calling C or C, you should take additional precautions. =back If C or C encounters an error, a diagnostic message will be printed to C via C (for non-fatal errors) or via C (for fatal errors). If this behaviour is not desirable, the C attribute may be used to hold a reference to a variable, which will be used to store the diagnostics. The variable is made a reference to an array of hash references. Each hash contain a single key/value pair where the key is the name of the file, and the value is the error message (including the contents of C<$!> when appropriate). If a general error is encountered the diagnostic key will be empty. An example usage looks like: remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} ); if ($err && @$err) { for my $diag (@$err) { my ($file, $message) = %$diag; if ($file eq '') { print "general error: $message\n"; } else { print "problem unlinking $file: $message\n"; } } } else { print "No error encountered\n"; } Note that if no errors are encountered, C<$err> will reference an empty array. This means that C<$err> will always end up TRUE; so you need to test C<@$err> to determine if errors occurred. =head2 NOTES C blindly exports C and C into the current namespace. These days, this is considered bad style, but to change it now would break too much code. Nonetheless, you are invited to specify what it is you are expecting to use: use File::Path 'rmtree'; The routines C and C are B exported by default. You must specify which ones you want to use. use File::Path 'remove_tree'; Note that a side-effect of the above is that C and C are no longer exported at all. This is due to the way the C module works. If you are migrating a codebase to use the new interface, you will have to list everything explicitly. But that's just good practice anyway. use File::Path qw(remove_tree rmtree); =head3 API CHANGES The API was changed in the 2.0 branch. For a time, C and C tried, unsuccessfully, to deal with the two different calling mechanisms. This approach was considered a failure. The new semantics are now only available with C and C. The old semantics are only available through C and C. Users are strongly encouraged to upgrade to at least 2.08 in order to avoid surprises. =head3 SECURITY CONSIDERATIONS There were race conditions in the 1.x implementations of File::Path's C 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 parameter is set (or the third parameter in the traditional interface is TRUE), should a C be interrupted, files that were originally in read-only mode may now have their permissions set to a read-write (or "delete OK") mode. The following CVE reports were previously filed against File-Path and are believed to have been addressed: =over 4 =item * L =item * L =back In February 2017 the cPanel Security Team reported an additional vulnerability in File-Path. The C logic to make directories traversable can be abused to set the mode on an attacker-chosen file to an attacker-chosen value. This is due to the time-of-check-to-time-of-use (TOCTTOU) race condition (L) between the C that decides the inode is a directory and the C that tries to make it user-rwx. CPAN versions 2.13 and later incorporate a patch provided by John Lightsey to address this problem. This vulnerability has been reported as CVE-2017-6512. =head1 DIAGNOSTICS FATAL errors will cause the program to halt (C), since the problem is so severe that it would be dangerous to continue. (This can always be trapped with C, 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 if 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 Ced about. Program execution will not be halted. =over 4 =item mkdir [path]: [errmsg] (SEVERE) C 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 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 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 attempted to determine the initial directory by calling C, but the call failed for some reason. No attempt will be made to delete anything. =item cannot stat initial working directory: [errmsg] C attempted to stat the initial directory (after having successfully obtained its name via C), however, the call failed for some reason. No attempt will be made to delete anything. =item cannot chdir to [dir]: [errmsg] C attempted to set the working directory in order to begin deleting the objects therein, but was unsuccessful. This is usually a permissions issue. The routine will continue to delete other things, but this directory will be left intact. =item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) C recorded the device and inode of a directory, and then moved into it. It then performed a C 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 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 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, after having deleted everything in a directory, attempted to restore its permissions to the original state but failed. The directory may wind up being left behind. =item cannot remove [dir] when cwd is [dir] The current working directory of the program is F and you are attempting to remove an ancestor, such as F. The directory tree is left untouched. The solution is to C out of the child directory to a place outside the directory tree to be removed. =item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL) C, after having deleted everything and restored the permissions of a directory, was unable to chdir back to the parent. The program halts to avoid a race condition from occurring. =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) C was unable to stat the parent directory after having 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. =item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) When C 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 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 attempted to remove a directory, but failed. This may be because some objects that were unable to be removed remain in the directory, or it could be 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 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 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 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 was also unable to restore the permissions on the file to a possibly less permissive setting. (Permissions given in octal). =item unable to map [owner] to a uid, ownership not changed"); C was instructed to give the ownership of created directories to the symbolic name [owner], but C did not return the corresponding numeric uid. The directory will be created, but ownership will not be changed. =item unable to map [group] to a gid, group ownership not changed C was instructed to give the group ownership of created directories to the symbolic name [group], but C did not return the corresponding numeric gid. The directory will be created, but group ownership will not be changed. =back =head1 SEE ALSO =over 4 =item * L 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. =item * L When removing directory trees, if you want to examine each file to decide whether to delete it (and possibly leaving large swathes alone), F offers a convenient and flexible approach to examining directory trees. =back =head1 BUGS AND LIMITATIONS The following describes F limitations and how to report bugs. =head2 MULTITHREADED APPLICATIONS F C and C will not work with multithreaded applications due to its use of C. At this time, no warning or error is generated in this situation. You will certainly encounter unexpected results. The implementation that surfaces this limitation will not be changed. See the F module for functionality similar to F but which does not C. =head2 NFS Mount Points F is not responsible for triggering the automounts, mirror mounts, and the contents of network mounted filesystems. If your NFS implementation requires an action to be performed on the filesystem in order for F to perform operations, it is strongly suggested you assure filesystem availability by reading the root of the mounted filesystem. =head2 REPORTING BUGS Please report all bugs on the RT queue, either via the web interface: L or by email: bug-File-Path@rt.cpan.org In either case, please B patches to the bug report rather than including them inline in the web post or the body of the email. You can also send pull requests to the Github repository: L =head1 ACKNOWLEDGEMENTS Paul Szabo identified the race condition originally, and Brendan O'Dea wrote an implementation for Debian that addressed the problem. That code was used as a basis for the current code. Their efforts are greatly appreciated. Gisle Aas made a number of improvements to the documentation for 2.07 and his advice and assistance is also greatly appreciated. =head1 AUTHORS Prior authors and maintainers: Tim Bunce, Charles Bailey, and David Landgren >. Current maintainers are Richard Elberger > and James (Jim) Keenan >. =head1 CONTRIBUTORS Contributors to File::Path, in alphabetical order by first name. =over 1 =item > =item Charlie Gonzalez > =item Craig A. Berry > =item James E Keenan > =item John Lightsey > =item Nigel Horne > =item Richard Elberger > =item Ryan Yee > =item Skye Shaw > =item Tom Lutz > =item Will Sheppard > =back =head1 COPYRIGHT This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren, James Keenan and Richard Elberger 1995-2017. 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 Which.pm000064400000022631152345537030006157 0ustar00package File::Which; use strict; use warnings; use Exporter (); use File::Spec (); # ABSTRACT: Perl implementation of the which utility as an API our $VERSION = '1.22'; # VERSION our @ISA = 'Exporter'; our @EXPORT = 'which'; our @EXPORT_OK = 'where'; use constant IS_VMS => ($^O eq 'VMS'); use constant IS_MAC => ($^O eq 'MacOS'); use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2'); use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys'); # For Win32 systems, stores the extensions used for # executable files # For others, the empty string is used # because 'perl' . '' eq 'perl' => easier my @PATHEXT = (''); if ( IS_DOS ) { # WinNT. PATHEXT might be set on Cygwin, but not used. if ( $ENV{PATHEXT} ) { push @PATHEXT, split ';', $ENV{PATHEXT}; } else { # Win9X or other: doesn't have PATHEXT, so needs hardcoded. push @PATHEXT, qw{.com .exe .bat}; } } elsif ( IS_VMS ) { push @PATHEXT, qw{.exe .com}; } elsif ( IS_CYG ) { # See this for more info # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe push @PATHEXT, qw{.exe .com}; } sub which { my ($exec) = @_; return undef unless defined $exec; return undef if $exec eq ''; my $all = wantarray; my @results = (); # check for aliases first if ( IS_VMS ) { my $symbol = `SHOW SYMBOL $exec`; chomp($symbol); unless ( $? ) { return $symbol unless $all; push @results, $symbol; } } if ( IS_MAC ) { my @aliases = split /\,/, $ENV{Aliases}; foreach my $alias ( @aliases ) { # This has not been tested!! # PPT which says MPW-Perl cannot resolve `Alias $alias`, # let's just hope it's fixed if ( lc($alias) eq lc($exec) ) { chomp(my $file = `Alias $alias`); last unless $file; # if it failed, just go on the normal way return $file unless $all; push @results, $file; # we can stop this loop as if it finds more aliases matching, # it'll just be the same result anyway last; } } } return $exec if !IS_VMS and !IS_MAC and !IS_DOS and $exec =~ /\// and -f $exec and -x $exec; my @path = File::Spec->path; if ( IS_DOS or IS_VMS or IS_MAC ) { unshift @path, File::Spec->curdir; } foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) { for my $ext ( @PATHEXT ) { my $file = $base.$ext; # We don't want dirs (as they are -x) next if -d $file; if ( # Executable, normal case -x _ or ( # MacOS doesn't mark as executable so we check -e IS_MAC || ( ( IS_DOS or IS_CYG ) and grep { $file =~ /$_\z/i } @PATHEXT[1..$#PATHEXT] ) # DOSish systems don't pass -x on # non-exe/bat/com files. so we check -e. # However, we don't want to pass -e on files # that aren't in PATHEXT, like README. and -e _ ) ) { return $file unless $all; push @results, $file; } } } if ( $all ) { return @results; } else { return undef; } } sub where { # force wantarray my @res = which($_[0]); return @res; } 1; __END__ =pod =encoding UTF-8 =head1 NAME File::Which - Perl implementation of the which utility as an API =head1 VERSION version 1.22 =head1 SYNOPSIS use File::Which; # exports which() use File::Which qw(which where); # exports which() and where() my $exe_path = which 'perldoc'; my @paths = where 'perl'; # Or my @paths = which 'perl'; # an array forces search for all of them =head1 DESCRIPTION L finds the full or relative paths to executable programs on the system. This is normally the function of C utility. C is typically implemented as either a program or a built in shell command. On some platforms, such as Microsoft Windows it is not provided as part of the core operating system. This module provides a consistent API to this functionality regardless of the underlying platform. The focus of this module is correctness and portability. As a consequence platforms where the current directory is implicitly part of the search path such as Microsoft Windows will find executables in the current directory, whereas on platforms such as UNIX where this is not the case executables in the current directory will only be found if the current directory is explicitly added to the path. If you need a portable C on the command line in an environment that does not provide it, install L which provides a command line interface to this API. =head2 Implementations L searches the directories of the user's C (the current implementation uses L to determine the correct C), looking for executable files having the name specified as a parameter to L. Under Win32 systems, which do not have a notion of directly executable files, but uses special extensions such as C<.exe> and C<.bat> to identify them, C takes extra steps to assure that you will find the correct file (so for example, you might be searching for C, it'll try F, F, etc.) =head3 Linux, *BSD and other UNIXes There should not be any surprises here. The current directory will not be searched unless it is explicitly added to the path. =head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc) Windows NT has a special environment variable called C, which is used by the shell to look for executable files. Usually, it will contain a list in the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C finds such an environment variable, it parses the list and uses it as the different extensions. =head3 Cygwin Cygwin provides a Unix-like environment for Microsoft Windows users. In most ways it works like other Unix and Unix-like environments, but in a few key aspects it works like Windows. As with other Unix environments, the current directory is not included in the search unless it is explicitly included in the search path. Like on Windows, files with C<.EXE> or <.BAT> extensions will be discovered even if they are not part of the query. C<.COM> or extensions specified using the C environment variable will NOT be discovered without the fully qualified name, however. =head3 Windows 95, 98, ME, MS-DOS, OS/2 This set of operating systems don't have the C variable, and usually you will find executable files there with the extensions C<.exe>, C<.bat> and (less likely) C<.com>. C uses this hardcoded list if it's running under Win32 but does not find a C variable. As of 2015 none of these platforms are tested frequently (or perhaps ever), but the current maintainer is determined not to intentionally remove support for older operating systems. =head3 VMS Same case as Windows 9x: uses C<.exe> and C<.com> (in that order). As of 2015 the current maintainer does not test on VMS, and is in fact not certain it has ever been tested on VMS. If this platform is important to you and you can help me verify and or support it on that platform please contact me. =head1 FUNCTIONS =head2 which my $path = which $short_exe_name; my @paths = which $short_exe_name; Exported by default. C<$short_exe_name> is the name used in the shell to call the program (for example, C). If it finds an executable with the name you specified, C will return the absolute path leading to this executable (for example, F or F). If it does I find the executable, it returns C. If C is called in list context, it will return I the matches. =head2 where my @paths = where $short_exe_name; Not exported by default. Same as L in array context. Same as the C utility, will return an array containing all the path names matching C<$short_exe_name>. =head1 CAVEATS This module has no non-core requirements for Perl 5.6.2 and better. This module is fully supported back to Perl 5.8.1. It may work on 5.8.0. It should work on Perl 5.6.x and I may even test on 5.6.2. I will accept patches to maintain compatibility for such older Perls, but you may need to fix it on 5.6.x / 5.8.0 and send me a patch. Not tested on VMS although there is platform specific code for those. Anyone who haves a second would be very kind to send me a report of how it went. =head1 SUPPORT Bugs should be reported via the GitHub issue tracker L For other issues, contact the maintainer. =head1 SEE ALSO =over 4 =item L, L Command line interface to this module. =item L Comes with a C function with slightly different semantics that the traditional UNIX where. It will find executables in the current directory, even though the current directory is not searched for by default on Unix. =item L This module purports to "check that a command is available", but does not provide any documentation on how you might use it. =back =head1 AUTHORS =over 4 =item * Per Einar Ellefsen =item * Adam Kennedy =item * Graham Ollis =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002 by Per Einar Ellefsen . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut HomeDir/MacOS9.pm000064400000005675152345537030007510 0ustar00package File::HomeDir::MacOS9; # Half-assed implementation for the legacy Mac OS9 operating system. # Provided mainly to provide legacy compatibility. May be removed at # a later date. use 5.00503; use strict; use Carp (); use File::HomeDir::Driver (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Driver'; } # Load early if in a forking environment and we have # prefork, or at run-time if not. SCOPE: { local $@; eval "use prefork 'Mac::Files'"; } ##################################################################### # Current User Methods sub my_home { my $class = shift; # Try for $ENV{HOME} if we have it if ( defined $ENV{HOME} ) { return $ENV{HOME}; } ### DESPERATION SETS IN # We could use the desktop SCOPE: { local $@; eval { my $home = $class->my_desktop; return $home if $home and -d $home; }; } # Desperation on any platform SCOPE: { # On some platforms getpwuid dies if called at all local $SIG{'__DIE__'} = ''; my $home = (getpwuid($<))[7]; return $home if $home and -d $home; } Carp::croak("Could not locate current user's home directory"); } sub my_desktop { my $class = shift; # Find the desktop via Mac::Files local $SIG{'__DIE__'} = ''; require Mac::Files; my $home = Mac::Files::FindFolder( Mac::Files::kOnSystemDisk(), Mac::Files::kDesktopFolderType(), ); return $home if $home and -d $home; Carp::croak("Could not locate current user's desktop"); } ##################################################################### # General User Methods sub users_home { my ($class, $name) = @_; SCOPE: { # On some platforms getpwnam dies if called at all local $SIG{'__DIE__'} = ''; my $home = (getpwnam($name))[7]; return $home if defined $home and -d $home; } Carp::croak("Failed to find home directory for user '$name'"); } 1; =pod =head1 NAME File::HomeDir::MacOS9 - Find your home and other directories on legacy Macs =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user $home = File::HomeDir->my_home; $desktop = File::HomeDir->my_desktop; =head1 DESCRIPTION This module provides implementations for determining common user directories on legacy Mac hosts. In normal usage this module will always be used via L. This module is no longer actively maintained, and is included only for extreme back-compatibility. Only the C and C methods are supported. =head1 SUPPORT See the support section the main L module. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Sean M. Burke Esburke@cpan.orgE =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. Some parts copyright 2000 Sean M. Burke. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut HomeDir/Darwin/Cocoa.pm000064400000007002152345537030010707 0ustar00package File::HomeDir::Darwin::Cocoa; use 5.00503; use strict; use Cwd (); use Carp (); use File::HomeDir::Darwin (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Darwin'; # Load early if in a forking environment and we have # prefork, or at run-time if not. local $@; eval "use prefork 'Mac::SystemDirectory'"; } ##################################################################### # Current User Methods sub my_home { my $class = shift; # A lot of unix people and unix-derived tools rely on # the ability to overload HOME. We will support it too # so that they can replace raw HOME calls with File::HomeDir. if ( exists $ENV{HOME} and defined $ENV{HOME} ) { return $ENV{HOME}; } require Mac::SystemDirectory; return Mac::SystemDirectory::HomeDirectory(); } # from 10.4 sub my_desktop { my $class = shift; require Mac::SystemDirectory; eval { $class->_find_folder(Mac::SystemDirectory::NSDesktopDirectory()) } || $class->SUPER::my_desktop; } # from 10.2 sub my_documents { my $class = shift; require Mac::SystemDirectory; eval { $class->_find_folder(Mac::SystemDirectory::NSDocumentDirectory()) } || $class->SUPER::my_documents; } # from 10.4 sub my_data { my $class = shift; require Mac::SystemDirectory; eval { $class->_find_folder(Mac::SystemDirectory::NSApplicationSupportDirectory()) } || $class->SUPER::my_data; } # from 10.6 sub my_music { my $class = shift; require Mac::SystemDirectory; eval { $class->_find_folder(Mac::SystemDirectory::NSMusicDirectory()) } || $class->SUPER::my_music; } # from 10.6 sub my_pictures { my $class = shift; require Mac::SystemDirectory; eval { $class->_find_folder(Mac::SystemDirectory::NSPicturesDirectory()) } || $class->SUPER::my_pictures; } # from 10.6 sub my_videos { my $class = shift; require Mac::SystemDirectory; eval { $class->_find_folder(Mac::SystemDirectory::NSMoviesDirectory()) } || $class->SUPER::my_videos; } sub _find_folder { my $class = shift; my $name = shift; require Mac::SystemDirectory; my $folder = Mac::SystemDirectory::FindDirectory($name); return undef unless defined $folder; unless ( -d $folder ) { # Make sure that symlinks resolve to directories. return undef unless -l $folder; my $dir = readlink $folder or return; return undef unless -d $dir; } return Cwd::abs_path($folder); } 1; =pod =head1 NAME File::HomeDir::Darwin::Cocoa - Find your home and other directories on Darwin (OS X) =head1 DESCRIPTION This module provides Darwin-specific implementations for determining common user directories using Cocoa API through L. In normal usage this module will always be used via L. Theoretically, this should return the same paths as both of the other Darwin drivers. Because this module requires L, if the module is not installed, L will fall back to L. =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user $home = File::HomeDir->my_home; # /Users/mylogin $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents $music = File::HomeDir->my_music; # /Users/mylogin/Music $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support =cut HomeDir/Darwin/Carbon.pm000064400000010770152345537030011075 0ustar00package File::HomeDir::Darwin::Carbon; # Basic implementation for the Dawin family of operating systems. # This includes (most prominently) Mac OS X. use 5.00503; use strict; use Cwd (); use Carp (); use File::HomeDir::Darwin (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; # This is only a child class of the pure Perl darwin # class so that we can do homedir detection of all three # drivers at one via ->isa. @ISA = 'File::HomeDir::Darwin'; # Load early if in a forking environment and we have # prefork, or at run-time if not. local $@; eval "use prefork 'Mac::Files'"; } ##################################################################### # Current User Methods sub my_home { my $class = shift; # A lot of unix people and unix-derived tools rely on # the ability to overload HOME. We will support it too # so that they can replace raw HOME calls with File::HomeDir. if ( exists $ENV{HOME} and defined $ENV{HOME} ) { return $ENV{HOME}; } require Mac::Files; $class->_find_folder( Mac::Files::kCurrentUserFolderType(), ); } sub my_desktop { my $class = shift; require Mac::Files; $class->_find_folder( Mac::Files::kDesktopFolderType(), ); } sub my_documents { my $class = shift; require Mac::Files; $class->_find_folder( Mac::Files::kDocumentsFolderType(), ); } sub my_data { my $class = shift; require Mac::Files; $class->_find_folder( Mac::Files::kApplicationSupportFolderType(), ); } sub my_music { my $class = shift; require Mac::Files; $class->_find_folder( Mac::Files::kMusicDocumentsFolderType(), ); } sub my_pictures { my $class = shift; require Mac::Files; $class->_find_folder( Mac::Files::kPictureDocumentsFolderType(), ); } sub my_videos { my $class = shift; require Mac::Files; $class->_find_folder( Mac::Files::kMovieDocumentsFolderType(), ); } sub _find_folder { my $class = shift; my $name = shift; require Mac::Files; my $folder = Mac::Files::FindFolder( Mac::Files::kUserDomain(), $name, ); return undef unless defined $folder; unless ( -d $folder ) { # Make sure that symlinks resolve to directories. return undef unless -l $folder; my $dir = readlink $folder or return; return undef unless -d $dir; } return Cwd::abs_path($folder); } ##################################################################### # Arbitrary User Methods sub users_home { my $class = shift; my $home = $class->SUPER::users_home(@_); return defined $home ? Cwd::abs_path($home) : undef; } # in theory this can be done, but for now, let's cheat, since the # rest is Hard sub users_desktop { my ($class, $name) = @_; return undef if $name eq 'root'; $class->_to_user( $class->my_desktop, $name ); } sub users_documents { my ($class, $name) = @_; return undef if $name eq 'root'; $class->_to_user( $class->my_documents, $name ); } sub users_data { my ($class, $name) = @_; $class->_to_user( $class->my_data, $name ) || $class->users_home($name); } # cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since # there's really no other good way to do it at this time, that i know of -- pudge sub _to_user { my ($class, $path, $name) = @_; my $my_home = $class->my_home; my $users_home = $class->users_home($name); defined $users_home or return undef; $path =~ s/^\Q$my_home/$users_home/; return $path; } 1; =pod =head1 NAME File::HomeDir::Darwin - Find your home and other directories on Darwin (OS X) =head1 DESCRIPTION This module provides Darwin-specific implementations for determining common user directories. In normal usage this module will always be used via L. Note -- since this module requires Mac::Carbon and Mac::Carbon does not work with 64-bit perls, on such systems, File::HomeDir will try L and then fall back to the (pure Perl) L. =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user $home = File::HomeDir->my_home; # /Users/mylogin $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents $music = File::HomeDir->my_music; # /Users/mylogin/Music $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support =head1 TODO =over 4 =item * Test with Mac OS (versions 7, 8, 9) =item * Some better way for users_* ? =back HomeDir/Driver.pm000064400000002143152345537030007673 0ustar00package File::HomeDir::Driver; # Abstract base class that provides no functionality, # but confirms the class is a File::HomeDir driver class. use 5.00503; use strict; use Carp (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.002'; } sub my_home { Carp::croak("$_[0] does not implement compulsory method $_[1]"); } 1; =pod =head1 NAME File::HomeDir::Driver - Base class for all File::HomeDir drivers =head1 DESCRIPTION This module is the base class for all L drivers, and must be inherited from to identify a class as a driver. It is primarily provided as a convenience for this specific identification purpose, as L supports the specification of custom drivers and an C<-Eisa> check is used during the loading of the driver. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2009 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut HomeDir/FreeDesktop.pm000064400000007064152345537030010662 0ustar00package File::HomeDir::FreeDesktop; # Specific functionality for unixes running free desktops # compatible with (but not using) File-BaseDir-0.03 # See POD at the end of the file for more documentation. use 5.00503; use strict; use Carp (); use File::Spec (); use File::Which (); use File::HomeDir::Unix (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Unix'; } # xdg uses $ENV{XDG_CONFIG_HOME}/user-dirs.dirs to know where are the # various "my xxx" directories. That is a shell file. The official API # is the xdg-user-dir executable. It has no provision for assessing # the directories of a user that is different than the one we are # running under; the standard substitute user mechanisms are needed to # overcome this. my $xdgprog = File::Which::which('xdg-user-dir'); sub _my { # No quoting because input is hard-coded and only comes from this module my $thingy = qx($xdgprog $_[1]); chomp $thingy; return $thingy; } # Simple stuff sub my_desktop { shift->_my('DESKTOP') } sub my_documents { shift->_my('DOCUMENTS') } sub my_music { shift->_my('MUSIC') } sub my_pictures { shift->_my('PICTURES') } sub my_videos { shift->_my('VIDEOS') } sub my_data { $ENV{XDG_DATA_HOME} or File::Spec->catdir( shift->my_home, qw{ .local share } ); } sub my_config { $ENV{XDG_CONFIG_HOME} or File::Spec->catdir( shift->my_home, qw{ .config } ); } # Custom locations (currently undocumented) sub my_download { shift->_my('DOWNLOAD') } sub my_publicshare { shift->_my('PUBLICSHARE') } sub my_templates { shift->_my('TEMPLATES') } sub my_cache { $ENV{XDG_CACHE_HOME} || File::Spec->catdir(shift->my_home, qw{ .cache }); } ##################################################################### # General User Methods sub users_desktop { Carp::croak('The users_desktop method is not available on an XDG based system.'); } sub users_documents { Carp::croak('The users_documents method is not available on an XDG based system.'); } sub users_music { Carp::croak('The users_music method is not available on an XDG based system.'); } sub users_pictures { Carp::croak('The users_pictures method is not available on an XDG based system.'); } sub users_videos { Carp::croak('The users_videos method is not available on an XDG based system.'); } sub users_data { Carp::croak('The users_data method is not available on an XDG based system.'); } 1; =pod =head1 NAME File::HomeDir::FreeDesktop - Find your home and other directories on FreeDesktop.org Unix =head1 DESCRIPTION This module provides implementations for determining common user directories. In normal usage this module will always be used via L. =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user $home = File::HomeDir->my_home; # /home/mylogin $desktop = File::HomeDir->my_desktop; $docs = File::HomeDir->my_documents; $music = File::HomeDir->my_music; $pics = File::HomeDir->my_pictures; $videos = File::HomeDir->my_videos; $data = File::HomeDir->my_data; =head1 AUTHORS Jerome Quelin Ejquellin@cpan.org Adam Kennedy Eadamk@cpan.orgE =head1 SEE ALSO L, L (legacy) =head1 COPYRIGHT Copyright 2009 - 2011 Jerome Quelin. Some parts copyright 2010 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut HomeDir/Windows.pm000064400000014246152345537030010101 0ustar00package File::HomeDir::Windows; # See POD at the end of the file for documentation use 5.00503; use strict; use Carp (); use File::Spec (); use File::HomeDir::Driver (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Driver'; } sub CREATE () { 1 } ##################################################################### # Current User Methods sub my_home { my $class = shift; # A lot of unix people and unix-derived tools rely on # the ability to overload HOME. We will support it too # so that they can replace raw HOME calls with File::HomeDir. if ( exists $ENV{HOME} and $ENV{HOME} ) { return $ENV{HOME}; } # Do we have a user profile? if ( exists $ENV{USERPROFILE} and $ENV{USERPROFILE} ) { return $ENV{USERPROFILE}; } # Some Windows use something like $ENV{HOME} if ( exists $ENV{HOMEDRIVE} and exists $ENV{HOMEPATH} and $ENV{HOMEDRIVE} and $ENV{HOMEPATH} ) { return File::Spec->catpath( $ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '', ); } return undef; } sub my_desktop { my $class = shift; # The most correct way to find the desktop SCOPE: { require Win32; my $dir = Win32::GetFolderPath(Win32::CSIDL_DESKTOP(), CREATE); return $dir if $dir and $class->_d($dir); } # MSWindows sets WINDIR, MS WinNT sets USERPROFILE. foreach my $e ( 'USERPROFILE', 'WINDIR' ) { next unless $ENV{$e}; my $desktop = File::Spec->catdir($ENV{$e}, 'Desktop'); return $desktop if $desktop and $class->_d($desktop); } # As a last resort, try some hard-wired values foreach my $fixed ( # The reason there are both types of slash here is because # this set of paths has been kept from thethe original version # of File::HomeDir::Win32 (before it was rewritten). # I can only assume this is Cygwin-related stuff. "C:\\windows\\desktop", "C:\\win95\\desktop", "C:/win95/desktop", "C:/windows/desktop", ) { return $fixed if $class->_d($fixed); } return undef; } sub my_documents { my $class = shift; # The most correct way to find my documents SCOPE: { require Win32; my $dir = Win32::GetFolderPath(Win32::CSIDL_PERSONAL(), CREATE); return $dir if $dir and $class->_d($dir); } return undef; } sub my_data { my $class = shift; # The most correct way to find my documents SCOPE: { require Win32; my $dir = Win32::GetFolderPath(Win32::CSIDL_LOCAL_APPDATA(), CREATE); return $dir if $dir and $class->_d($dir); } return undef; } sub my_music { my $class = shift; # The most correct way to find my music SCOPE: { require Win32; my $dir = Win32::GetFolderPath(Win32::CSIDL_MYMUSIC(), CREATE); return $dir if $dir and $class->_d($dir); } return undef; } sub my_pictures { my $class = shift; # The most correct way to find my pictures SCOPE: { require Win32; my $dir = Win32::GetFolderPath(Win32::CSIDL_MYPICTURES(), CREATE); return $dir if $dir and $class->_d($dir); } return undef; } sub my_videos { my $class = shift; # The most correct way to find my videos SCOPE: { require Win32; my $dir = Win32::GetFolderPath(Win32::CSIDL_MYVIDEO(), CREATE); return $dir if $dir and $class->_d($dir); } return undef; } # Special case version of -d sub _d { my $self = shift; my $path = shift; # Window can legally return a UNC path from GetFolderPath. # Not only is the meaning of -d complicated in this situation, # but even on a local network calling -d "\\\\cifs\\path" can # take several seconds. UNC can also do even weirder things, # like launching processes and such. # To avoid various crazy bugs caused by this, we do NOT attempt # to validate UNC paths at all so that the code that is calling # us has an opportunity to take special actions without our # blundering getting in the way. if ( $path =~ /\\\\/ ) { return 1; } # Otherwise do a stat as normal return -d $path; } 1; =pod =head1 NAME File::HomeDir::Windows - Find your home and other directories on Windows =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user (eg. using Windows XP Professional) $home = File::HomeDir->my_home; # C:\Documents and Settings\mylogin $desktop = File::HomeDir->my_desktop; # C:\Documents and Settings\mylogin\Desktop $docs = File::HomeDir->my_documents; # C:\Documents and Settings\mylogin\My Documents $music = File::HomeDir->my_music; # C:\Documents and Settings\mylogin\My Documents\My Music $pics = File::HomeDir->my_pictures; # C:\Documents and Settings\mylogin\My Documents\My Pictures $videos = File::HomeDir->my_videos; # C:\Documents and Settings\mylogin\My Documents\My Video $data = File::HomeDir->my_data; # C:\Documents and Settings\mylogin\Local Settings\Application Data =head1 DESCRIPTION This module provides Windows-specific implementations for determining common user directories. In normal usage this module will always be used via L. Internally this module will use L::GetFolderPath to fetch the location of your directories. As a result of this, in certain unusual situations (usually found inside large organisations) the methods may return UNC paths such as C<\\cifs.local\home$>. If your application runs on Windows and you want to have it work comprehensively everywhere, you may need to implement your own handling for these paths as they can cause strange behaviour. For example, stat calls to UNC paths may work but block for several seconds, but opendir() may not be able to read any files (creating the appearance of an existing but empty directory). To avoid complicating the problem any further, in the rare situation that a UNC path is returned by C the usual -d validation checks will B be done. =head1 SUPPORT See the support section the main L module. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Sean M. Burke Esburke@cpan.orgE =head1 SEE ALSO L, L (legacy) =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. Some parts copyright 2000 Sean M. Burke. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut HomeDir/Test.pm000064400000005704152345537030007365 0ustar00package File::HomeDir::Test; use 5.00503; use strict; use Carp (); use File::Spec (); use File::Temp (); use File::HomeDir::Driver (); use vars qw{$VERSION @ISA %DIR $ENABLED}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Driver'; %DIR = (); $ENABLED = 0; } # Special magic use in test scripts sub import { my $class = shift; die "Attempted to initialise File::HomeDir::Test trice" if %DIR; # Fill the test directories my $BASE = File::Temp::tempdir( CLEANUP => 1 ); %DIR = map { $_ => File::Spec->catdir( $BASE, $_ ) } qw{ my_home my_desktop my_documents my_data my_music my_pictures my_videos }; # Hijack HOME to the home directory $ENV{HOME} = $DIR{my_home}; # Make File::HomeDir load us instead of the native driver $File::HomeDir::IMPLEMENTED_BY = # Prevent a warning $File::HomeDir::IMPLEMENTED_BY = 'File::HomeDir::Test'; # Ready to go $ENABLED = 1; } ##################################################################### # Current User Methods sub my_home { mkdir($DIR{my_home}, 0755) unless -d $DIR{my_home}; return $DIR{my_home}; } sub my_desktop { mkdir($DIR{my_desktop}, 0755) unless -d $DIR{my_desktop}; return $DIR{my_desktop}; } sub my_documents { mkdir($DIR{my_documents}, 0755) unless -f $DIR{my_documents}; return $DIR{my_documents}; } sub my_data { mkdir($DIR{my_data}, 0755) unless -d $DIR{my_data}; return $DIR{my_data}; } sub my_music { mkdir($DIR{my_music}, 0755) unless -d $DIR{my_music}; return $DIR{my_music}; } sub my_pictures { mkdir($DIR{my_pictures}, 0755) unless -d $DIR{my_pictures}; return $DIR{my_pictures}; } sub my_videos { mkdir($DIR{my_videos}, 0755) unless -d $DIR{my_videos}; return $DIR{my_videos}; } sub users_home { return undef; } 1; __END__ =pod =head1 NAME File::HomeDir::Test - Prevent the accidental creation of user-owned files during testing =head1 SYNOPSIS use Test::More test => 1; use File::HomeDir::Test; use File::HomeDir; =head1 DESCRIPTION B is a L driver intended for use in the test scripts of modules or applications that write files into user-owned directories. It is designed to prevent the pollution of user directories with files that are not part of the application install itself, but were created during testing. These files can leak state information from the tests into the run-time usage of an application, and on Unix systems also prevents tests (which may be executed as root via sudo) from writing files which cannot later be modified or removed by the regular user. =head1 SUPPORT See the support section of the main L documentation. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut HomeDir/Darwin.pm000064400000006276152345537030007677 0ustar00package File::HomeDir::Darwin; use 5.00503; use strict; use Cwd (); use Carp (); use File::HomeDir::Unix (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Unix'; } ##################################################################### # Current User Methods sub my_home { my $class = shift; if ( exists $ENV{HOME} and defined $ENV{HOME} ) { return $ENV{HOME}; } my $home = (getpwuid($<))[7]; return $home if $home && -d $home; return undef; } sub _my_home { my($class, $path) = @_; my $home = $class->my_home; return undef unless defined $home; my $folder = "$home/$path"; unless ( -d $folder ) { # Make sure that symlinks resolve to directories. return undef unless -l $folder; my $dir = readlink $folder or return; return undef unless -d $dir; } return Cwd::abs_path($folder); } sub my_desktop { my $class = shift; $class->_my_home('Desktop'); } sub my_documents { my $class = shift; $class->_my_home('Documents'); } sub my_data { my $class = shift; $class->_my_home('Library/Application Support'); } sub my_music { my $class = shift; $class->_my_home('Music'); } sub my_pictures { my $class = shift; $class->_my_home('Pictures'); } sub my_videos { my $class = shift; $class->_my_home('Movies'); } ##################################################################### # Arbitrary User Methods sub users_home { my $class = shift; my $home = $class->SUPER::users_home(@_); return defined $home ? Cwd::abs_path($home) : undef; } sub users_desktop { my ($class, $name) = @_; return undef if $name eq 'root'; $class->_to_user( $class->my_desktop, $name ); } sub users_documents { my ($class, $name) = @_; return undef if $name eq 'root'; $class->_to_user( $class->my_documents, $name ); } sub users_data { my ($class, $name) = @_; $class->_to_user( $class->my_data, $name ) || $class->users_home($name); } # cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since # there's really no other good way to do it at this time, that i know of -- pudge sub _to_user { my ($class, $path, $name) = @_; my $my_home = $class->my_home; my $users_home = $class->users_home($name); defined $users_home or return undef; $path =~ s/^\Q$my_home/$users_home/; return $path; } 1; =pod =head1 NAME File::HomeDir::Darwin - Find your home and other directories on Darwin (OS X) =head1 DESCRIPTION This module provides Mac OS X specific file path for determining common user directories in pure perl, by just using C<$ENV{HOME}> without Carbon nor Cocoa API calls. In normal usage this module will always be used via L. =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user $home = File::HomeDir->my_home; # /Users/mylogin $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents $music = File::HomeDir->my_music; # /Users/mylogin/Music $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support =cut HomeDir/Unix.pm000064400000006526152345537030007374 0ustar00package File::HomeDir::Unix; # See POD at the end of the file for documentation use 5.00503; use strict; use Carp (); use File::HomeDir::Driver (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.002'; @ISA = 'File::HomeDir::Driver'; } ##################################################################### # Current User Methods sub my_home { my $class = shift; my $home = $class->_my_home(@_); # On Unix in general, a non-existant home means "no home" # For example, "nobody"-like users might use /nonexistant if ( defined $home and ! -d $home ) { $home = undef; } return $home; } sub _my_home { my $class = shift; if ( exists $ENV{HOME} and defined $ENV{HOME} ) { return $ENV{HOME}; } # This is from the original code, but I'm guessing # it means "login directory" and exists on some Unixes. if ( exists $ENV{LOGDIR} and $ENV{LOGDIR} ) { return $ENV{LOGDIR}; } ### More-desperate methods # Light desperation on any (Unixish) platform SCOPE: { my $home = (getpwuid($<))[7]; return $home if $home and -d $home; } return undef; } # On unix by default, everything is under the same folder sub my_desktop { shift->my_home; } sub my_documents { shift->my_home; } sub my_data { shift->my_home; } sub my_music { shift->my_home; } sub my_pictures { shift->my_home; } sub my_videos { shift->my_home; } ##################################################################### # General User Methods sub users_home { my ($class, $name) = @_; # IF and only if we have getpwuid support, and the # name of the user is our own, shortcut to my_home. # This is needed to handle HOME environment settings. if ( $name eq getpwuid($<) ) { return $class->my_home; } SCOPE: { my $home = (getpwnam($name))[7]; return $home if $home and -d $home; } return undef; } sub users_desktop { shift->users_home(@_); } sub users_documents { shift->users_home(@_); } sub users_data { shift->users_home(@_); } sub users_music { shift->users_home(@_); } sub users_pictures { shift->users_home(@_); } sub users_videos { shift->users_home(@_); } 1; =pod =head1 NAME File::HomeDir::Unix - Find your home and other directories on legacy Unix =head1 SYNOPSIS use File::HomeDir; # Find directories for the current user $home = File::HomeDir->my_home; # /home/mylogin $desktop = File::HomeDir->my_desktop; # All of these will... $docs = File::HomeDir->my_documents; # ...default to home... $music = File::HomeDir->my_music; # ...directory $pics = File::HomeDir->my_pictures; # $videos = File::HomeDir->my_videos; # $data = File::HomeDir->my_data; # =head1 DESCRIPTION This module provides implementations for determining common user directories. In normal usage this module will always be used via L. =head1 SUPPORT See the support section the main L module. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Sean M. Burke Esburke@cpan.orgE =head1 SEE ALSO L, L (legacy) =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. Some parts copyright 2000 Sean M. Burke. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut HomeDir.pm000064400000052725152345537030006453 0ustar00package File::HomeDir; # See POD at end for documentation use 5.00503; use strict; use Carp (); use Config (); use File::Spec (); use File::Which (); # Globals use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK $IMPLEMENTED_BY}; BEGIN { $VERSION = '1.002'; # Inherit manually require Exporter; @ISA = qw{ Exporter }; @EXPORT = qw{ home }; @EXPORT_OK = qw{ home my_home my_desktop my_documents my_music my_pictures my_videos my_data my_dist_config my_dist_data users_home users_desktop users_documents users_music users_pictures users_videos users_data }; # %~ doesn't need (and won't take) exporting, as it's a magic # symbol name that's always looked for in package 'main'. } # Inlined Params::Util functions sub _CLASS ($) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef; } sub _DRIVER ($$) { (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; } # Platform detection if ( $IMPLEMENTED_BY ) { # Allow for custom HomeDir classes # Leave it as the existing value } elsif ( $^O eq 'MSWin32' ) { # All versions of Windows $IMPLEMENTED_BY = 'File::HomeDir::Windows'; } elsif ( $^O eq 'darwin') { # 1st: try Mac::SystemDirectory by chansen if ( eval { require Mac::SystemDirectory; 1 } ) { $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Cocoa'; } elsif ( eval { require Mac::Files; 1 } ) { # 2nd try Mac::Files: Carbon - unmaintained since 2006 except some 64bit fixes $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Carbon'; } else { # 3rd: fallback: pure perl $IMPLEMENTED_BY = 'File::HomeDir::Darwin'; } } elsif ( $^O eq 'MacOS' ) { # Legacy Mac OS $IMPLEMENTED_BY = 'File::HomeDir::MacOS9'; } elsif ( File::Which::which('xdg-user-dir') ) { # freedesktop unixes $IMPLEMENTED_BY = 'File::HomeDir::FreeDesktop'; } else { # Default to Unix semantics $IMPLEMENTED_BY = 'File::HomeDir::Unix'; } unless ( _DRIVER($IMPLEMENTED_BY, 'File::HomeDir::Driver') ) { Carp::croak("Missing or invalid File::HomeDir driver $IMPLEMENTED_BY"); } ##################################################################### # Current User Methods sub my_home { $IMPLEMENTED_BY->my_home; } sub my_desktop { $IMPLEMENTED_BY->can('my_desktop') ? $IMPLEMENTED_BY->my_desktop : Carp::croak("The my_desktop method is not implemented on this platform"); } sub my_documents { $IMPLEMENTED_BY->can('my_documents') ? $IMPLEMENTED_BY->my_documents : Carp::croak("The my_documents method is not implemented on this platform"); } sub my_music { $IMPLEMENTED_BY->can('my_music') ? $IMPLEMENTED_BY->my_music : Carp::croak("The my_music method is not implemented on this platform"); } sub my_pictures { $IMPLEMENTED_BY->can('my_pictures') ? $IMPLEMENTED_BY->my_pictures : Carp::croak("The my_pictures method is not implemented on this platform"); } sub my_videos { $IMPLEMENTED_BY->can('my_videos') ? $IMPLEMENTED_BY->my_videos : Carp::croak("The my_videos method is not implemented on this platform"); } sub my_data { $IMPLEMENTED_BY->can('my_data') ? $IMPLEMENTED_BY->my_data : Carp::croak("The my_data method is not implemented on this platform"); } sub my_dist_data { my $params = ref $_[-1] eq 'HASH' ? pop : {}; my $dist = pop or Carp::croak("The my_dist_data method requires an argument"); my $data = my_data(); # If datadir is not defined, there's nothing we can do: bail out # and return nothing... return undef unless defined $data; # On traditional unixes, hide the top-level directory my $var = $data eq home() ? File::Spec->catdir( $data, '.perl', 'dist', $dist ) : File::Spec->catdir( $data, 'Perl', 'dist', $dist ); # directory exists: return it return $var if -d $var; # directory doesn't exist: check if we need to create it... return undef unless $params->{create}; # user requested directory creation require File::Path; File::Path::mkpath( $var ); return $var; } sub my_dist_config { my $params = ref $_[-1] eq 'HASH' ? pop : {}; my $dist = pop or Carp::croak("The my_dist_config method requires an argument"); # not all platforms support a specific my_config() method my $config = $IMPLEMENTED_BY->can('my_config') ? $IMPLEMENTED_BY->my_config : $IMPLEMENTED_BY->my_documents; # If neither configdir nor my_documents is defined, there's # nothing we can do: bail out and return nothing... return undef unless defined $config; # On traditional unixes, hide the top-level dir my $etc = $config eq home() ? File::Spec->catdir( $config, '.perl', $dist ) : File::Spec->catdir( $config, 'Perl', $dist ); # directory exists: return it return $etc if -d $etc; # directory doesn't exist: check if we need to create it... return undef unless $params->{create}; # user requested directory creation require File::Path; File::Path::mkpath( $etc ); return $etc; } ##################################################################### # General User Methods sub users_home { $IMPLEMENTED_BY->can('users_home') ? $IMPLEMENTED_BY->users_home( $_[-1] ) : Carp::croak("The users_home method is not implemented on this platform"); } sub users_desktop { $IMPLEMENTED_BY->can('users_desktop') ? $IMPLEMENTED_BY->users_desktop( $_[-1] ) : Carp::croak("The users_desktop method is not implemented on this platform"); } sub users_documents { $IMPLEMENTED_BY->can('users_documents') ? $IMPLEMENTED_BY->users_documents( $_[-1] ) : Carp::croak("The users_documents method is not implemented on this platform"); } sub users_music { $IMPLEMENTED_BY->can('users_music') ? $IMPLEMENTED_BY->users_music( $_[-1] ) : Carp::croak("The users_music method is not implemented on this platform"); } sub users_pictures { $IMPLEMENTED_BY->can('users_pictures') ? $IMPLEMENTED_BY->users_pictures( $_[-1] ) : Carp::croak("The users_pictures method is not implemented on this platform"); } sub users_videos { $IMPLEMENTED_BY->can('users_videos') ? $IMPLEMENTED_BY->users_videos( $_[-1] ) : Carp::croak("The users_videos method is not implemented on this platform"); } sub users_data { $IMPLEMENTED_BY->can('users_data') ? $IMPLEMENTED_BY->users_data( $_[-1] ) : Carp::croak("The users_data method is not implemented on this platform"); } ##################################################################### # Legacy Methods # Find the home directory of an arbitrary user sub home (;$) { # Allow to be called as a method if ( $_[0] and $_[0] eq 'File::HomeDir' ) { shift(); } # No params means my home return my_home() unless @_; # Check the param my $name = shift; if ( ! defined $name ) { Carp::croak("Can't use undef as a username"); } if ( ! length $name ) { Carp::croak("Can't use empty-string (\"\") as a username"); } # A dot also means my home ### Is this meant to mean File::Spec->curdir? if ( $name eq '.' ) { return my_home(); } # Now hand off to the implementor $IMPLEMENTED_BY->users_home($name); } ##################################################################### # Tie-Based Interface # Okay, things below this point get scary CLASS: { # Make the class for the %~ tied hash: package File::HomeDir::TIE; # Make the singleton object. # (We don't use the hash for anything, though) ### THEN WHY MAKE IT??? my $SINGLETON = bless {}; sub TIEHASH { $SINGLETON } sub FETCH { # Catch a bad username unless ( defined $_[1] ) { Carp::croak("Can't use undef as a username"); } # Get our homedir unless ( length $_[1] ) { return File::HomeDir::my_home(); } # Get a named user's homedir Carp::carp("The tied %~ hash has been deprecated"); return File::HomeDir::home($_[1]); } sub STORE { _bad('STORE') } sub EXISTS { _bad('EXISTS') } sub DELETE { _bad('DELETE') } sub CLEAR { _bad('CLEAR') } sub FIRSTKEY { _bad('FIRSTKEY') } sub NEXTKEY { _bad('NEXTKEY') } sub _bad ($) { Carp::croak("You can't $_[0] with the %~ hash") } } # Do the actual tie of the global %~ variable tie %~, 'File::HomeDir::TIE'; 1; __END__ =pod =encoding UTF-8 =head1 NAME File::HomeDir - Find your home and other directories on any platform =head1 SYNOPSIS use File::HomeDir; # Modern Interface (Current User) $home = File::HomeDir->my_home; $desktop = File::HomeDir->my_desktop; $docs = File::HomeDir->my_documents; $music = File::HomeDir->my_music; $pics = File::HomeDir->my_pictures; $videos = File::HomeDir->my_videos; $data = File::HomeDir->my_data; $dist = File::HomeDir->my_dist_data('File-HomeDir'); $dist = File::HomeDir->my_dist_config('File-HomeDir'); # Modern Interface (Other Users) $home = File::HomeDir->users_home('foo'); $desktop = File::HomeDir->users_desktop('foo'); $docs = File::HomeDir->users_documents('foo'); $music = File::HomeDir->users_music('foo'); $pics = File::HomeDir->users_pictures('foo'); $video = File::HomeDir->users_videos('foo'); $data = File::HomeDir->users_data('foo'); =head1 DESCRIPTION B is a module for locating the directories that are "owned" by a user (typicaly your user) and to solve the various issues that arise trying to find them consistently across a wide variety of platforms. The end result is a single API that can find your resources on any platform, making it relatively trivial to create Perl software that works elegantly and correctly no matter where you run it. This module provides two main interfaces. The first is a modern L-style interface with a consistent OO API and different implementation modules to support various platforms. You are B recommended to use this interface. The second interface is for legacy support of the original 0.07 interface that exported a C function by default and tied the C<%~> variable. It is generally not recommended that you use this interface, but due to back-compatibility reasons they will remain supported until at least 2010. The C<%~> interface has been deprecated. Documentation was removed in 2009, Unit test were removed in 2011, usage will issue warnings from 2012, and the interface will be removed entirely in 2015 (in line with the general Perl toolchain convention of a 10 year support period for legacy APIs that are potentially or actually in common use). =head2 Platform Neutrality In the Unix world, many different types of data can be mixed together in your home directory (although on some Unix platforms this is no longer the case, particularly for "desktop"-oriented platforms). On some non-Unix platforms, separate directories are allocated for different types of data and have been for a long time. When writing applications on top of B, you should thus always try to use the most specific method you can. User documents should be saved in C, data that supports an application but isn't normally editing by the user directory should go into C. On platforms that do not make any distinction, all these different methods will harmlessly degrade to the main home directory, but on platforms that care B will always try to Do The Right Thing(tm). =head1 METHODS Two types of methods are provided. The C series of methods for finding resources for the current user, and the C (read as "user's method") series for finding resources for arbitrary users. This split is necessary, as on most platforms it is B easier to find information about the current user compared to other users, and indeed on a number you cannot find out information such as C at all, due to security restrictions. All methods will double check (using a C<-d> test) that a directory actually exists before returning it, so you may trust in the values that are returned (subject to the usual caveats of race conditions of directories being deleted at the moment between a directory being returned and you using it). However, because in some cases platforms may not support the concept of home directories at all, any method may return C (both in scalar and list context) to indicate that there is no matching directory on the system. For example, most untrusted 'nobody'-type users do not have a home directory. So any modules that are used in a CGI application that at some level of recursion use your code, will result in calls to File::HomeDir returning undef, even for a basic home() call. =head2 my_home The C method takes no arguments and returns the main home/profile directory for the current user. If the distinction is important to you, the term "current" refers to the real user, and not the effective user. This is also the case for all of the other "my" methods. Returns the directory path as a string, C if the current user does not have a home directory, or dies on error. =head2 my_desktop The C method takes no arguments and returns the "desktop" directory for the current user. Due to the diversity and complexity of implementions required to deal with implementing the required functionality fully and completely, the C method may or may not be implemented on each platform. That said, I am extremely interested in code to implement C on Unix, as long as it is capable of dealing (as the Windows implementation does) with internationalisation. It should also avoid false positive results by making sure it only returns the appropriate directories for the appropriate platforms. Returns the directory path as a string, C if the current user does not have a desktop directory, or dies on error. =head2 my_documents The C method takes no arguments and returns the directory (for the current user) where the user's documents are stored. Returns the directory path as a string, C if the current user does not have a documents directory, or dies on error. =head2 my_music The C method takes no arguments and returns the directory where the current user's music is stored. No bias is made to any particular music type or music program, rather the concept of a directory to hold the user's music is made at the level of the underlying operating system or (at least) desktop environment. Returns the directory path as a string, C if the current user does not have a suitable directory, or dies on error. =head2 my_pictures The C method takes no arguments and returns the directory where the current user's pictures are stored. No bias is made to any particular picture type or picture program, rather the concept of a directory to hold the user's pictures is made at the level of the underlying operating system or (at least) desktop environment. Returns the directory path as a string, C if the current user does not have a suitable directory, or dies on error. =head2 my_videos The C method takes no arguments and returns the directory where the current user's videos are stored. No bias is made to any particular video type or video program, rather the concept of a directory to hold the user's videos is made at the level of the underlying operating system or (at least) desktop environment. Returns the directory path as a string, C if the current user does not have a suitable directory, or dies on error. =head2 my_data The C method takes no arguments and returns the directory where local applications should stored their internal data for the current user. Generally an application would create a subdirectory such as C<.foo>, beneath this directory, and store its data there. By creating your directory this way, you get an accurate result on the maximum number of platforms. But see the documentation about C or C below. For example, on Unix you get C<~/.foo> and on Win32 you get C<~/Local Settings/Application Data/.foo> Returns the directory path as a string, C if the current user does not have a data directory, or dies on error. =head2 my_dist_config File::HomeDir->my_dist_config( $dist [, \%params] ); # For example... File::HomeDir->my_dist_config( 'File-HomeDir' ); File::HomeDir->my_dist_config( 'File-HomeDir', { create => 1 } ); The C method takes a distribution name as argument and returns an application-specific directory where they should store their internal configuration. The base directory will be either C if the platform supports it, or C otherwise. The subdirectory itself will be C. If the base directory is the user's homedir, C will be in C<~/.perl/Dist-Name> (and thus be hidden on all Unixes). The optional last argument is a hash reference to tweak the method behaviour. The following hash keys are recognized: =over 4 =item * create Passing a true value to this key will force the creation of the directory if it doesn't exist (remember that C's policy is to return C if the directory doesn't exist). Defaults to false, meaning no automatic creation of directory. =back =head2 my_dist_data File::HomeDir->my_dist_data( $dist [, \%params] ); # For example... File::HomeDir->my_dist_data( 'File-HomeDir' ); File::HomeDir->my_dist_data( 'File-HomeDir', { create => 1 } ); The C method takes a distribution name as argument and returns an application-specific directory where they should store their internal data. This directory will be of course a subdirectory of C. Platforms supporting data-specific directories will use C following the common "DATA/vendor/application" pattern. If the C directory is the user's homedir, C will be in C<~/.perl/dist/Dist-Name> (and thus be hidden on all Unixes). The optional last argument is a hash reference to tweak the method behaviour. The following hash keys are recognized: =over 4 =item * create Passing a true value to this key will force the creation of the directory if it doesn't exist (remember that C's policy is to return C if the directory doesn't exist). Defaults to false, meaning no automatic creation of directory. =back =head2 users_home $home = File::HomeDir->users_home('foo'); The C method takes a single param and is used to locate the parent home/profile directory for an identified user on the system. While most of the time this identifier would be some form of user name, it is permitted to vary per-platform to support user ids or UUIDs as applicable for that platform. Returns the directory path as a string, C if that user does not have a home directory, or dies on error. =head2 users_documents $docs = File::HomeDir->users_documents('foo'); Returns the directory path as a string, C if that user does not have a documents directory, or dies on error. =head2 users_data $data = File::HomeDir->users_data('foo'); Returns the directory path as a string, C if that user does not have a data directory, or dies on error. =head1 FUNCTIONS =head2 home use File::HomeDir; $home = home(); $home = home('foo'); $home = File::HomeDir::home(); $home = File::HomeDir::home('foo'); The C function is exported by default and is provided for compatibility with legacy applications. In new applications, you should use the newer method-based interface above. Returns the directory path to a named user's home/profile directory. If provided no param, returns the directory path to the current user's home/profile directory. =head1 TO DO =over 4 =item * Add more granularity to Unix, and add support to VMS and other esoteric platforms, so we can consider going core. =item * Add consistent support for users_* methods =back =head1 SUPPORT This module is stored in an Open Repository at the following address. L Write access to the repository is made available automatically to any published CPAN author, and to most other volunteers on request. If you are able to submit your bug report in the form of new (failing) unit tests, or can apply your fix directly instead of submitting a patch, you are B encouraged to do so as the author currently maintains over 100 modules and it can take some time to deal with non-Critical bug reports or patches. This will guarantee that your issue will be addressed in the next release of the module. If you cannot provide a direct test or fix, or don't have time to do so, then regular bug reports are still accepted and appreciated via the CPAN bug tracker. L For other issues, for commercial enhancement or support, or to have your write access enabled for the repository, contact the author at the email address above. =head1 ACKNOWLEDGEMENTS The biggest acknowledgement goes to Chris Nandor, who wielded his legendary Mac-fu and turned my initial fairly ordinary Darwin implementation into something that actually worked properly everywhere, and then donated a Mac OS X license to allow it to be maintained properly. =head1 AUTHORS Adam Kennedy Eadamk@cpan.orgE Sean M. Burke Esburke@cpan.orgE Chris Nandor Ecnandor@cpan.orgE Stephen Steneker Estennie@cpan.orgE =head1 SEE ALSO L, L (legacy) =head1 COPYRIGHT Copyright 2005 - 2012 Adam Kennedy. Some parts copyright 2000 Sean M. Burke. Some parts copyright 2006 Chris Nandor. Some parts copyright 2006 Stephen Steneker. Some parts copyright 2009-2011 Jérôme Quelin. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Listing.pm000064400000024606152345537030006532 0ustar00package File::Listing; sub Version { $VERSION; } $VERSION = "6.04"; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(parse_dir); use strict; use Carp (); use HTTP::Date qw(str2time); sub parse_dir ($;$$$) { my($dir, $tz, $fstype, $error) = @_; $fstype ||= 'unix'; $fstype = "File::Listing::" . lc $fstype; my @args = $_[0]; push(@args, $tz) if(@_ >= 2); push(@args, $error) if(@_ >= 4); $fstype->parse(@args); } sub line { Carp::croak("Not implemented yet"); } sub init { } # Dummy sub sub file_mode ($) { Carp::croak("Input to file_mode() must be a 10 character string.") unless length($_[0]) == 10; # This routine was originally borrowed from Graham Barr's # Net::FTP package. local $_ = shift; my $mode = 0; my($type); s/^(.)// and $type = $1; # When the set-group-ID bit (file mode bit 02000) is set, and the group # execution bit (file mode bit 00020) is unset, and it is a regular file, # some implementations of `ls' use the letter `S', others use `l' or `L'. # Convert this `S'. s/[Ll](...)$/S$1/; while (/(.)/g) { $mode <<= 1; $mode |= 1 if $1 ne "-" && $1 ne 'S' && $1 ne 'T'; } $mode |= 0004000 if /^..s....../i; $mode |= 0002000 if /^.....s.../i; $mode |= 0001000 if /^........t/i; # De facto standard definitions. From 'stat.h' on Solaris 9. $type eq "p" and $mode |= 0010000 or # fifo $type eq "c" and $mode |= 0020000 or # character special $type eq "d" and $mode |= 0040000 or # directory $type eq "b" and $mode |= 0060000 or # block special $type eq "-" and $mode |= 0100000 or # regular $type eq "l" and $mode |= 0120000 or # symbolic link $type eq "s" and $mode |= 0140000 or # socket $type eq "D" and $mode |= 0150000 or # door Carp::croak("Unknown file type: $type"); $mode; } sub parse { my($pkg, $dir, $tz, $error) = @_; # First let's try to determine what kind of dir parameter we have # received. We allow both listings, reference to arrays and # file handles to read from. if (ref($dir) eq 'ARRAY') { # Already splitted up } elsif (ref($dir) eq 'GLOB') { # A file handle } elsif (ref($dir)) { Carp::croak("Illegal argument to parse_dir()"); } elsif ($dir =~ /^\*\w+(::\w+)+$/) { # This scalar looks like a file handle, so we assume it is } else { # A normal scalar listing $dir = [ split(/\n/, $dir) ]; } $pkg->init(); my @files = (); if (ref($dir) eq 'ARRAY') { for (@$dir) { push(@files, $pkg->line($_, $tz, $error)); } } else { local($_); while (<$dir>) { chomp; push(@files, $pkg->line($_, $tz, $error)); } } wantarray ? @files : \@files; } package File::Listing::unix; use HTTP::Date qw(str2time); # A place to remember current directory from last line parsed. use vars qw($curdir @ISA); @ISA = qw(File::Listing); sub init { $curdir = ''; } sub line { shift; # package name local($_) = shift; my($tz, $error) = @_; s/\015//g; #study; my ($kind, $size, $date, $name); if (($kind, $size, $date, $name) = /^([\-FlrwxsStTdD]{10}) # Type and permission bits .* # Graps \D(\d+) # File size \s+ # Some space (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date \s+ # Some more space (.*)$ # File name /x ) { return if $name eq '.' || $name eq '..'; $name = "$curdir/$name" if length $curdir; my $type = '?'; if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) { $name = $1; $type = "l $2"; } elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file $type = 'f'; } elsif ($kind =~ /^[dD]/) { $type = 'd'; $size = undef; # Don't believe the reported size } return [$name, $type, $size, str2time($date, $tz), File::Listing::file_mode($kind)]; } elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) { my $dir = $1; return () if $dir eq '.'; $curdir = $dir; return (); } elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) { return (); } elsif (/not found/ || # OSF1, HPUX, and SunOS return # "$file not found" /No such file/ || # IRIX returns # "UX:ls: ERROR: Cannot access $file: No such file or directory" # Solaris returns # "$file: No such file or directory" /cannot find/ # Windows NT returns # "The system cannot find the path specified." ) { return () unless defined $error; &$error($_) if ref($error) eq 'CODE'; warn "Error: $_\n" if $error eq 'warn'; return (); } elsif ($_ eq '') { # AIX, and Linux return nothing return () unless defined $error; &$error("No such file or directory") if ref($error) eq 'CODE'; warn "Warning: No such file or directory\n" if $error eq 'warn'; return (); } else { # parse failed, check if the dosftp parse understands it File::Listing::dosftp->init(); return(File::Listing::dosftp->line($_,$tz,$error)); } } package File::Listing::dosftp; use HTTP::Date qw(str2time); # A place to remember current directory from last line parsed. use vars qw($curdir @ISA); @ISA = qw(File::Listing); sub init { $curdir = ''; } sub line { shift; # package name local($_) = shift; my($tz, $error) = @_; s/\015//g; my ($date, $size_or_dir, $name, $size); # 02-05-96 10:48AM 1415 src.slf # 09-10-96 09:18AM sl_util if (($date, $size_or_dir, $name) = /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info \s+ # Some space (<\w{3}>|\d+) # Dir or Size \s+ # Some more space (.+)$ # File name /x ) { return if $name eq '.' || $name eq '..'; $name = "$curdir/$name" if length $curdir; my $type = '?'; if ($size_or_dir eq '') { $type = "d"; $size = ""; # directories have no size in the pc listing } else { $type = 'f'; $size = $size_or_dir; } return [$name, $type, $size, str2time($date, $tz), undef]; } else { return () unless defined $error; &$error($_) if ref($error) eq 'CODE'; warn "Can't parse: $_\n" if $error eq 'warn'; return (); } } package File::Listing::vms; @File::Listing::vms::ISA = qw(File::Listing); package File::Listing::netware; @File::Listing::netware::ISA = qw(File::Listing); package File::Listing::apache; use vars qw(@ISA); @ISA = qw(File::Listing); sub init { } sub line { shift; # package name local($_) = shift; my($tz, $error) = @_; # ignored for now... s!]*>! !g; # clean away various table stuff if (m!.*.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) { my($filename, $filesize) = ($1, $7); my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6); if ($m =~ /^\d+$/) { ($d,$y) = ($y,$d) # iso date } else { $m = _monthabbrev_number($m); } $filesize = 0 if $filesize eq '-'; if ($filesize =~ s/k$//i) { $filesize *= 1024; } elsif ($filesize =~ s/M$//) { $filesize *= 1024*1024; } elsif ($filesize =~ s/G$//) { $filesize *= 1024*1024*1024; } $filesize = int $filesize; require Time::Local; my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900); my $filetype = ($filename =~ s|/$|| ? "d" : "f"); return [$filename, $filetype, $filesize, $filetime, undef]; } return (); } sub _guess_year { my $y = shift; if ($y >= 90) { $y = 1900+$y; } elsif ($y < 100) { $y = 2000+$y; } $y; } sub _monthabbrev_number { my $mon = shift; +{'Jan' => 1, 'Feb' => 2, 'Mar' => 3, 'Apr' => 4, 'May' => 5, 'Jun' => 6, 'Jul' => 7, 'Aug' => 8, 'Sep' => 9, 'Oct' => 10, 'Nov' => 11, 'Dec' => 12, }->{$mon}; } 1; __END__ =head1 NAME File::Listing - parse directory listing =head1 SYNOPSIS use File::Listing qw(parse_dir); $ENV{LANG} = "C"; # dates in non-English locales not supported for (parse_dir(`ls -l`)) { ($name, $type, $size, $mtime, $mode) = @$_; next if $type ne 'f'; # plain file #... } # directory listing can also be read from a file open(LISTING, "zcat ls-lR.gz|"); $dir = parse_dir(\*LISTING, '+0000'); =head1 DESCRIPTION This module exports a single function called parse_dir(), which can be used to parse directory listings. The first parameter to parse_dir() is the directory listing to parse. It can be a scalar, a reference to an array of directory lines or a glob representing a filehandle to read the directory listing from. The second parameter is the time zone to use when parsing time stamps in the listing. If this value is undefined, then the local time zone is assumed. The third parameter is the type of listing to assume. Currently supported formats are 'unix', 'apache' and 'dosftp'. The default value is 'unix'. Ideally, the listing type should be determined automatically. The fourth parameter specifies how unparseable lines should be treated. Values can be 'ignore', 'warn' or a code reference. Warn means that the perl warn() function will be called. If a code reference is passed, then this routine will be called and the return value from it will be incorporated in the listing. The default is 'ignore'. Only the first parameter is mandatory. The return value from parse_dir() is a list of directory entries. In a scalar context the return value is a reference to the list. The directory entries are represented by an array consisting of [ $filename, $filetype, $filesize, $filetime, $filemode ]. The $filetype value is one of the letters 'f', 'd', 'l' or '?'. The $filetime value is the seconds since Jan 1, 1970. The $filemode is a bitmask like the mode returned by stat(). =head1 COPYRIGHT Copyright 1996-2010, Gisle Aas Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and Net::FTP's parse_dir (Graham Barr). This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Temp.pm000064400000346456152345537030006040 0ustar00package File::Temp; # git description: v0.2305-8-g4787a5d # ABSTRACT: return name and handle of a temporary file safely our $VERSION = '0.2306'; #pod =begin __INTERNALS #pod #pod =head1 PORTABILITY #pod #pod This section is at the top in order to provide easier access to #pod porters. It is not expected to be rendered by a standard pod #pod formatting tool. Please skip straight to the SYNOPSIS section if you #pod are not trying to port this module to a new platform. #pod #pod This module is designed to be portable across operating systems and it #pod currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS #pod (Classic). When porting to a new OS there are generally three main #pod issues that have to be solved: #pod #pod =over 4 #pod #pod =item * #pod #pod Can the OS unlink an open file? If it can not then the #pod C<_can_unlink_opened_file> method should be modified. #pod #pod =item * #pod #pod Are the return values from C reliable? By default all the #pod return values from C are compared when unlinking a temporary #pod file using the filename and the handle. Operating systems other than #pod unix do not always have valid entries in all fields. If utility function #pod C fails then the C comparison should be #pod modified accordingly. #pod #pod =item * #pod #pod Security. Systems that can not support a test for the sticky bit #pod on a directory can not use the MEDIUM and HIGH security tests. #pod The C<_can_do_level> method should be modified accordingly. #pod #pod =back #pod #pod =end __INTERNALS #pod #pod =head1 SYNOPSIS #pod #pod use File::Temp qw/ tempfile tempdir /; #pod #pod $fh = tempfile(); #pod ($fh, $filename) = tempfile(); #pod #pod ($fh, $filename) = tempfile( $template, DIR => $dir); #pod ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); #pod ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); #pod #pod binmode( $fh, ":utf8" ); #pod #pod $dir = tempdir( CLEANUP => 1 ); #pod ($fh, $filename) = tempfile( DIR => $dir ); #pod #pod Object interface: #pod #pod require File::Temp; #pod use File::Temp (); #pod use File::Temp qw/ :seekable /; #pod #pod $fh = File::Temp->new(); #pod $fname = $fh->filename; #pod #pod $fh = File::Temp->new(TEMPLATE => $template); #pod $fname = $fh->filename; #pod #pod $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); #pod print $tmp "Some data\n"; #pod print "Filename is $tmp\n"; #pod $tmp->seek( 0, SEEK_END ); #pod #pod $dir = File::Temp->newdir(); # CLEANUP => 1 by default #pod #pod The following interfaces are provided for compatibility with #pod existing APIs. They should not be used in new code. #pod #pod MkTemp family: #pod #pod use File::Temp qw/ :mktemp /; #pod #pod ($fh, $file) = mkstemp( "tmpfileXXXXX" ); #pod ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); #pod #pod $tmpdir = mkdtemp( $template ); #pod #pod $unopened_file = mktemp( $template ); #pod #pod POSIX functions: #pod #pod use File::Temp qw/ :POSIX /; #pod #pod $file = tmpnam(); #pod $fh = tmpfile(); #pod #pod ($fh, $file) = tmpnam(); #pod #pod Compatibility functions: #pod #pod $unopened_file = File::Temp::tempnam( $dir, $pfx ); #pod #pod =head1 DESCRIPTION #pod #pod C can be used to create and open temporary files in a safe #pod way. There is both a function interface and an object-oriented #pod interface. The File::Temp constructor or the tempfile() function can #pod be used to return the name and the open filehandle of a temporary #pod file. The tempdir() function can be used to create a temporary #pod directory. #pod #pod The security aspect of temporary file creation is emphasized such that #pod a filehandle and filename are returned together. This helps guarantee #pod that a race condition can not occur where the temporary file is #pod created by another process between checking for the existence of the #pod file and its opening. Additional security levels are provided to #pod check, for example, that the sticky bit is set on world writable #pod directories. See L<"safe_level"> for more information. #pod #pod For compatibility with popular C library functions, Perl implementations of #pod the mkstemp() family of functions are provided. These are, mkstemp(), #pod mkstemps(), mkdtemp() and mktemp(). #pod #pod Additionally, implementations of the standard L #pod tmpnam() and tmpfile() functions are provided if required. #pod #pod Implementations of mktemp(), tmpnam(), and tempnam() are provided, #pod but should be used with caution since they return only a filename #pod that was valid when function was called, so cannot guarantee #pod that the file will not exist by the time the caller opens the filename. #pod #pod Filehandles returned by these functions support the seekable methods. #pod #pod =cut # Toolchain targets v5.8.1, but we'll try to support back to v5.6 anyway. # It might be possible to make this v5.5, but many v5.6isms are creeping # into the code and tests. use 5.006; use strict; use Carp; use File::Spec 0.8; use Cwd (); use File::Path 2.06 qw/ rmtree /; use Fcntl 1.03; use IO::Seekable; # For SEEK_* use Errno; use Scalar::Util 'refaddr'; 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 parent 0.221 qw/ IO::Handle IO::Seekable /; use overload '""' => "STRINGIFY", '0+' => "NUMIFY", fallback => 1; our $DEBUG = 0; our $KEEP_ALL = 0; # We are exporting functions use Exporter 5.57 'import'; # 5.57 lets us import 'import' # Export list - to allow fine tuning of export table our @EXPORT_OK = qw{ tempfile tempdir tmpnam tmpfile mktemp mkstemp mkstemps mkdtemp unlink0 cleanup SEEK_SET SEEK_CUR SEEK_END }; # Groups of functions for export our %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'); # This is a list of characters that can be used in random filenames my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9 _ /); # Maximum number of tries to make a temp file before failing use constant MAX_TRIES => 1000; # Minimum number of X characters that should be in a template use constant MINX => 4; # Default template when no template supplied use constant TEMPXXX => 'X' x 10; # Constants for the security level use constant STANDARD => 0; use constant MEDIUM => 1; use constant HIGH => 2; # OPENFLAGS. If we defined the flag to use with Sysopen here this gives # us an optimisation when many temporary files are requested my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; my $LOCKFLAG; unless ($^O eq 'MacOS') { for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) { my ($bit, $func) = (0, "Fcntl::O_" . $oflag); no strict 'refs'; $OPENFLAGS |= $bit if eval { # Make sure that redefined die handlers do not cause problems # e.g. CGI::Carp local $SIG{__DIE__} = sub {}; local $SIG{__WARN__} = sub {}; $bit = &$func(); 1; }; } # Special case O_EXLOCK $LOCKFLAG = eval { local $SIG{__DIE__} = sub {}; local $SIG{__WARN__} = sub {}; &Fcntl::O_EXLOCK(); }; } # On some systems the O_TEMPORARY flag can be used to tell the OS # to automatically remove the file when it is closed. This is fine # in most cases but not if tempfile is called with UNLINK=>0 and # the filename is requested -- in the case where the filename is to # be passed to another routine. This happens on windows. We overcome # this by using a second open flags variable my $OPENTEMPFLAGS = $OPENFLAGS; unless ($^O eq 'MacOS') { for my $oflag (qw/ TEMPORARY /) { my ($bit, $func) = (0, "Fcntl::O_" . $oflag); local($@); no strict 'refs'; $OPENTEMPFLAGS |= $bit if eval { # Make sure that redefined die handlers do not cause problems # e.g. CGI::Carp local $SIG{__DIE__} = sub {}; local $SIG{__WARN__} = sub {}; $bit = &$func(); 1; }; } } # Private hash tracking which files have been created by each process id via the OO interface my %FILES_CREATED_BY_OBJECT; # INTERNAL ROUTINES - not to be used outside of package # Generic routine for getting a temporary filename # modelled on OpenBSD _gettemp() in mktemp.c # The template must contain X's that are to be replaced # with the random values # Arguments: # TEMPLATE - string containing the XXXXX's that is converted # to a random filename and opened if required # Optionally, a hash can also be supplied containing specific options # "open" => if true open the temp file, else just return the name # default is 0 # "mkdir"=> if true, we are creating a temp directory rather than tempfile # default is 0 # "suffixlen" => number of characters at end of PATH to be ignored. # default is 0. # "unlink_on_close" => indicates that, if possible, the OS should remove # the file as soon as it is closed. Usually indicates # use of the O_TEMPORARY flag to sysopen. # Usually irrelevant on unix # "use_exlock" => Indicates that O_EXLOCK should be used. Default is true. # Optionally a reference to a scalar can be passed into the function # On error this will be used to store the reason for the error # "ErrStr" => \$errstr # "open" and "mkdir" can not both be true # "unlink_on_close" is not used when "mkdir" is true. # The default options are equivalent to mktemp(). # Returns: # filehandle - open file handle (if called with doopen=1, else undef) # temp name - name of the temp file or directory # For example: # ($fh, $name) = _gettemp($template, "open" => 1); # for the current version, failures are associated with # stored in an error string and returned to give the reason whilst debugging # This routine is not called by any external function sub _gettemp { croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' unless scalar(@_) >= 1; # the internal error string - expect it to be overridden # Need this in case the caller decides not to supply us a value # need an anonymous scalar my $tempErrStr; # Default options my %options = ( "open" => 0, "mkdir" => 0, "suffixlen" => 0, "unlink_on_close" => 0, "use_exlock" => 1, "ErrStr" => \$tempErrStr, ); # Read the template my $template = shift; if (ref($template)) { # Use a warning here since we have not yet merged ErrStr carp "File::Temp::_gettemp: template must not be a reference"; return (); } # Check that the number of entries on stack are even if (scalar(@_) % 2 != 0) { # Use a warning here since we have not yet merged ErrStr carp "File::Temp::_gettemp: Must have even number of options"; return (); } # Read the options and merge with defaults %options = (%options, @_) if @_; # Make sure the error string is set to undef ${$options{ErrStr}} = undef; # Can not open the file and make a directory in a single call if ($options{"open"} && $options{"mkdir"}) { ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; return (); } # Find the start of the end of the Xs (position of last X) # Substr starts from 0 my $start = length($template) - 1 - $options{"suffixlen"}; # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string # (taking suffixlen into account). Any fewer is insecure. # Do it using substr - no reason to use a pattern match since # we know where we are looking and what we are looking for if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { ${$options{ErrStr}} = "The template must end with at least ". MINX . " 'X' characters\n"; return (); } # Replace all the X at the end of the substring with a # random character or just all the XX at the end of a full string. # Do it as an if, since the suffix adjusts which section to replace # and suffixlen=0 returns nothing if used in the substr directly # and generate a full path from the template my $path = _replace_XX($template, $options{"suffixlen"}); # Split the path into constituent parts - eventually we need to check # whether the directory exists # We need to know whether we are making a temp directory # or a tempfile my ($volume, $directories, $file); my $parent; # parent directory if ($options{"mkdir"}) { # There is no filename at the end ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); # The parent is then $directories without the last directory # Split the directory and put it back together again my @dirs = File::Spec->splitdir($directories); # If @dirs only has one entry (i.e. the directory template) that means # we are in the current directory if ($#dirs == 0) { $parent = File::Spec->curdir; } else { if ($^O eq 'VMS') { # need volume to avoid relative dir spec $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); $parent = 'sys$disk:[]' if $parent eq ''; } else { # Put it back together without the last one $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); # ...and attach the volume (no filename) $parent = File::Spec->catpath($volume, $parent, ''); } } } else { # Get rid of the last filename (use File::Basename for this?) ($volume, $directories, $file) = File::Spec->splitpath( $path ); # Join up without the file part $parent = File::Spec->catpath($volume,$directories,''); # If $parent is empty replace with curdir $parent = File::Spec->curdir unless $directories ne ''; } # Check that the parent directories exist # Do this even for the case where we are simply returning a name # not a file -- no point returning a name that includes a directory # that does not exist or is not writable unless (-e $parent) { ${$options{ErrStr}} = "Parent directory ($parent) does not exist"; return (); } unless (-d $parent) { ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; return (); } # Check the stickiness of the directory and chown giveaway if required # If the directory is world writable the sticky bit # must be set if (File::Temp->safe_level == MEDIUM) { my $safeerr; unless (_is_safe($parent,\$safeerr)) { ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; return (); } } elsif (File::Temp->safe_level == HIGH) { my $safeerr; unless (_is_verysafe($parent, \$safeerr)) { ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; return (); } } # Now try MAX_TRIES time to open the file for (my $i = 0; $i < MAX_TRIES; $i++) { # Try to open the file if requested if ($options{"open"}) { my $fh; # If we are running before perl5.6.0 we can not auto-vivify if ($] < 5.006) { $fh = &Symbol::gensym; } # Try to make sure this will be marked close-on-exec # XXX: Win32 doesn't respect this, nor the proper fcntl, # but may have O_NOINHERIT. This may or may not be in Fcntl. local $^F = 2; # Attempt to open the file my $open_success = undef; if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { # make it auto delete on close by setting FAB$V_DLT bit $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); $open_success = $fh; } else { my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? $OPENTEMPFLAGS : $OPENFLAGS ); $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock}); $open_success = sysopen($fh, $path, $flags, 0600); } if ( $open_success ) { # in case of odd umask force rw chmod(0600, $path); # Opened successfully - return file handle and name return ($fh, $path); } else { # Error opening file - abort with error # if the reason was anything but EEXIST unless ($!{EEXIST}) { ${$options{ErrStr}} = "Could not create temp file $path: $!"; return (); } # Loop round for another try } } elsif ($options{"mkdir"}) { # Open the temp directory if (mkdir( $path, 0700)) { # in case of odd umask chmod(0700, $path); return undef, $path; } else { # Abort with error if the reason for failure was anything # except EEXIST unless ($!{EEXIST}) { ${$options{ErrStr}} = "Could not create directory $path: $!"; return (); } # Loop round for another try } } else { # Return true if the file can not be found # Directory has been checked previously return (undef, $path) unless -e $path; # Try again until MAX_TRIES } # Did not successfully open the tempfile/dir # so try again with a different set of random letters # No point in trying to increment unless we have only # 1 X say and the randomness could come up with the same # file MAX_TRIES in a row. # Store current attempt - in principle 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 occasionally # 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 available 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 (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) { 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 explicitly closed if open # - filename (the thing we want to remove) # - isdir (flag to indicate that we are being given a directory) # [and hence no filehandle] # Status is not referred to since all the magic is done with an END block { # Will set up two lexical variables to contain all the files to be # removed. One array for files, another for directories They will # only exist in this block. # This means we only have to set up a single END block to remove # all files. # in order to prevent child processes inadvertently deleting the parent # temp files we use a hash to store the temp files and directories # created by a particular process id. # %files_to_unlink contains values that are references to an array of # array references containing the filehandle and filename associated with # the temp file. my (%files_to_unlink, %dirs_to_unlink); # Set up an end block to use these arrays END { local($., $@, $!, $^E, $?); cleanup(at_exit => 1); } # Cleanup function. Always triggered on END (with at_exit => 1) but # can be invoked manually. sub cleanup { my %h = @_; my $at_exit = delete $h{at_exit}; $at_exit = 0 if not defined $at_exit; { my @k = sort keys %h; die "unrecognized parameters: @k" if @k } 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 don't 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{$$} } : () ); my ($cwd, $cwd_to_remove); foreach my $dir (@dirs) { if (-d $dir) { # Some versions of rmtree will abort if you attempt to remove # the directory you are sitting in. For automatic cleanup # at program exit, we avoid this by chdir()ing out of the way # first. If not at program exit, it's best not to mess with the # current directory, so just let it fail with a warning. if ($at_exit) { $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd; my $abs = Cwd::abs_path($dir); if ($abs eq $cwd) { $cwd_to_remove = $dir; next; } } eval { rmtree($dir, $DEBUG, 0); }; warn $@ if ($@ && $^W); } } if (defined $cwd_to_remove) { # We do need to clean up the current directory, and everything # else is done, so get out of there and remove it. chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!"; my $updir = File::Spec->updir; chdir $updir or die "cannot chdir to $updir: $!"; eval { rmtree($cwd_to_remove, $DEBUG, 0); }; warn $@ if ($@ && $^W); } # clear the arrays @{ $files_to_unlink{$$} } = () if exists $files_to_unlink{$$}; @{ $dirs_to_unlink{$$} } = () if exists $dirs_to_unlink{$$}; } } # This is the sub called to register a file for deferred unlinking # This could simply store the input parameters and defer everything # until the END block. For now we do a bit of checking at this # point in order to make sure that (1) we have a file/dir to delete # and (2) we have been called with the correct arguments. sub _deferred_unlink { croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' unless scalar(@_) == 3; my ($fh, $fname, $isdir) = @_; warn "Setting up deferred removal of $fname\n" if $DEBUG; # make sure we save the absolute path for later cleanup # OK to untaint because we only ever use this internally # as a file path, never interpolating into the shell $fname = Cwd::abs_path($fname); ($fname) = $fname =~ /^(.*)$/; # 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; } } } } # normalize argument keys to upper case and do consistent handling # of leading template vs TEMPLATE sub _parse_args { my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' ); my %args = @_; %args = map { uc($_), $args{$_} } keys %args; # template (store it in an array so that it will # disappear from the arg list of tempfile) my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : $leading_template ? $leading_template : () ); delete $args{TEMPLATE}; return( \@template, \%args ); } #pod =head1 OBJECT-ORIENTED INTERFACE #pod #pod This is the primary interface for interacting with #pod C. Using the OO interface a temporary file can be created #pod when the object is constructed and the file can be removed when the #pod object is no longer required. #pod #pod Note that there is no method to obtain the filehandle from the #pod C object. The object itself acts as a filehandle. The object #pod isa C and isa C so all those methods are #pod available. #pod #pod Also, the object is configured such that it stringifies to the name of the #pod temporary file and so can be compared to a filename directly. It numifies #pod to the C the same as other handles and so can be compared to other #pod handles with C<==>. #pod #pod $fh eq $filename # as a string #pod $fh != \*STDOUT # as a number #pod #pod Available since 0.14. #pod #pod =over 4 #pod #pod =item B #pod #pod Create a temporary file object. #pod #pod my $tmp = File::Temp->new(); #pod #pod by default the object is constructed as if C #pod was called without options, but with the additional behaviour #pod that the temporary file is removed by the object destructor #pod if UNLINK is set to true (the default). #pod #pod Supported arguments are the same as for C: UNLINK #pod (defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename #pod template is specified using the TEMPLATE option. The OPEN option #pod is not supported (the file is always opened). #pod #pod $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', #pod DIR => 'mydir', #pod SUFFIX => '.dat'); #pod #pod Arguments are case insensitive. #pod #pod Can call croak() if an error occurs. #pod #pod Available since 0.14. #pod #pod TEMPLATE available since 0.23 #pod #pod =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my ($maybe_template, $args) = _parse_args(@_); # see if they are unlinking (defaulting to yes) my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 ); delete $args->{UNLINK}; # Protect OPEN delete $args->{OPEN}; # Open the file and retain file handle and file name my ($fh, $path) = tempfile( @$maybe_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; } #pod =item B #pod #pod Create a temporary directory using an object oriented interface. #pod #pod $dir = File::Temp->newdir(); #pod #pod By default the directory is deleted when the object goes out of scope. #pod #pod Supports the same options as the C function. Note that directories #pod created with this method default to CLEANUP => 1. #pod #pod $dir = File::Temp->newdir( $template, %options ); #pod #pod A template may be specified either with a leading template or #pod with a TEMPLATE argument. #pod #pod Available since 0.19. #pod #pod TEMPLATE available since 0.23. #pod #pod =cut sub newdir { my $self = shift; my ($maybe_template, $args) = _parse_args(@_); # handle CLEANUP without passing CLEANUP to tempdir my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 ); delete $args->{CLEANUP}; my $tempdir = tempdir( @$maybe_template, %$args); # get a safe absolute path for cleanup, just like # happens in _deferred_unlink my $real_dir = Cwd::abs_path( $tempdir ); ($real_dir) = $real_dir =~ /^(.*)$/; return bless { DIRNAME => $tempdir, REALNAME => $real_dir, CLEANUP => $cleanup, LAUNCHPID => $$, }, "File::Temp::Dir"; } #pod =item B #pod #pod Return the name of the temporary file associated with this object #pod (if the object was created using the "new" constructor). #pod #pod $filename = $tmp->filename; #pod #pod This method is called automatically when the object is used as #pod a string. #pod #pod Current API available since 0.14 #pod #pod =cut sub filename { my $self = shift; return ${*$self}; } sub STRINGIFY { my $self = shift; return $self->filename; } # For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because # refaddr() demands one parameter only, whereas overload.pm calls with three # even for unary operations like '0+'. sub NUMIFY { return refaddr($_[0]); } #pod =item B #pod #pod Return the name of the temporary directory associated with this #pod object (if the object was created using the "newdir" constructor). #pod #pod $dirname = $tmpdir->dirname; #pod #pod This method is called automatically when the object is used in string context. #pod #pod =item B #pod #pod Control whether the file is unlinked when the object goes out of scope. #pod The file is removed if this value is true and $KEEP_ALL is not. #pod #pod $fh->unlink_on_destroy( 1 ); #pod #pod Default is for the file to be removed. #pod #pod Current API available since 0.15 #pod #pod =cut sub unlink_on_destroy { my $self = shift; if (@_) { ${*$self}{UNLINK} = shift; } return ${*$self}{UNLINK}; } #pod =item B #pod #pod When the object goes out of scope, the destructor is called. This #pod destructor will attempt to unlink the file (using L) #pod if the constructor was called with UNLINK set to 1 (the default state #pod if UNLINK is not specified). #pod #pod No error is given if the unlink fails. #pod #pod If the object has been passed to a child process during a fork, the #pod file will be deleted when the object goes out of scope in the parent. #pod #pod For a temporary directory object the directory will be removed unless #pod the CLEANUP argument was used in the constructor (and set to false) or #pod C was modified after creation. Note that if a temp #pod directory is your current directory, it cannot be removed - a warning #pod will be given in this case. C out of the directory before #pod letting the object go out of scope. #pod #pod If the global variable $KEEP_ALL is true, the file or directory #pod will not be removed. #pod #pod =cut sub DESTROY { local($., $@, $!, $^E, $?); my $self = shift; # Make sure we always remove the file from the global hash # on destruction. This prevents the hash from growing uncontrollably # and post-destruction there is no reason to know about the file. my $file = $self->filename; my $was_created_by_proc; if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) { $was_created_by_proc = 1; delete $FILES_CREATED_BY_OBJECT{$$}{$file}; } if (${*$self}{UNLINK} && !$KEEP_ALL) { print "# ---------> Unlinking $self\n" if $DEBUG; # only delete if this process created it return unless $was_created_by_proc; # The unlink1 may fail if the file has been closed # by the caller. This leaves us with the decision # of whether to refuse to remove the file or simply # do an unlink without test. Seems to be silly # to do this when we are trying to be careful # about security _force_writable( $file ); # for windows unlink1( $self, $file ) or unlink($file); } } #pod =back #pod #pod =head1 FUNCTIONS #pod #pod This section describes the recommended interface for generating #pod temporary files and directories. #pod #pod =over 4 #pod #pod =item B #pod #pod This is the basic function to generate temporary files. #pod The behaviour of the file can be changed using various options: #pod #pod $fh = tempfile(); #pod ($fh, $filename) = tempfile(); #pod #pod Create a temporary file in the directory specified for temporary #pod files, as specified by the tmpdir() function in L. #pod #pod ($fh, $filename) = tempfile($template); #pod #pod Create a temporary file in the current directory using the supplied #pod template. Trailing `X' characters are replaced with random letters to #pod generate the filename. At least four `X' characters must be present #pod at the end of the template. #pod #pod ($fh, $filename) = tempfile($template, SUFFIX => $suffix) #pod #pod Same as previously, except that a suffix is added to the template #pod after the `X' translation. Useful for ensuring that a temporary #pod filename has a particular extension when needed by other applications. #pod But see the WARNING at the end. #pod #pod ($fh, $filename) = tempfile($template, DIR => $dir); #pod #pod Translates the template as before except that a directory name #pod is specified. #pod #pod ($fh, $filename) = tempfile($template, TMPDIR => 1); #pod #pod Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file #pod into the same temporary directory as would be used if no template was #pod specified at all. #pod #pod ($fh, $filename) = tempfile($template, UNLINK => 1); #pod #pod Return the filename and filehandle as before except that the file is #pod automatically removed when the program exits (dependent on #pod $KEEP_ALL). Default is for the file to be removed if a file handle is #pod requested and to be kept if the filename is requested. In a scalar #pod context (where no filename is returned) the file is always deleted #pod either (depending on the operating system) on exit or when it is #pod closed (unless $KEEP_ALL is true when the temp file is created). #pod #pod Use the object-oriented interface if fine-grained control of when #pod a file is removed is required. #pod #pod If the template is not specified, a template is always #pod automatically generated. This temporary file is placed in tmpdir() #pod (L) unless a directory is specified explicitly with the #pod DIR option. #pod #pod $fh = tempfile( DIR => $dir ); #pod #pod If called in scalar context, only the filehandle is returned and the #pod file will automatically be deleted when closed on operating systems #pod that support this (see the description of tmpfile() elsewhere in this #pod document). This is the preferred mode of operation, as if you only #pod have a filehandle, you can never create a race condition by fumbling #pod with the filename. On systems that can not unlink an open file or can #pod not mark a file as temporary when it is opened (for example, Windows #pod NT uses the C flag) the file is marked for deletion when #pod the program ends (equivalent to setting UNLINK to 1). The C #pod flag is ignored if present. #pod #pod (undef, $filename) = tempfile($template, OPEN => 0); #pod #pod This will return the filename based on the template but #pod will not open this file. Cannot be used in conjunction with #pod UNLINK set to true. Default is to always open the file #pod to protect from possible race conditions. A warning is issued #pod if warnings are turned on. Consider using the tmpnam() #pod and mktemp() functions described elsewhere in this document #pod if opening the file is not required. #pod #pod If the operating system supports it (for example BSD derived systems), the #pod filehandle will be opened with O_EXLOCK (open with exclusive file lock). #pod This can sometimes cause problems if the intention is to pass the filename #pod to another system that expects to take an exclusive lock itself (such as #pod DBD::SQLite) whilst ensuring that the tempfile is not reused. In this #pod situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK #pod will be true (this retains compatibility with earlier releases). #pod #pod ($fh, $filename) = tempfile($template, EXLOCK => 0); #pod #pod Options can be combined as required. #pod #pod Will croak() if there is an error. #pod #pod Available since 0.05. #pod #pod UNLINK flag available since 0.10. #pod #pod TMPDIR flag available since 0.19. #pod #pod EXLOCK flag available since 0.19. #pod #pod =cut sub tempfile { if ( @_ && $_[0] eq 'File::Temp' ) { croak "'tempfile' can't be called as a method"; } # 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 ($maybe_template, $args) = _parse_args(@_); my $template = @$maybe_template ? $maybe_template->[0] : undef; # Read the options and merge with defaults %options = (%options, %$args); # 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(_wrap_file_spec_tmpdir(), $template ); } } else { if ($options{"DIR"}) { $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); } else { $template = File::Spec->catfile(_wrap_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 $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; } } # On Windows under taint mode, File::Spec could suggest "C:\" as a tempdir # which might not be writable. If that is the case, we fallback to a # user directory. See https://rt.cpan.org/Ticket/Display.html?id=60340 { my ($alt_tmpdir, $checked); sub _wrap_file_spec_tmpdir { return File::Spec->tmpdir unless $^O eq "MSWin32" && ${^TAINT}; if ( $checked ) { return $alt_tmpdir ? $alt_tmpdir : File::Spec->tmpdir; } # probe what File::Spec gives and find a fallback my $xxpath = _replace_XX( "X" x 10, 0 ); # First, see if File::Spec->tmpdir is writable my $tmpdir = File::Spec->tmpdir; my $testpath = File::Spec->catdir( $tmpdir, $xxpath ); if (mkdir( $testpath, 0700) ) { $checked = 1; rmdir $testpath; return $tmpdir; } # Next, see if CSIDL_LOCAL_APPDATA is writable require Win32; my $local_app = File::Spec->catdir( Win32::GetFolderPath( Win32::CSIDL_LOCAL_APPDATA() ), 'Temp' ); $testpath = File::Spec->catdir( $local_app, $xxpath ); if ( -e $local_app or mkdir( $local_app, 0700 ) ) { if (mkdir( $testpath, 0700) ) { $checked = 1; rmdir $testpath; return $alt_tmpdir = $local_app; } } # Can't find something writable croak << "HERE"; Couldn't find a writable temp directory in taint mode. Tried: $tmpdir $local_app Try setting and untainting the TMPDIR environment variable. HERE } } #pod =item B #pod #pod This is the recommended interface for creation of temporary #pod directories. By default the directory will not be removed on exit #pod (that is, it won't be temporary; this behaviour can not be changed #pod because of issues with backwards compatibility). To enable removal #pod either use the CLEANUP option which will trigger removal on program #pod exit, or consider using the "newdir" method in the object interface which #pod will allow the directory to be cleaned up when the object goes out of #pod scope. #pod #pod The behaviour of the function depends on the arguments: #pod #pod $tempdir = tempdir(); #pod #pod Create a directory in tmpdir() (see L). #pod #pod $tempdir = tempdir( $template ); #pod #pod Create a directory from the supplied template. This template is #pod similar to that described for tempfile(). `X' characters at the end #pod of the template are replaced with random letters to construct the #pod directory name. At least four `X' characters must be in the template. #pod #pod $tempdir = tempdir ( DIR => $dir ); #pod #pod Specifies the directory to use for the temporary directory. #pod The temporary directory name is derived from an internal template. #pod #pod $tempdir = tempdir ( $template, DIR => $dir ); #pod #pod Prepend the supplied directory name to the template. The template #pod should not include parent directory specifications itself. Any parent #pod directory specifications are removed from the template before #pod prepending the supplied directory. #pod #pod $tempdir = tempdir ( $template, TMPDIR => 1 ); #pod #pod Using the supplied template, create the temporary directory in #pod a standard location for temporary files. Equivalent to doing #pod #pod $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); #pod #pod but shorter. Parent directory specifications are stripped from the #pod template itself. The C option is ignored if C is set #pod explicitly. Additionally, C is implied if neither a template #pod nor a directory are supplied. #pod #pod $tempdir = tempdir( $template, CLEANUP => 1); #pod #pod Create a temporary directory using the supplied template, but #pod attempt to remove it (and all files inside it) when the program #pod exits. Note that an attempt will be made to remove all files from #pod the directory even if they were not created by this module (otherwise #pod why ask to clean it up?). The directory removal is made with #pod the rmtree() function from the L module. #pod Of course, if the template is not specified, the temporary directory #pod will be created in tmpdir() and will also be removed at program exit. #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =cut # ' sub tempdir { if ( @_ && $_[0] eq 'File::Temp' ) { croak "'tempdir' can't be called as a method"; } # 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 ($maybe_template, $args) = _parse_args(@_); my $template = @$maybe_template ? $maybe_template->[0] : undef; # Read the options and merge with defaults %options = (%options, %$args); # 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(_wrap_file_spec_tmpdir(), $template); } } } else { if ($options{"DIR"}) { $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); } else { $template = File::Spec->catdir(_wrap_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; } #pod =back #pod #pod =head1 MKTEMP FUNCTIONS #pod #pod The following functions are Perl implementations of the #pod mktemp() family of temp file generation system calls. #pod #pod =over 4 #pod #pod =item B #pod #pod Given a template, returns a filehandle to the temporary file and the name #pod of the file. #pod #pod ($fh, $name) = mkstemp( $template ); #pod #pod In scalar context, just the filehandle is returned. #pod #pod The template may be any filename with some number of X's appended #pod to it, for example F. The trailing X's are replaced #pod with unique alphanumeric combinations. #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =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; } } #pod =item B #pod #pod Similar to mkstemp(), except that an extra argument can be supplied #pod with a suffix to be appended to the template. #pod #pod ($fh, $name) = mkstemps( $template, $suffix ); #pod #pod For example a template of C and suffix of C<.dat> #pod would generate a file similar to F. #pod #pod Returns just the filehandle alone when called in scalar context. #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =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; } } #pod =item B #pod #pod Create a directory from a template. The template must end in #pod X's that are replaced by the routine. #pod #pod $tmpdir_name = mkdtemp($template); #pod #pod Returns the name of the temporary directory created. #pod #pod Directory must be removed by the caller. #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =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; } #pod =item B #pod #pod Returns a valid temporary filename but does not guarantee #pod that the file will not be opened by someone else. #pod #pod $unopened_file = mktemp($template); #pod #pod Template is the same as that required by mkstemp(). #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =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; } #pod =back #pod #pod =head1 POSIX FUNCTIONS #pod #pod This section describes the re-implementation of the tmpnam() #pod and tmpfile() functions described in L #pod using the mkstemp() from this module. #pod #pod Unlike the L implementations, the directory used #pod for the temporary file is not specified in a system include #pod file (C) but simply depends on the choice of tmpdir() #pod returned by L. On some implementations this #pod location can be set using the C environment variable, which #pod may not be secure. #pod If this is a problem, simply use mkstemp() and specify a template. #pod #pod =over 4 #pod #pod =item B #pod #pod When called in scalar context, returns the full name (including path) #pod of a temporary file (uses mktemp()). The only check is that the file does #pod not already exist, but there is no guarantee that that condition will #pod continue to apply. #pod #pod $file = tmpnam(); #pod #pod When called in list context, a filehandle to the open file and #pod a filename are returned. This is achieved by calling mkstemp() #pod after constructing a suitable template. #pod #pod ($fh, $file) = tmpnam(); #pod #pod If possible, this form should be used to prevent possible #pod race conditions. #pod #pod See L for information on the choice of temporary #pod directory for a particular operating system. #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =cut sub tmpnam { # Retrieve the temporary directory name my $tmpdir = _wrap_file_spec_tmpdir(); # XXX I don't know under what circumstances this occurs, -- xdg 2016-04-02 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); } } #pod =item B #pod #pod Returns the filehandle of a temporary file. #pod #pod $fh = tmpfile(); #pod #pod The file is removed when the filehandle is closed or when the program #pod exits. No access to the filename is provided. #pod #pod If the temporary file can not be created undef is returned. #pod Currently this command will probably not work when the temporary #pod directory is on an NFS file system. #pod #pod Will croak() if there is an error. #pod #pod Available since 0.05. #pod #pod Returning undef if unable to create file added in 0.12. #pod #pod =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; } #pod =back #pod #pod =head1 ADDITIONAL FUNCTIONS #pod #pod These functions are provided for backwards compatibility #pod with common tempfile generation C library functions. #pod #pod They are not exported and must be addressed using the full package #pod name. #pod #pod =over 4 #pod #pod =item B #pod #pod Return the name of a temporary file in the specified directory #pod using a prefix. The file is guaranteed not to exist at the time #pod the function was called, but such guarantees are good for one #pod clock tick only. Always use the proper form of C #pod with C if you must open such a filename. #pod #pod $filename = File::Temp::tempnam( $dir, $prefix ); #pod #pod Equivalent to running mktemp() with $dir/$prefixXXXXXXXX #pod (using unix file convention as an example) #pod #pod Because this function uses mktemp(), it can suffer from race conditions. #pod #pod Will croak() if there is an error. #pod #pod Current API available since 0.05. #pod #pod =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); } #pod =back #pod #pod =head1 UTILITY FUNCTIONS #pod #pod Useful functions for dealing with the filehandle and filename. #pod #pod =over 4 #pod #pod =item B #pod #pod Given an open filehandle and the associated filename, make a safe #pod unlink. This is achieved by first checking that the filename and #pod filehandle initially point to the same file and that the number of #pod links to the file is 1 (all fields returned by stat() are compared). #pod Then the filename is unlinked and the filehandle checked once again to #pod verify that the number of links on that file is now 0. This is the #pod closest you can come to making sure that the filename unlinked was the #pod same as the file whose descriptor you hold. #pod #pod unlink0($fh, $path) #pod or die "Error unlinking file $path safely"; #pod #pod Returns false on error but croaks() if there is a security #pod anomaly. The filehandle is not closed since on some occasions this is #pod not required. #pod #pod On some platforms, for example Windows NT, it is not possible to #pod unlink an open file (the file must be closed first). On those #pod platforms, the actual unlinking is deferred until the program ends and #pod good status is returned. A check is still performed to make sure that #pod the filehandle and filename are pointing to the same thing (but not at #pod the time the end block is executed since the deferred removal may not #pod have access to the filehandle). #pod #pod Additionally, on Windows NT not all the fields returned by stat() can #pod be compared. For example, the C and C fields seem to be #pod different. Also, it seems that the size of the file returned by stat() #pod does not always agree, with C being more accurate than #pod C, presumably because of caching issues even when #pod using autoflush (this is usually overcome by waiting a while after #pod writing to the tempfile before attempting to C it). #pod #pod Finally, on NFS file systems the link count of the file handle does #pod not always go to zero immediately after unlinking. Currently, this #pod command is expected to fail on NFS disks. #pod #pod This function is disabled if the global variable $KEEP_ALL is true #pod and an unlink on open file is supported. If the unlink is to be deferred #pod to the END block, the file is still registered for removal. #pod #pod This function should not be called if you are using the object oriented #pod interface since the it will interfere with the object destructor deleting #pod the file. #pod #pod Available Since 0.05. #pod #pod If can not unlink open file, defer removal until later available since 0.06. #pod #pod =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 can't know that # we are on NFS. Since we can't be sure, we'll defer it return 1 if $fh[3] == 0 || $^O eq 'cygwin'; } # fall-through if we can't unlink now _deferred_unlink($fh, $path, 0); return 1; } #pod =item B #pod #pod Compare C of filehandle with C of provided filename. This #pod can be used to check that the filename and filehandle initially point #pod to the same file and that the number of links to the file is 1 (all #pod fields returned by stat() are compared). #pod #pod cmpstat($fh, $path) #pod or die "Error comparing handle with file"; #pod #pod Returns false if the stat information differs or if the link count is #pod greater than 1. Calls croak if there is a security anomaly. #pod #pod On certain platforms, for example Windows, not all the fields returned by stat() #pod can be compared. For example, the C and C fields seem to be #pod different in Windows. Also, it seems that the size of the file #pod returned by stat() does not always agree, with C being more #pod accurate than C, presumably because of caching issues #pod even when using autoflush (this is usually overcome by waiting a while #pod after writing to the tempfile before attempting to C it). #pod #pod Not exported by default. #pod #pod Current API available since 0.14. #pod #pod =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; } #pod =item B #pod #pod Similar to C except after file comparison using cmpstat, the #pod filehandle is closed prior to attempting to unlink the file. This #pod allows the file to be removed without using an END block, but does #pod mean that the post-unlink comparison of the filehandle state provided #pod by C is not available. #pod #pod unlink1($fh, $path) #pod or die "Error closing and unlinking file"; #pod #pod Usually called from the object destructor when using the OO interface. #pod #pod Not exported by default. #pod #pod This function is disabled if the global variable $KEEP_ALL is true. #pod #pod Can call croak() if there is a security anomaly during the stat() #pod comparison. #pod #pod Current API available since 0.14. #pod #pod =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); } #pod =item B #pod #pod Calling this function will cause any temp files or temp directories #pod that are registered for removal to be removed. This happens automatically #pod when the process exits but can be triggered manually if the caller is sure #pod that none of the temp files are required. This method can be registered as #pod an Apache callback. #pod #pod Note that if a temp directory is your current directory, it cannot be #pod removed. C out of the directory first before calling #pod C. (For the cleanup at program exit when the CLEANUP flag #pod is set, this happens automatically.) #pod #pod On OSes where temp files are automatically removed when the temp file #pod is closed, calling this function will have no effect other than to remove #pod temporary directories (which may include temporary files). #pod #pod File::Temp::cleanup(); #pod #pod Not exported by default. #pod #pod Current API available since 0.15. #pod #pod =back #pod #pod =head1 PACKAGE VARIABLES #pod #pod These functions control the global state of the package. #pod #pod =over 4 #pod #pod =item B #pod #pod Controls the lengths to which the module will go to check the safety of the #pod temporary file or directory before proceeding. #pod Options are: #pod #pod =over 8 #pod #pod =item STANDARD #pod #pod Do the basic security measures to ensure the directory exists and is #pod writable, that temporary files are opened only if they do not already #pod exist, and that possible race conditions are avoided. Finally the #pod L function is used to remove files safely. #pod #pod =item MEDIUM #pod #pod In addition to the STANDARD security, the output directory is checked #pod to make sure that it is owned either by root or the user running the #pod program. If the directory is writable by group or by other, it is then #pod checked to make sure that the sticky bit is set. #pod #pod Will not work on platforms that do not support the C<-k> test #pod for sticky bit. #pod #pod =item HIGH #pod #pod In addition to the MEDIUM security checks, also check for the #pod possibility of ``chown() giveaway'' using the L #pod sysconf() function. If this is a possibility, each directory in the #pod path is checked in turn for safeness, recursively walking back to the #pod root directory. #pod #pod For platforms that do not support the L #pod C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is #pod assumed that ``chown() giveaway'' is possible and the recursive test #pod is performed. #pod #pod =back #pod #pod The level can be changed as follows: #pod #pod File::Temp->safe_level( File::Temp::HIGH ); #pod #pod The level constants are not exported by the module. #pod #pod Currently, you must be running at least perl v5.6.0 in order to #pod run with MEDIUM or HIGH security. This is simply because the #pod safety tests use functions from L that are not #pod available in older versions of perl. The problem is that the version #pod number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though #pod they are different versions. #pod #pod On systems that do not support the HIGH or MEDIUM safety levels #pod (for example Win NT or OS/2) any attempt to change the level will #pod be ignored. The decision to ignore rather than raise an exception #pod allows portable programs to be written with high security in mind #pod for the systems that can support this without those programs failing #pod on systems where the extra tests are irrelevant. #pod #pod If you really need to see whether the change has been accepted #pod simply examine the return value of C. #pod #pod $newlevel = File::Temp->safe_level( File::Temp::HIGH ); #pod die "Could not change to high security" #pod if $newlevel != File::Temp::HIGH; #pod #pod Available since 0.05. #pod #pod =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 { # Don't 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; } } #pod =item TopSystemUID #pod #pod This is the highest UID on the current system that refers to a root #pod UID. This is used to make sure that the temporary directory is #pod owned by a system UID (C, C, C etc) rather than #pod simply by root. #pod #pod This is required since on many unix systems C is not owned #pod by root. #pod #pod Default is to assume that any UID less than or equal to 10 is a root #pod UID. #pod #pod File::Temp->top_system_uid(10); #pod my $topid = File::Temp->top_system_uid; #pod #pod This value can be adjusted to reduce security checking if required. #pod The value is only relevant when C is set to MEDIUM or higher. #pod #pod Available since 0.05. #pod #pod =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; } } #pod =item B<$KEEP_ALL> #pod #pod Controls whether temporary files and directories should be retained #pod regardless of any instructions in the program to remove them #pod automatically. This is useful for debugging but should not be used in #pod production code. #pod #pod $File::Temp::KEEP_ALL = 1; #pod #pod Default is for files to be removed as requested by the caller. #pod #pod In some cases, files will only be retained if this variable is true #pod when the file is created. This means that you can not create a temporary #pod file, set this variable and expect the temp file to still be around #pod when the program exits. #pod #pod =item B<$DEBUG> #pod #pod Controls whether debugging messages should be enabled. #pod #pod $File::Temp::DEBUG = 1; #pod #pod Default is for debugging mode to be disabled. #pod #pod Available since 0.15. #pod #pod =back #pod #pod =head1 WARNING #pod #pod For maximum security, endeavour always to avoid ever looking at, #pod touching, or even imputing the existence of the filename. You do not #pod know that that filename is connected to the same file as the handle #pod you have, and attempts to check this can only trigger more race #pod conditions. It's far more secure to use the filehandle alone and #pod dispense with the filename altogether. #pod #pod If you need to pass the handle to something that expects a filename #pod then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for #pod arbitrary programs. Perl code that uses the 2-argument version of #pod C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you #pod will need to pass the filename. You will have to clear the #pod close-on-exec bit on that file descriptor before passing it to another #pod process. #pod #pod use Fcntl qw/F_SETFD F_GETFD/; #pod fcntl($tmpfh, F_SETFD, 0) #pod or die "Can't clear close-on-exec flag on temp fh: $!\n"; #pod #pod =head2 Temporary files and NFS #pod #pod Some problems are associated with using temporary files that reside #pod on NFS file systems and it is recommended that a local filesystem #pod is used whenever possible. Some of the security tests will most probably #pod fail when the temp file is not local. Additionally, be aware that #pod the performance of I/O operations over NFS will not be as good as for #pod a local disk. #pod #pod =head2 Forking #pod #pod In some cases files created by File::Temp are removed from within an #pod END block. Since END blocks are triggered when a child process exits #pod (unless C is used by the child) File::Temp takes care #pod to only remove those temp files created by a particular process ID. This #pod means that a child will not attempt to remove temp files created by the #pod parent process. #pod #pod If you are forking many processes in parallel that are all creating #pod temporary files, you may need to reset the random number seed using #pod srand(EXPR) in each child else all the children will attempt to walk #pod through the same set of random file names and may well cause #pod themselves to give up if they exceed the number of retry attempts. #pod #pod =head2 Directory removal #pod #pod Note that if you have chdir'ed into the temporary directory and it is #pod subsequently cleaned up (either in the END block or as part of object #pod destruction), then you will get a warning from File::Path::rmtree(). #pod #pod =head2 Taint mode #pod #pod If you need to run code under taint mode, updating to the latest #pod L is highly recommended. On Windows, if the directory #pod given by L isn't writable, File::Temp will attempt #pod to fallback to the user's local application data directory or croak #pod with an error. #pod #pod =head2 BINMODE #pod #pod The file returned by File::Temp will have been opened in binary mode #pod if such a mode is available. If that is not correct, use the C #pod function to change the mode of the filehandle. #pod #pod Note that you can modify the encoding of a file opened by File::Temp #pod also by using C. #pod #pod =head1 HISTORY #pod #pod Originally began life in May 1999 as an XS interface to the system #pod mkstemp() function. In March 2000, the OpenBSD mkstemp() code was #pod translated to Perl for total control of the code's #pod security checking, to ensure the presence of the function regardless of #pod operating system and to help with portability. The module was shipped #pod as a standard part of perl from v5.6.1. #pod #pod Thanks to Tom Christiansen for suggesting that this module #pod should be written and providing ideas for code improvements and #pod security enhancements. #pod #pod =head1 SEE ALSO #pod #pod L, L, L, L #pod #pod See L and L, L for #pod different implementations of temporary file handling. #pod #pod See L for an alternative object-oriented wrapper for #pod the C function. #pod #pod =cut package File::Temp::Dir; # git description: v0.2305-8-g4787a5d our $VERSION = '0.2306'; use File::Path qw/ rmtree /; use strict; use overload '""' => "STRINGIFY", '0+' => \&File::Temp::NUMIFY, fallback => 1; # private class specifically to support tempdir objects # created by File::Temp->newdir # ostensibly the same method interface as File::Temp but without # inheriting all the IO::Seekable methods and other cruft # Read-only - returns the name of the temp directory sub dirname { my $self = shift; return $self->{DIRNAME}; } sub STRINGIFY { my $self = shift; return $self->dirname; } sub unlink_on_destroy { my $self = shift; if (@_) { $self->{CLEANUP} = shift; } return $self->{CLEANUP}; } sub DESTROY { my $self = shift; local($., $@, $!, $^E, $?); if ($self->unlink_on_destroy && $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { if (-d $self->{REALNAME}) { # Some versions of rmtree will abort if you attempt to remove # the directory you are sitting in. We protect that and turn it # into a warning. We do this because this occurs during object # destruction and so can not be caught by the user. eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); }; warn $@ if ($@ && $^W); } } } 1; # vim: ts=2 sts=2 sw=2 et: __END__ =pod =encoding UTF-8 =head1 NAME File::Temp - return name and handle of a temporary file safely =head1 VERSION version 0.2306 =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 ); $dir = File::Temp->newdir(); # CLEANUP => 1 by default 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 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 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. =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 reliable? By default all the return values from C 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 utility function C fails then the C 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 OBJECT-ORIENTED INTERFACE This is the primary interface for interacting with C. 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 object. The object itself acts as a filehandle. The object isa C and isa C so all those methods are available. Also, the object is configured such that it stringifies to the name of the temporary file and so can be compared to a filename directly. It numifies to the C the same as other handles and so can be compared to other handles with C<==>. $fh eq $filename # as a string $fh != \*STDOUT # as a number Available since 0.14. =over 4 =item B Create a temporary file object. my $tmp = File::Temp->new(); by default the object is constructed as if C 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: 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. Available since 0.14. TEMPLATE available since 0.23 =item B 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 function. Note that directories created with this method default to CLEANUP => 1. $dir = File::Temp->newdir( $template, %options ); A template may be specified either with a leading template or with a TEMPLATE argument. Available since 0.19. TEMPLATE available since 0.23. =item B 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. Current API available since 0.14 =item B 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 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. Current API available since 0.15 =item B When the object goes out of scope, the destructor is called. This destructor will attempt to unlink the file (using L) 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 was modified after creation. Note that if a temp directory is your current directory, it cannot be removed - a warning will be given in this case. C out of the directory before letting the object go out of scope. If the global variable $KEEP_ALL is true, the file or directory will not be removed. =back =head1 FUNCTIONS This section describes the recommended interface for generating temporary files and directories. =over 4 =item B 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. ($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) 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 flag) the file is marked for deletion when the program ends (equivalent to setting UNLINK to 1). The C 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. Available since 0.05. UNLINK flag available since 0.10. TMPDIR flag available since 0.19. EXLOCK flag available since 0.19. =item B 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). $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 option is ignored if C is set explicitly. Additionally, C 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 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. Current API available since 0.05. =back =head1 MKTEMP FUNCTIONS The following functions are Perl implementations of the mktemp() family of temp file generation system calls. =over 4 =item B 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. The trailing X's are replaced with unique alphanumeric combinations. Will croak() if there is an error. Current API available since 0.05. =item B 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 and suffix of C<.dat> would generate a file similar to F. Returns just the filehandle alone when called in scalar context. Will croak() if there is an error. Current API available since 0.05. =item B 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. Current API available since 0.05. =item B 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. Current API available since 0.05. =back =head1 POSIX FUNCTIONS This section describes the re-implementation of the tmpnam() and tmpfile() functions described in L using the mkstemp() from this module. Unlike the L implementations, the directory used for the temporary file is not specified in a system include file (C) but simply depends on the choice of tmpdir() returned by L. On some implementations this location can be set using the C environment variable, which may not be secure. If this is a problem, simply use mkstemp() and specify a template. =over 4 =item B 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 for information on the choice of temporary directory for a particular operating system. Will croak() if there is an error. Current API available since 0.05. =item B 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. Available since 0.05. Returning undef if unable to create file added in 0.12. =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 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 with C 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. Current API available since 0.05. =back =head1 UTILITY FUNCTIONS Useful functions for dealing with the filehandle and filename. =over 4 =item B 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 and C fields seem to be different. Also, it seems that the size of the file returned by stat() does not always agree, with C being more accurate than C, 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 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. Available Since 0.05. If can not unlink open file, defer removal until later available since 0.06. =item B Compare C of filehandle with C 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 and C 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 being more accurate than C, 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 it). Not exported by default. Current API available since 0.14. =item B Similar to C 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 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. Current API available since 0.14. =item B 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. Note that if a temp directory is your current directory, it cannot be removed. C out of the directory first before calling C. (For the cleanup at program exit when the CLEANUP flag is set, this happens automatically.) 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. Current API available since 0.15. =back =head1 PACKAGE VARIABLES These functions control the global state of the package. =over 4 =item B 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 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 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 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 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. $newlevel = File::Temp->safe_level( File::Temp::HIGH ); die "Could not change to high security" if $newlevel != File::Temp::HIGH; Available since 0.05. =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, C, C etc) rather than simply by root. This is required since on many unix systems C 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 is set to MEDIUM or higher. Available since 0.05. =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. Available since 0.15. =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 you can use C<"/dev/fd/" . fileno($fh)> for arbitrary programs. Perl code that uses the 2-argument version of C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you will need to pass the filename. 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 is used by the child) File::Temp takes care to only remove those temp files created by a particular process ID. This means that a child will not attempt to remove temp files created by the parent process. If you are forking many processes in parallel that are all creating temporary files, you may need to reset the random number seed using srand(EXPR) in each child else all the children will attempt to walk through the same set of random file names and may well cause themselves to give up if they exceed the number of retry attempts. =head2 Directory removal Note that if you have chdir'ed into the temporary directory and it is subsequently cleaned up (either in the END block or as part of object destruction), then you will get a warning from File::Path::rmtree(). =head2 Taint mode If you need to run code under taint mode, updating to the latest L is highly recommended. On Windows, if the directory given by L isn't writable, File::Temp will attempt to fallback to the user's local application data directory or croak with an error. =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 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. =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. Thanks to Tom Christiansen for suggesting that this module should be written and providing ideas for code improvements and security enhancements. =head1 SEE ALSO L, L, L, L See L and L, L for different implementations of temporary file handling. See L for an alternative object-oriented wrapper for the C function. =for Pod::Coverage STRINGIFY NUMIFY top_system_uid =head1 SUPPORT Bugs may be submitted through L (or L). There is also a mailing list available for users of this distribution, at L. There is also an irc channel available for users of this distribution, at L on C|irc://irc.perl.org/#toolchain>. =head1 AUTHOR Tim Jenness =head1 CONTRIBUTORS =for stopwords David Golden Karen Etheridge Olivier Mengue Peter Rabbitson Ben Tilly Kevin Ryde John Acklam Slaven Rezic James E. Keenan Brian Mowrey Dagfinn Ilmari Mannsåker Steinbrunner Ed Avis Guillem Jover =over 4 =item * David Golden =item * Karen Etheridge =item * Olivier Mengue =item * David Golden =item * Peter Rabbitson =item * Ben Tilly =item * Kevin Ryde =item * Peter John Acklam =item * Slaven Rezic =item * Slaven Rezic =item * James E. Keenan =item * Brian Mowrey =item * Dagfinn Ilmari Mannsåker =item * David Steinbrunner =item * Ed Avis =item * Guillem Jover =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2018 by Tim Jenness and the UK Particle Physics and Astronomy Research Council. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Fetch.pm000064400000133422152345537030006147 0ustar00package File::Fetch; use strict; use FileHandle; use File::Temp; use File::Copy; use File::Spec; use File::Spec::Unix; use File::Basename qw[dirname]; use Cwd qw[cwd]; use Carp qw[carp]; use IPC::Cmd qw[can_run run QUOTE]; use File::Path qw[mkpath]; use File::Temp qw[tempdir]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Style => 'gettext'; use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $BLACKLIST $METHOD_FAIL $VERSION $METHODS $FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4 ]; $VERSION = '0.56'; $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|]; push @$BLACKLIST, qw|lftp| if $^O eq 'dragonfly' || $^O eq 'hpux'; $METHOD_FAIL = { }; $FTP_PASSIVE = 1; $TIMEOUT = 0; $DEBUG = 0; $WARN = 1; $FORCEIPV4 = 0; ### methods available to fetch the file depending on the scheme $METHODS = { http => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ], https => [ qw|lwp wget curl| ], ftp => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ], file => [ qw|lwp lftp file| ], rsync => [ qw|rsync| ], git => [ qw|git| ], }; ### silly warnings ### local $Params::Check::VERBOSE = 1; local $Params::Check::VERBOSE = 1; local $Module::Load::Conditional::VERBOSE = 0; local $Module::Load::Conditional::VERBOSE = 0; ### Fix CVE-2016-1238 ### local $Module::Load::Conditional::FORCE_SAFE_INC = 1; ### 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); use constant HAS_FETCH => ( $^O =~ m!^(freebsd|netbsd|dragonfly)$! ); =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, C, C, C or C uri by a number of different means. See the C section further down for details. =head1 ACCESSORS A C 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. =item $ff->file_default The name of the default local file, that $ff->output_file falls back to if it would otherwise return no filename. For example when fetching a URI like http://www.abc.net.au/ the contents retrieved may be from a remote file called 'index.html'. The default value of this attribute is literally 'file_default'. =cut ########################## ### Object & Accessors ### ########################## { ### template for autogenerated accessors ### my $Tmpl = { scheme => { default => 'http' }, host => { default => 'localhost' }, path => { default => '/' }, file => { required => 1 }, uri => { required => 1 }, userinfo => { default => '' }, vol => { default => '' }, # windows for file:// uris share => { default => '' }, # windows for file:// uris file_default => { default => 'file_default' }, tempdir_root => { required => 1 }, # Should be lazy-set at ->new() _error_msg => { no_override => 1 }, _error_msg_long => { no_override => 1 }, }; for my $method ( keys %$Tmpl ) { no strict 'refs'; *$method = sub { my $self = shift; $self->{$method} = $_[0] if @_; return $self->{$method}; } } sub _create { my $class = shift; my %hash = @_; my $args = check( $Tmpl, \%hash ) or return; bless $args, $class; if( lc($args->scheme) ne 'file' and not $args->host ) { return $class->_error(loc( "Hostname required when fetching from '%1'",$args->scheme)); } for (qw[path]) { unless( $args->$_() ) { # 5.5.x needs the () return $class->_error(loc("No '%1' specified",$_)); } } return $args; } } =item $ff->output_file The name of the output file. This is the same as $ff->file, but any query parameters are stripped off. For example: http://example.com/index.html?x=y would make the output file be C rather than C. =back =cut sub output_file { my $self = shift; my $file = $self->file; $file =~ s/\?.*$//g; $file ||= $self->file_default; 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 Ced and returns it. Returns false on failure. =cut sub new { my $class = shift; my %hash = @_; my ($uri, $file_default, $tempdir_root); my $tmpl = { uri => { required => 1, store => \$uri }, file_default => { required => 0, store => \$file_default }, tempdir_root => { required => 0, store => \$tempdir_root }, }; check( $tmpl, \%hash ) or return; ### parse the uri to usable parts ### my $href = $class->_parse_uri( $uri ) or return; $href->{file_default} = $file_default if $file_default; $href->{tempdir_root} = File::Spec->rel2abs( $tempdir_root ) if $tempdir_root; $href->{tempdir_root} = File::Spec->rel2abs( Cwd::cwd ) if not $href->{tempdir_root}; ### make it into a FFI object ### my $ff = $class->_create( %$href ) or return; ### return the object ### return $ff; } ### parses an uri to a hash structure: ### ### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' ) ### ### becomes: ### ### $href = { ### scheme => 'ftp', ### host => 'ftp.cpan.org', ### path => '/pub/mirror', ### file => 'index.html' ### }; ### ### In the case of file:// urls there maybe be additional fields ### ### For systems with volume specifications such as Win32 there will be ### a volume specifier provided in the 'vol' field. ### ### 'vol' => 'volumename' ### ### For windows file shares there may be a 'share' key specified ### ### 'share' => 'sharename' ### ### Note that the rules of what a file:// url means vary by the operating system ### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious ### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and ### not '/foo/bar.txt' ### ### Similarly if the host interpreting the url is VMS then ### file:///disk$user/my/notes/note12345.txt' means ### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as ### if it is unix where it means /disk$user/my/notes/note12345.txt'. ### Except for some cases in the File::Spec methods, Perl on VMS will generally ### handle UNIX format file specifications. ### ### This means it is impossible to serve certain file:// urls on certain systems. ### ### Thus are the problems with a protocol-less specification. :-( ### sub _parse_uri { my $self = shift; my $uri = shift or return; my $href = { uri => $uri }; ### find the scheme ### $uri =~ s|^(\w+)://||; $href->{scheme} = $1; ### See rfc 1738 section 3.10 ### http://www.faqs.org/rfcs/rfc1738.html ### And wikipedia for more on windows file:// urls ### http://en.wikipedia.org/wiki/File:// if( $href->{scheme} eq 'file' ) { my @parts = split '/',$uri; ### file://hostname/... ### file://hostname/... ### normalize file://localhost with file:/// $href->{host} = $parts[0] || ''; ### index in @parts where the path components begin; my $index = 1; ### file:////hostname/sharename/blah.txt if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) { $href->{host} = $parts[2] || ''; # avoid warnings $href->{share} = $parts[3] || ''; # avoid warnings $index = 4 # index after the share ### file:///D|/blah.txt ### file:///D:/blah.txt } elsif (HAS_VOL) { ### this code comes from dmq's patch, but: ### XXX if volume is empty, wouldn't that be an error? --kane ### if so, our file://localhost test needs to be fixed as wel $href->{vol} = $parts[1] || ''; ### correct D| style colume descriptors $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN; $index = 2; # index after the volume } ### rebuild the path from the leftover parts; $href->{path} = join '/', '', splice( @parts, $index, $#parts ); } else { ### using anything but qw() in hash slices may produce warnings ### in older perls :-( @{$href}{ qw(userinfo host path) } = $uri =~ m|(?:([^\@:]*:[^\:\@]*)@)?([^/]*)(/.*)$|s; } ### split the path into file + dir ### { my @parts = File::Spec::Unix->splitpath( delete $href->{path} ); $href->{path} = $parts[1]; $href->{file} = $parts[2]; } ### host will be empty if the target was 'localhost' and the ### scheme was 'file' $href->{host} = '' if ($href->{host} eq 'localhost') and ($href->{scheme} eq 'file'); return $href; } =head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] ) Fetches the file you requested and returns the full path to the file. By default it writes to C, but you can override that by specifying the C argument: ### file fetch to /tmp, full path to the file in $where $where = $ff->fetch( to => '/tmp' ); ### file slurped into $scalar, full path to the file in $where ### file is downloaded to a temp directory and cleaned up at exit time $where = $ff->fetch( to => \$scalar ); Returns the full path to the downloaded file on success, and false on failure. =cut sub fetch { my $self = shift or return; my %hash = @_; my $target; my $tmpl = { to => { default => cwd(), store => \$target }, }; check( $tmpl, \%hash ) or return; my ($to, $fh); ### you want us to slurp the contents if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { $to = tempdir( 'FileFetch.XXXXXX', DIR => $self->tempdir_root, CLEANUP => 1 ); ### plain old fetch } else { $to = $target; ### On VMS force to VMS format so File::Spec will work. $to = VMS::Filespec::vmspath($to) if ON_VMS; ### create the path if it doesn't exist yet ### unless( -d $to ) { eval { mkpath( $to ) }; return $self->_error(loc("Could not create path '%1'",$to)) if $@; } } ### set passive ftp if required ### local $ENV{FTP_PASSIVE} = $FTP_PASSIVE; ### we dont use catfile on win32 because if we are using a cygwin tool ### under cmd.exe they wont understand windows style separators. my $out_to = ON_WIN ? $to.'/'.$self->output_file : File::Spec->catfile( $to, $self->output_file ); for my $method ( @{ $METHODS->{$self->scheme} } ) { my $sub = '_'.$method.'_fetch'; unless( __PACKAGE__->can($sub) ) { $self->_error(loc("Cannot call method for '%1' -- WEIRD!", $method)); next; } ### method is blacklisted ### next if grep { lc $_ eq $method } @$BLACKLIST; ### method is known to fail ### next if $METHOD_FAIL->{$method}; ### there's serious issues with IPC::Run and quoting of command ### line arguments. using quotes in the wrong place breaks things, ### and in the case of say, ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document ### "index.html" "http://www.cpan.org/index.html?q=1&y=2" ### it doesn't matter how you quote, it always fails. local $IPC::Cmd::USE_IPC_RUN = 0; if( my $file = $self->$sub( to => $out_to )){ unless( -e $file && -s _ ) { $self->_error(loc("'%1' said it fetched '%2', ". "but it was not created",$method,$file)); ### mark the failure ### $METHOD_FAIL->{$method} = 1; next; } else { ### slurp mode? if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { ### open the file open my $fh, "<$file" or do { $self->_error( loc("Could not open '%1': %2", $file, $!)); return; }; ### slurp $$target = do { local $/; <$fh> }; } my $abs = File::Spec->rel2abs( $file ); return $abs; } } } ### if we got here, we looped over all methods, but we weren't able ### to fetch it. return; } ######################## ### _*_fetch methods ### ######################## ### LWP fetching ### sub _lwp_fetch { my $self = shift; my %hash = @_; my ($to); my $tmpl = { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; ### modules required to download with lwp ### my $use_list = { LWP => '0.0', 'LWP::UserAgent' => '0.0', 'HTTP::Request' => '0.0', 'HTTP::Status' => '0.0', URI => '0.0', }; if ($self->scheme eq 'https') { $use_list->{'LWP::Protocol::https'} = '0'; } unless( can_load( modules => $use_list ) ) { $METHOD_FAIL->{'lwp'} = 1; return; } ### 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 ); if ($self->userinfo) { $uri->userinfo($self->userinfo); } elsif ($self->scheme ne 'file') { $uri->userinfo("anonymous:$FROM_EMAIL"); } ### 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)); } } ### HTTP::Tiny fetching ### sub _httptiny_fetch { my $self = shift; my %hash = @_; my ($to); my $tmpl = { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; my $use_list = { 'HTTP::Tiny' => '0.008', }; unless( can_load(modules => $use_list) ) { $METHOD_FAIL->{'httptiny'} = 1; return; } my $uri = $self->uri; my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) ); my $rc = $http->mirror( $uri, $to ); unless ( $rc->{success} ) { return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]", $rc->{status}, $rc->{reason} ) ); } return $to; } ### HTTP::Lite fetching ### sub _httplite_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 = { 'HTTP::Lite' => '2.2', 'MIME::Base64' => '0', }; unless( can_load(modules => $use_list) ) { $METHOD_FAIL->{'httplite'} = 1; return; } my $uri = $self->uri; my $retries = 0; RETRIES: while ( $retries++ < 5 ) { my $http = HTTP::Lite->new(); # Naughty naughty but there isn't any accessor/setter $http->{timeout} = $TIMEOUT if $TIMEOUT; $http->http11_mode(1); if ($self->userinfo) { my $encoded = MIME::Base64::encode($self->userinfo, ''); $http->add_req_header("Authorization", "Basic $encoded"); } my $fh = FileHandle->new; unless ( $fh->open($to,'>') ) { return $self->_error(loc( "Could not open '%1' for writing: %2",$to,$!)); } $fh->autoflush(1); binmode $fh; my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh ); close $fh; if ( $rc == 301 || $rc == 302 ) { my $loc; HEADERS: for ($http->headers_array) { /Location: (\S+)/ and $loc = $1, last HEADERS; } #$loc or last; # Think we should squeal here. if ($loc =~ m!^/!) { $uri =~ s{^(\w+?://[^/]+)/.*$}{$1}; $uri .= $loc; } else { $uri = $loc; } next RETRIES; } elsif ( $rc == 200 ) { return $to; } else { return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]", $rc, $http->status_message)); } } # Loop for 5 retries. return $self->_error("Fetch failed! Gave up after 5 tries"); } ### Simple IO::Socket::INET fetching ### sub _iosock_fetch { my $self = shift; my %hash = @_; my ($to); my $tmpl = { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; my $use_list = { 'IO::Socket::INET' => '0.0', 'IO::Select' => '0.0', }; unless( can_load(modules => $use_list) ) { $METHOD_FAIL->{'iosock'} = 1; return; } my $sock = IO::Socket::INET->new( PeerHost => $self->host, ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), ); unless ( $sock ) { return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); } my $fh = FileHandle->new; # Check open() unless ( $fh->open($to,'>') ) { return $self->_error(loc( "Could not open '%1' for writing: %2",$to,$!)); } $fh->autoflush(1); binmode $fh; my $path = File::Spec::Unix->catfile( $self->path, $self->file ); my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a"; $sock->send( $req ); my $select = IO::Select->new( $sock ); my $resp = ''; my $normal = 0; while ( $select->can_read( $TIMEOUT || 60 ) ) { my $ret = $sock->sysread( $resp, 4096, length($resp) ); if ( !defined $ret or $ret == 0 ) { $select->remove( $sock ); $normal++; } } close $sock; unless ( $normal ) { return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); } # Check the "response" # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1) $resp =~ s/^(\x0d?\x0a)+//; # Check it is an HTTP response unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) { return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host)); } # Check for OK my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i; unless ( $code eq '200' ) { return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host)); } { local $\; print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; } close $fh; return $to; } ### 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 }; unless( can_load( modules => $use_list ) ) { $METHOD_FAIL->{'netftp'} = 1; return; } ### 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; } ### /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; my $wget; ### see if we have a wget binary ### unless( $wget = can_run('wget') ) { $METHOD_FAIL->{'wget'} = 1; return; } ### no verboseness, thanks ### my $cmd = [ $wget, '--quiet' ]; ### if a timeout is set, add it ### push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; ### run passive if specified ### push @$cmd, '--passive-ftp' if $FTP_PASSIVE; ### set the output document, add the uri ### push @$cmd, '--output-document', $to, $self->uri; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? ($to, $self->uri) # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); ### shell out ### my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG )) { ### wget creates the output document always, even if the fetch ### fails.. so unlink it in that case 1 while unlink $to; return $self->_error(loc( "Command failed: %1", $captured || '' )); } return $to; } ### /bin/lftp fetch ### sub _lftp_fetch { my $self = shift; my %hash = @_; my ($to); my $tmpl = { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; ### see if we have a lftp binary ### my $lftp; unless( $lftp = can_run('lftp') ) { $METHOD_FAIL->{'lftp'} = 1; return; } ### no verboseness, thanks ### my $cmd = [ $lftp, '-f' ]; my $fh = File::Temp->new; my $str; ### if a timeout is set, add it ### $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT; ### run passive if specified ### $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE; ### set the output document, add the uri ### ### quote the URI, because lftp supports certain shell ### expansions, most notably & for backgrounding. ### ' quote does nto work, must be " $str .= q[get ']. $self->uri .q[' -o ]. $to . $/; if( $DEBUG ) { my $pp_str = join ' ', split $/, $str; print "# lftp command: $pp_str\n"; } ### write straight to the file. $fh->autoflush(1); print $fh $str; ### the command needs to be 1 string to be executed push @$cmd, $fh->filename; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? ($to, $self->uri) # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); ### shell out ### my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG )) { ### wget creates the output document always, even if the fetch ### fails.. so unlink it in that case 1 while unlink $to; return $self->_error(loc( "Command failed: %1", $captured || '' )); } return $to; } ### /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 ### my $ftp; unless( $ftp = can_run('ftp') ) { $METHOD_FAIL->{'ftp'} = 1; return; } 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 ### my $lynx; unless ( $lynx = can_run('lynx') ){ $METHOD_FAIL->{'lynx'} = 1; return; } unless( IPC::Cmd->can_capture_buffer ) { $METHOD_FAIL->{'lynx'} = 1; return $self->_error(loc( "Can not capture buffers. Can not use '%1' to fetch files", 'lynx' )); } ### check if the HTTP resource exists ### if ($self->uri =~ /^https?:\/\//i) { my $cmd = [ $lynx, '-head', '-source', "-auth=anonymous:$FROM_EMAIL", ]; push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; push @$cmd, $self->uri; ### shell out ### my $head; unless(run( command => $cmd, buffer => \$head, verbose => $DEBUG ) ) { return $self->_error(loc("Command failed: %1", $head || '')); } unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) { return $self->_error(loc("Command failed: %1", $head || '')); } } ### write to the output file ourselves, since lynx ass_u_mes to much my $local = FileHandle->new( $to, 'w' ) or return $self->_error(loc( "Could not open '%1' for writing: %2",$to,$!)); ### dump to stdout ### my $cmd = [ $lynx, '-source', "-auth=anonymous:$FROM_EMAIL", ]; push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; ### DO NOT quote things for IPC::Run, it breaks stuff. push @$cmd, $self->uri; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? $self->uri # : QUOTE. $self->uri .QUOTE; ### shell out ### my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG ) ) { return $self->_error(loc("Command failed: %1", $captured || '')); } ### print to local file ### ### XXX on a 404 with a special error page, $captured will actually ### hold the contents of that page, and make it *appear* like the ### request was a success, when really it wasn't :( ### there doesn't seem to be an option for lynx to change the exit ### code based on a 4XX status or so. ### the closest we can come is using --error_file and parsing that, ### which is very unreliable ;( $local->print( $captured ); $local->close or return; return $to; } ### 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 sessions, so bail out ### if $FTP_PASSIVE is set return if $FTP_PASSIVE; ### see if we have a ncftp binary ### my $ncftp; unless( $ncftp = can_run('ncftp') ) { $METHOD_FAIL->{'ncftp'} = 1; return; } 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; } ### 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; my $curl; unless ( $curl = can_run('curl') ) { $METHOD_FAIL->{'curl'} = 1; return; } ### these long opts are self explanatory - I like that -jmb my $cmd = [ $curl, '-q' ]; push(@$cmd, '-4') if $^O eq 'netbsd' && $FORCEIPV4; # only seen this on NetBSD so far push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; push(@$cmd, '--silent') unless $DEBUG; ### curl does the right thing with passive, regardless ### if ($self->scheme eq 'ftp') { push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); } ### curl doesn't follow 302 (temporarily moved) etc automatically ### so we add --location to enable that. push @$cmd, '--fail', '--location', '--output', $to, $self->uri; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? ($to, $self->uri) # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG ) ) { return $self->_error(loc("Command failed: %1", $captured || '')); } return $to; } ### /usr/bin/fetch fetch! ### sub _fetch_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 fetch binary ### my $fetch; unless( HAS_FETCH and $fetch = can_run('fetch') ) { $METHOD_FAIL->{'fetch'} = 1; return; } ### no verboseness, thanks ### my $cmd = [ $fetch, '-q' ]; ### if a timeout is set, add it ### push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT; ### run passive if specified ### #push @$cmd, '-p' if $FTP_PASSIVE; local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE; ### set the output document, add the uri ### push @$cmd, '-o', $to, $self->uri; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? ($to, $self->uri) # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); ### shell out ### my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG )) { ### wget creates the output document always, even if the fetch ### fails.. so unlink it in that case 1 while unlink $to; return $self->_error(loc( "Command failed: %1", $captured || '' )); } return $to; } ### 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 ### whereas 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; my $rsync; unless ( $rsync = can_run('rsync') ) { $METHOD_FAIL->{'rsync'} = 1; return; } my $cmd = [ $rsync ]; ### XXX: rsync has no I/O timeouts at all, by default push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; push(@$cmd, '--quiet') unless $DEBUG; ### DO NOT quote things for IPC::Run, it breaks stuff. push @$cmd, $self->uri, $to; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? ($to, $self->uri) # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG ) ) { return $self->_error(loc("Command %1 failed: %2", "@$cmd" || '', $captured || '')); } return $to; } ### use git to fetch files sub _git_fetch { my $self = shift; my %hash = @_; my ($to); my $tmpl = { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; my $git; unless ( $git = can_run('git') ) { $METHOD_FAIL->{'git'} = 1; return; } my $cmd = [ $git, 'clone' ]; #push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; push(@$cmd, '--quiet') unless $DEBUG; ### DO NOT quote things for IPC::Run, it breaks stuff. push @$cmd, $self->uri, $to; ### with IPC::Cmd > 0.41, this is fixed in teh library, ### and there's no need for special casing any more. ### DO NOT quote things for IPC::Run, it breaks stuff. # $IPC::Cmd::USE_IPC_RUN # ? ($to, $self->uri) # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); my $captured; unless(run( command => $cmd, buffer => \$captured, verbose => $DEBUG ) ) { return $self->_error(loc("Command %1 failed: %2", "@$cmd" || '', $captured || '')); } return $to; } ################################# # # Error code # ################################# =pod =head2 $ff->error([BOOL]) Returns the last encountered error as string. Pass it a true value to get the C output instead. =cut ### error handling the way Archive::Extract does it sub _error { my $self = shift; my $error = shift; $self->_error_msg( $error ); $self->_error_msg_long( Carp::longmess($error) ); if( $WARN ) { carp $DEBUG ? $self->_error_msg_long : $self->_error_msg; } return; } sub error { my $self = shift; return shift() ? $self->_error_msg_long : $self->_error_msg; } 1; =pod =head1 HOW IT WORKS File::Fetch is able to fetch a variety of uris, by using several external programs and modules. Below is a mapping of what utilities will be used in what order for what schemes, if available: file => LWP, lftp, file http => LWP, HTTP::Tiny, wget, curl, lftp, fetch, HTTP::Lite, lynx, iosock ftp => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp rsync => rsync git => git 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 method will only fail when all options are exhausted, and it was not able to retrieve the file. The C utility is available on FreeBSD. NetBSD and Dragonfly BSD may also have it from C. We only check for C on those three platforms. C is a very limited L based mechanism for retrieving C schemed urls. It doesn't follow redirects for instance. C only supports C style urls. 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 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. =head2 $File::Fetch::USER_AGENT This is the useragent as C will report it. Default is C. =head2 $File::Fetch::FTP_PASSIVE This variable controls whether the environment variable C and any passive switches to commandline tools will be set to true. Default value is 1. Note: When $FTP_PASSIVE is true, C 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 should be C'd or not. Set to false to silence warnings. Inspect the output of the C method manually to see what went wrong. Defaults to C. =head2 $File::Fetch::DEBUG This enables debugging output when calling commandline utilities to fetch files. This also enables C errors, instead of the regular C 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 and C, you could set $File::Fetch::BLACKLIST to: $File::Fetch::BLACKLIST = [qw|lwp netftp|] The default blacklist is [qw|ftp|], as C is rather unreliable. See the note on C 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 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 HTTP::Lite => httplite HTTP::Tiny => httptiny Net::FTP => netftp wget => wget lynx => lynx ncftp => ncftp ftp => ftp curl => curl rsync => rsync lftp => lftp fetch => fetch IO::Socket => iosock =head1 FREQUENTLY ASKED QUESTIONS =head2 So how do I use a proxy with File::Fetch? C 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 can only fetch remote files by dumping its contents to C, 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 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 'successful' fetch and a custom error page. Therefor, we recommend to only use C 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 is relatively smart about things. When trying to write a file to disk, it removes the C (see the C 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 module from CPAN, and pre-encode your URI before passing it to C. 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 Ebug-file-fetch@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =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: