Listing.pm000064400000033114000000000000006456 0ustar00package File::Listing; use strict; use warnings; use Carp (); use HTTP::Date qw(str2time); use base qw( Exporter ); # ABSTRACT: Parse directory listing our $VERSION = '6.14'; # VERSION sub Version { $File::Listing::VERSION; } our @EXPORT = qw(parse_dir); 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 "*" && $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 split 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 (my $line = <$dir>) { chomp $line; push(@files, $pkg->line($line, $tz, $error)); } } wantarray ? @files : \@files; ## no critic (Freenode::Wantarray) } package File::Listing::unix; use HTTP::Date qw(str2time); our @ISA = qw(File::Listing); # A place to remember current directory from last line parsed. our $curdir; 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); our @ISA = qw(File::Listing); # A place to remember current directory from last line parsed. our $curdir; 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; our @ISA = qw(File::Listing); package File::Listing::netware; our @ISA = qw(File::Listing); package File::Listing::apache; our @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)); my $filetype = ($filename =~ s|/$|| ? "d" : "f"); return [$filename, $filetype, $filesize, $filetime, undef]; } # the default listing doesn't include timestamps or file sizes # but we don't want to grab navigation links, so we ignore links # that have a non-trailing slash / character or ? elsif(m!.*!i) { my $filename = $1; my $filetype = ($filename =~ s|/$|| ? "d" : "f"); return [$filename, $filetype, undef, undef, undef]; } return (); } sub _guess_year { my $y = shift; # if the year is already four digit then we shouldn't do # anything to modify it. if ($y >= 1900) { # do nothing # TODO: for hysterical er historical reasons we assume 9x is in the # 1990s we should probably not do that, but I don't have any examples # where apache provides two digit dates so I am leaving this as-is # for now. Possibly the right thing is to not handle two digit years. } elsif ($y >= 90) { $y = 1900+$y; } # TODO: likewise assuming 00-89 are 20xx is long term probably wrong. 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__ =pod =encoding UTF-8 =head1 NAME File::Listing - Parse directory listing =head1 VERSION version 6.14 =head1 SYNOPSIS use File::Listing qw(parse_dir); $ENV{LANG} = "C"; # dates in non-English locales not supported foreach my $file (parse_dir(`ls -l`)) { my ($name, $type, $size, $mtime, $mode) = @$file; next if $type ne 'f'; # plain file #... } # directory listing can also be read from a file open my $listing, "zcat ls-lR.gz|"; $dir = parse_dir($listing, '+0000'); =head1 DESCRIPTION This module exports a single function called C, which can be used to parse directory listings. =head1 FUNCTIONS =head2 parse_dir my $dir = parse_dir( $listing ); my $dir = parse_dir( $listing, $time_zone ); my $dir = parse_dir( $listing, $time_zone, $type ); my $dir = parse_dir( $listing, $time_zone, $type, $error ); my @files = parse_dir( $listing ); my @files = parse_dir( $listing, $time_zone ); my @files = parse_dir( $listing, $time_zone, $type ); my @files = parse_dir( $listing, $time_zone, $type, $error ); The first parameter (C<$listing>) 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 (C<$time_zone>) 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 (C<$type>) is the type of listing to assume. Currently supported formats are C<'unix'>, C<'apache'> and C<'dosftp'>. The default value is C<'unix'>. Ideally, the listing type should be determined automatically. The fourth parameter (C<$error>) specifies how unparseable lines should be treated. Values can be C<'ignore'>, C<'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 C<'ignore'>. Only the first parameter is mandatory. # list context foreach my $file (parse_dir($listing)) { my($name, $type, $size, $mtime, $mode) = @$file; } # scalar context my $dir = parse_dir($listing); foreach my $file (@$dir) { my($name, $type, $size, $mtime, $mode) = @$file; } 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: =over 4 =item name The name of the file. =item type One of: C file, C directory, C symlink, C unknown. =item size The size of the file. =item time The number of seconds since January 1, 1970. =item mode Bitmask a la the mode returned by C. =back =head1 SEE ALSO =over 4 =item L Provides the same interface but uses XS and the parser implementation from C. =back =head1 AUTHOR Original author: Gisle Aas Current maintainer: Graham Ollis Eplicease@cpan.orgE Contributors: Adam Kennedy Adam Sjogren Alex Kapranoff Alexey Tourbin Andreas J. Koenig Bill Mann Bron Gondwana DAVIDRW Daniel Hedlund David E. Wheeler David Steinbrunner Erik Esterer FWILES Father Chrysostomos Gavin Peters Graeme Thompson Hans-H. Froehlich Ian Kilgore Jacob J Mark Stosberg Mike Schilli Ondrej Hanak Peter John Acklam Peter Rabbitson Robert Stone Rolf Grossmann Sean M. Burke Simon Legner Slaven Rezic Spiros Denaxas Steve Hay Todd Lipcon Tom Hukins Tony Finch Toru Yamaguchi Ville Skyttä Yuri Karaban Zefram amire80 jefflee john9art mschilli murphy phrstbrn ruff sasao uid39246 =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1996-2020 by Gisle Aas. 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 Basename.pm000064400000025672000000000000006572 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 stat.pm000064400000024076000000000000006027 0ustar00package File::stat; use 5.006; use strict; use warnings; use warnings::register; use Carp; use constant _IS_CYGWIN => $^O eq "cygwin"; BEGIN { *warnif = \&warnings::warnif } our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); our $VERSION = '1.09'; our @fields; our ( $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 ); 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 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 (_IS_CYGWIN ? _ingroup(544, $eff) : ($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 Copy.pm000064400000037552000000000000005771 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 }; # We want HiRes stat and utime if available BEGIN { eval q{ use Time::HiRes qw( stat utime ) } }; our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); sub copy; sub syscopy; sub cp; sub mv; $VERSION = '2.35'; 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 '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 implementation, 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 Path.pm000064400000124366000000000000005753 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.18'; $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.18 - released November 4 2020. =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-2020. 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 Temp.pm000064400000001656000000000000005760 0ustar00# this is a back compatibility wrapper around File::Temp. DO NOT # use this package outside of CGI, i won't provide any help if # you use it directly and your code breaks horribly. package CGI::File::Temp; $CGI::File::Temp::VERSION = '4.54'; use parent File::Temp; use parent Fh; my $appease_cpants_kwalitee = q/ use strict; use warnings; #/; use overload '""' => \&asString, 'cmp' => \&compare, 'fallback'=>1; # back compatibility method since we now return a File::Temp object # as the filehandle (which isa IO::Handle) so calling ->handle on # it will fail. FIXME: deprecate this method in v5+ sub handle { return shift; }; sub compare { my ( $self,$value ) = @_; return "$self" cmp $value; } sub _mp_filename { my ( $self,$filename ) = @_; ${*$self}->{ _mp_filename } = $filename if $filename; return ${*$self}->{_mp_filename}; } sub asString { my ( $self ) = @_; return $self->_mp_filename; } 1; Find.pm000064400000100503000000000000005722 0ustar00package File::Find; use 5.006; use strict; use warnings; use warnings::register; our $VERSION = '1.37'; require Exporter; require Cwd; our @ISA = qw(Exporter); our @EXPORT = qw(find finddepth); use strict; my $Is_VMS = $^O eq 'VMS'; my $Is_Win32 = $^O eq 'MSWin32'; 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./]+)$|; # 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; # 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 0 if you are sure the filesystem you are scanning reflects the number of subdirectories in the parent directory's C count. If you do set C<$File::Find::dont_use_nlink> to 0, you may notice an improvement in speed at the risk of not recursing into subdirectories if a filesystem doesn't populate C as expected. C<$File::Find::dont_use_nlink> now defaults to 1 on all platforms. =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 GlobMapper.pm000064400000036503000000000000007102 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 ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); $noPreBS = '(? '([^/]*)', '?' => '([^/])', '.' => '\.', '[' => '([', '(' => '(', ')' => ')', ); %wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; sub globmap ($$;) { my $inputGlob = shift ; my $outputGlob = shift ; my $obj = File::GlobMapper->new($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 = '(?{OutputGlob}' => '$string'\n"; $self->{OutputPattern} = $string ; return 1 ; } sub _getFiles { my $self = shift ; my %outInMapping = (); my %inFiles = () ; foreach my $inFile (@{ $self->{InputFiles} }) { next if $inFiles{$inFile} ++ ; my $outFile = $inFile ; if ( $inFile =~ m/$self->{InputPattern}/ ) { no warnings 'uninitialized'; eval "\$outFile = $self->{OutputPattern};" ; if (defined $outInMapping{$outFile}) { $Error = "multiple input files map to one output file"; return undef ; } $outInMapping{$outFile} = $inFile; push @{ $self->{Pairs} }, [$inFile, $outFile]; } } return 1 ; } sub getFileMap { my $self = shift ; return $self->{Pairs} ; } sub getHash { my $self = shift ; return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; } 1; __END__ =head1 NAME File::GlobMapper - Extend File Glob to Allow Input and Output Files =head1 SYNOPSIS use File::GlobMapper qw( globmap ); my $aref = globmap $input => $output or die $File::GlobMapper::Error ; my $gm = File::GlobMapper->new( $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. Fetch.pm000064400000134171000000000000006103 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 = '1.00'; $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; ### 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'; } ### Fix CVE-2016-1238 ### local $Module::Load::Conditional::FORCE_SAFE_INC = 1; 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', }; ### Fix CVE-2016-1238 ### local $Module::Load::Conditional::FORCE_SAFE_INC = 1; 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', }; ### Fix CVE-2016-1238 ### local $Module::Load::Conditional::FORCE_SAFE_INC = 1; 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', }; ### Fix CVE-2016-1238 ### local $Module::Load::Conditional::FORCE_SAFE_INC = 1; 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 }; ### Fix CVE-2016-1238 ### local $Module::Load::Conditional::FORCE_SAFE_INC = 1; 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: Compare.pm000064400000010354000000000000006434 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 Find/Rule.pm000064400000050274000000000000006642 0ustar00# $Id$ package File::Find::Rule; use strict; use File::Spec; use Text::Glob 'glob_to_regex'; use Number::Compare; use Carp qw/croak/; use File::Find (); # we're only wrapping for now our $VERSION = '0.34'; # we'd just inherit from Exporter, but I want the colon sub import { my $pkg = shift; my $to = caller; for my $sym ( qw( find rule ) ) { no strict 'refs'; *{"$to\::$sym"} = \&{$sym}; } for (grep /^:/, @_) { my ($extension) = /^:(.*)/; eval "require File::Find::Rule::$extension"; croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@; } } =head1 NAME File::Find::Rule - Alternative interface to File::Find =head1 SYNOPSIS use File::Find::Rule; # find all the subdirectories of a given directory my @subdirs = File::Find::Rule->directory->in( $directory ); # find all the .pm files in @INC my @files = File::Find::Rule->file() ->name( '*.pm' ) ->in( @INC ); # as above, but without method chaining my $rule = File::Find::Rule->new; $rule->file; $rule->name( '*.pm' ); my @files = $rule->in( @INC ); =head1 DESCRIPTION File::Find::Rule is a friendlier interface to File::Find. It allows you to build rules which specify the desired files and directories. =cut # the procedural shim *rule = \&find; sub find { my $object = __PACKAGE__->new(); my $not = 0; while (@_) { my $method = shift; my @args; if ($method =~ s/^\!//) { # jinkies, we're really negating this unshift @_, $method; $not = 1; next; } unless (defined prototype $method) { my $args = shift; @args = ref $args eq 'ARRAY' ? @$args : $args; } if ($not) { $not = 0; @args = $object->new->$method(@args); $method = "not"; } my @return = $object->$method(@args); return @return if $method eq 'in'; } $object; } =head1 METHODS =over =item C A constructor. You need not invoke C manually unless you wish to, as each of the rule-making methods will auto-create a suitable object if called as class methods. =cut sub new { my $referent = shift; my $class = ref $referent || $referent; bless { rules => [], subs => {}, iterator => [], extras => {}, maxdepth => undef, mindepth => undef, }, $class; } sub _force_object { my $object = shift; $object = $object->new() unless ref $object; $object; } =back =head2 Matching Rules =over =item C Specifies names that should match. May be globs or regular expressions. $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex $set->name( 'foo.bar' ); # just things named foo.bar =cut sub _flatten { my @flat; while (@_) { my $item = shift; ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; } return @flat; } sub name { my $self = _force_object shift; my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); push @{ $self->{rules} }, { rule => 'name', code => join( ' || ', map { "m{$_}" } @names ), args => \@_, }; $self; } =item -X tests Synonyms are provided for each of the -X tests. See L for details. None of these methods take arguments. Test | Method Test | Method ------|------------- ------|---------------- -r | readable -R | r_readable -w | writeable -W | r_writeable -w | writable -W | r_writable -x | executable -X | r_executable -o | owned -O | r_owned | | -e | exists -f | file -z | empty -d | directory -s | nonempty -l | symlink | -p | fifo -u | setuid -S | socket -g | setgid -b | block -k | sticky -c | character | -t | tty -M | modified | -A | accessed -T | ascii -C | changed -B | binary Though some tests are fairly meaningless as binary flags (C, C, C), they have been included for completeness. # find nonempty files $rule->file, ->nonempty; =cut use vars qw( %X_tests ); %X_tests = ( -r => readable => -R => r_readable => -w => writeable => -W => r_writeable => -w => writable => -W => r_writable => -x => executable => -X => r_executable => -o => owned => -O => r_owned => -e => exists => -f => file => -z => empty => -d => directory => -s => nonempty => -l => symlink => => -p => fifo => -u => setuid => -S => socket => -g => setgid => -b => block => -k => sticky => -c => character => => -t => tty => -M => modified => -A => accessed => -T => ascii => -C => changed => -B => binary => ); for my $test (keys %X_tests) { my $sub = eval 'sub () { my $self = _force_object shift; push @{ $self->{rules} }, { code => "' . $test . ' \$_", rule => "'.$X_tests{$test}.'", }; $self; } '; no strict 'refs'; *{ $X_tests{$test} } = $sub; } =item stat tests The following C based methods are provided: C, C, C, C, C, C, C, C, C, C, C, C, and C. See L for details. Each of these can take a number of targets, which will follow L semantics. $rule->size( 7 ); # exactly 7 $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes $rule->size( ">=7" ) ->size( "<=90" ); # between 7 and 90, inclusive $rule->size( 7, 9, 42 ); # 7, 9 or 42 =cut use vars qw( @stat_tests ); @stat_tests = qw( dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks ); { my $i = 0; for my $test (@stat_tests) { my $index = $i++; # to close over my $sub = sub { my $self = _force_object shift; my @tests = map { Number::Compare->parse_to_perl($_) } @_; push @{ $self->{rules} }, { rule => $test, args => \@_, code => 'do { my $val = (stat $_)['.$index.'] || 0;'. join ('||', map { "(\$val $_)" } @tests ).' }', }; $self; }; no strict 'refs'; *$test = $sub; } } =item C =item C Allows shortcircuiting boolean evaluation as an alternative to the default and-like nature of combined rules. C and C are interchangeable. # find avis, movs, things over 200M and empty files $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ), File::Find::Rule->size( '>200M' ), File::Find::Rule->file->empty, ); =cut sub any { my $self = _force_object shift; # compile all the subrules to code fragments push @{ $self->{rules} }, { rule => "any", code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')', args => \@_, }; # merge all the subs hashes of the kids into ourself %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; $self; } *or = \&any; =item C =item C Negates a rule. (The inverse of C.) C and C are interchangeable. # files that aren't 8.3 safe $rule->file ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); =cut sub not { my $self = _force_object shift; push @{ $self->{rules} }, { rule => 'not', args => \@_, code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")", }; # merge all the subs hashes into us %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; $self; } *none = \¬ =item C Traverse no further. This rule always matches. =cut sub prune () { my $self = _force_object shift; push @{ $self->{rules} }, { rule => 'prune', code => '$File::Find::prune = 1' }; $self; } =item C Don't keep this file. This rule always matches. =cut sub discard () { my $self = _force_object shift; push @{ $self->{rules} }, { rule => 'discard', code => '$discarded = 1', }; $self; } =item C Allows user-defined rules. Your subroutine will be invoked with C<$_> set to the current short name, and with parameters of the name, the path you're in, and the full relative filename. Return a true value if your rule matched. # get things with long names $rules->exec( sub { length > 20 } ); =cut sub exec { my $self = _force_object shift; my $code = shift; push @{ $self->{rules} }, { rule => 'exec', code => $code, }; $self; } =item C Opens a file and tests it each line at a time. For each line it evaluates each of the specifiers, stopping at the first successful match. A specifier may be a regular expression or a subroutine. The subroutine will be invoked with the same parameters as an ->exec subroutine. It is possible to provide a set of negative specifiers by enclosing them in anonymous arrays. Should a negative specifier match the iteration is aborted and the clause is failed. For example: $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); Is a passing clause if the first line of a file looks like a perl shebang line. =cut sub grep { my $self = _force_object shift; my @pattern = map { ref $_ ? ref $_ eq 'ARRAY' ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ : [ $_ => 1 ] : [ qr/$_/ => 1 ] } @_; $self->exec( sub { local *FILE; open FILE, $_ or return; local ($_, $.); while () { for my $p (@pattern) { my ($rule, $ret) = @$p; return $ret if ref $rule eq 'Regexp' ? /$rule/ : $rule->(@_); } } return; } ); } =item C Descend at most C<$level> (a non-negative integer) levels of directories below the starting point. May be invoked many times per rule, but only the most recent value is used. =item C Do not apply any tests at levels less than C<$level> (a non-negative integer). =item C Specifies extra values to pass through to C as part of the options hash. For example this allows you to specify following of symlinks like so: my $rule = File::Find::Rule->extras({ follow => 1 }); May be invoked many times per rule, but only the most recent value is used. =cut for my $setter (qw( maxdepth mindepth extras )) { my $sub = sub { my $self = _force_object shift; $self->{$setter} = shift; $self; }; no strict 'refs'; *$setter = $sub; } =item C Trim the leading portion of any path found =cut sub relative () { my $self = _force_object shift; $self->{relative} = 1; $self; } =item C Normalize paths found using Ccanonpath>. This will return paths with a file-seperator that is native to your OS (as determined by L), instead of the default C. For example, this will return C on Unix-ish OSes and C on Win32. =cut sub canonpath () { my $self = _force_object shift; $self->{canonpath} = 1; $self; } =item C Negated version of the rule. An effective shortand related to ! in the procedural interface. $foo->not_name('*.pl'); $foo->not( $foo->new->name('*.pl' ) ); =cut sub DESTROY {} sub AUTOLOAD { our $AUTOLOAD; $AUTOLOAD =~ /::not_([^:]*)$/ or croak "Can't locate method $AUTOLOAD"; my $method = $1; my $sub = sub { my $self = _force_object shift; $self->not( $self->new->$method(@_) ); }; { no strict 'refs'; *$AUTOLOAD = $sub; } &$sub; } =back =head2 Query Methods =over =item C Evaluates the rule, returns a list of paths to matching files and directories. =cut sub in { my $self = _force_object shift; my @found; my $fragment = $self->_compile; my %subs = %{ $self->{subs} }; warn "relative mode handed multiple paths - that's a bit silly\n" if $self->{relative} && @_ > 1; my $topdir; my $code = 'sub { (my $path = $File::Find::name) =~ s#^(?:\./+)+##; $path = "." if ($path eq ""); # See Debian bug #329377 my @args = ($_, $File::Find::dir, $path); my $maxdepth = $self->{maxdepth}; my $mindepth = $self->{mindepth}; my $relative = $self->{relative}; my $canonpath = $self->{canonpath}; # figure out the relative path and depth my $relpath = $File::Find::name; $relpath =~ s{^\Q$topdir\E/?}{}; my $depth = scalar File::Spec->splitdir($relpath); #print "name: \'$File::Find::name\' "; #print "relpath: \'$relpath\' depth: $depth relative: $relative\n"; defined $maxdepth && $depth >= $maxdepth and $File::Find::prune = 1; defined $mindepth && $depth < $mindepth and return; #print "Testing \'$_\'\n"; my $discarded; return unless ' . $fragment . '; return if $discarded; if ($relative) { if ($relpath ne "") { push @found, $canonpath ? File::Spec->canonpath($relpath) : $relpath; } } else { push @found, $canonpath ? File::Spec->canonpath($path) : $path; } }'; #use Data::Dumper; #print Dumper \%subs; #warn "Compiled sub: '$code'\n"; my $sub = eval "$code" or die "compile error '$code' $@"; for my $path (@_) { # $topdir is used for relative and maxdepth $topdir = $path; # slice off the trailing slash if there is one (the # maxdepth/mindepth code is fussy) $topdir =~ s{/?$}{} unless $topdir eq '/'; $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path ); } return @found; } sub _call_find { my $self = shift; File::Find::find( @_ ); } sub _compile { my $self = shift; return '1' unless @{ $self->{rules} }; my $code = join " && ", map { if (ref $_->{code}) { my $key = "$_->{code}"; $self->{subs}{$key} = $_->{code}; "\$subs{'$key'}->(\@args) # $_->{rule}\n"; } else { "( $_->{code} ) # $_->{rule}\n"; } } @{ $self->{rules} }; #warn $code; return $code; } =item C Starts a find across the specified directories. Matching items may then be queried using L. This allows you to use a rule as an iterator. my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" ); while ( defined ( my $image = $rule->match ) ) { ... } =cut sub start { my $self = _force_object shift; $self->{iterator} = [ $self->in( @_ ) ]; $self; } =item C Returns the next file which matches, false if there are no more. =cut sub match { my $self = _force_object shift; return shift @{ $self->{iterator} }; } 1; __END__ =back =head2 Extensions Extension modules are available from CPAN in the File::Find::Rule namespace. In order to use these extensions either use them directly: use File::Find::Rule::ImageSize; use File::Find::Rule::MMagic; # now your rules can use the clauses supplied by the ImageSize and # MMagic extension or, specify that File::Find::Rule should load them for you: use File::Find::Rule qw( :ImageSize :MMagic ); For notes on implementing your own extensions, consult L =head2 Further examples =over =item Finding perl scripts my $finder = File::Find::Rule->or ( File::Find::Rule->name( '*.pl' ), File::Find::Rule->exec( sub { if (open my $fh, $_) { my $shebang = <$fh>; close $fh; return $shebang =~ /^#!.*\bperl/; } return 0; } ), ); Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 =item ignore CVS directories my $rule = File::Find::Rule->new; $rule->or($rule->new ->directory ->name('CVS') ->prune ->discard, $rule->new); Note here the use of a null rule. Null rules match anything they see, so the effect is to match (and discard) directories called 'CVS' or to match anything. =back =head1 TWO FOR THE PRICE OF ONE File::Find::Rule also gives you a procedural interface. This is documented in L =head1 EXPORTS L, L =head1 TAINT MODE INTERACTION As of 0.32 File::Find::Rule doesn't capture the current working directory in a taint-unsafe manner. File::Find itself still does operations that the taint system will flag as insecure but you can use the L feature to ask L to internally C file paths with a regex like so: my $rule = File::Find::Rule->extras({ untaint => 1 }); Please consult L's documentation for C, C, and C for more information. =head1 BUGS The code makes use of the C keyword and as such requires perl version 5.6.0 or newer. Currently it isn't possible to remove a clause from a rule object. If this becomes a significant issue it will be addressed. =head1 AUTHOR Richard Clamp with input gained from this use.perl discussion: http://use.perl.org/~richardc/journal/6467 Additional proofreading and input provided by Kake, Greg McCarroll, and Andy Lester andy@petdance.com. =head1 COPYRIGHT Copyright (C) 2002, 2003, 2004, 2006, 2009, 2011 Richard Clamp. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, find(1) If you want to know about the procedural interface, see L, and if you have an idea for a neat extension L =cut Implementation notes: $self->rules is an array of hashrefs. it may be a code fragment or a call to a subroutine. Anonymous subroutines are stored in the $self->subs hashref keyed on the stringfied version of the coderef. When one File::Find::Rule object is combined with another, such as in the any and not operations, this entire hash is merged. The _compile method walks the rules element and simply glues the code fragments together so they can be compiled into an anyonymous File::Find match sub for speed [*] There's probably a win to be made with the current model in making stat calls use C<_>. For find( file => size => "> 20M" => size => "< 400M" ); up to 3 stats will happen for each candidate. Adding a priming _ would be a bit blind if the first operation was C< name => 'foo' >, since that can be tested by a single regex. Simply checking what the next type of operation doesn't work since any arbritary exec sub may or may not stat. Potentially worse, they could stat something else like so: # extract from the worlds stupidest make(1) find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } ); Maybe the best way is to treat C<_> as invalid after calling an exec, and doc that C<_> will only be meaningful after stat and -X tests if they're wanted in exec blocks. Session.pm000064400000004251000000000000006470 0ustar00package TAP::Formatter::File::Session; use strict; use warnings; use base 'TAP::Formatter::Session'; =head1 NAME TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION Version 3.43 =cut our $VERSION = '3.43'; =head1 DESCRIPTION This provides file orientated output formatting for L. It is particularly important when running with parallel tests, as it ensures that test results are not interleaved, even when run verbosely. =cut =head1 METHODS =head2 result Stores results for later output, all together. =cut sub result { my $self = shift; my $result = shift; my $parser = $self->parser; my $formatter = $self->formatter; if ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); return; } if (!$formatter->quiet && ( $formatter->verbose || ( $result->is_test && $formatter->failures && !$result->is_ok ) || ( $formatter->comments && $result->is_comment ) || ( $result->has_directive && $formatter->directives ) ) ) { $self->{results} .= $self->_format_for_output($result) . "\n"; } } =head2 close_test When the test file finishes, outputs the summary, together. =cut sub close_test { my $self = shift; # Avoid circular references $self->parser(undef); my $parser = $self->parser; my $formatter = $self->formatter; my $pretty = $formatter->_format_name( $self->name ); return if $formatter->really_quiet; if ( my $skip_all = $parser->skip_all ) { $formatter->_output( $pretty . "skipped: $skip_all\n" ); } elsif ( $parser->has_problems ) { $formatter->_output( $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) ); $self->_output_test_failure($parser); } else { my $time_report = $self->time_report($formatter, $parser); $formatter->_output( $pretty . ( $self->{results} ? "\n" . $self->{results} : "" ) . $self->_make_ok_line($time_report) ); } } 1; var/lib/dpkg/triggers/File000064400000002646000000000000011430 0ustar00/usr/share/debianutils/shells.d debianutils/noawait /usr/share/mime/packages shared-mime-info/noawait /etc/dbus-1/system.d dbus/noawait /usr/share/dbus-1/system.d dbus/noawait /usr/share/dbus-1/system-services dbus/noawait /etc/rsyslog.d rsyslog/noawait /usr/share/info install-info/noawait /usr/man man-db/noawait /usr/share/man man-db/noawait /usr/local/man man-db/noawait /usr/local/share/man man-db/noawait /usr/X11R6/man man-db/noawait /opt/man man-db/noawait /etc/lsb-release plymouth-theme-ubuntu-text/noawait /etc/ufw/applications.d ufw/noawait /lib/firmware/amd-ucode microcode-initrd/noawait /lib/firmware/intel-ucode microcode-initrd/noawait /usr/share/package-data-downloads update-notifier-common/noawait /usr/lib/mime/packages mailcap/noawait /usr/share/applications mailcap/noawait /etc/php/7.4/cli/conf.d php7.4-cli/noawait /etc/php/7.4/apache2/conf.d libapache2-mod-php7.4/noawait /etc/php/8.2/apache2/conf.d libapache2-mod-php8.2/noawait /etc/php/8.2/cli/conf.d php8.2-cli/noawait /usr/lib/x86_64-linux-gnu/gio/modules libglib2.0-0:amd64/noawait /usr/share/glib-2.0/schemas libglib2.0-0:amd64 /etc/php/8.3/apache2/conf.d libapache2-mod-php8.3/noawait /etc/php/8.3/cli/conf.d php8.3-cli/noawait /usr/lib/systemd/catalog systemd/noawait /lib/udev/hwdb.d udev/noawait /usr/lib/gdk-pixbuf-2.0/2.10.0/loaders libgdk-pixbuf-2.0-0:amd64/noawait /usr/lib/x86_64-linux-gnu/gdk-pixbuf-2.0/2.10.0/loaders libgdk-pixbuf-2.0-0:amd64/noawait DosGlob.pm000064400000017472000000000000006407 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 Spec/Unix.pm000064400000037021000000000000006663 0ustar00package File::Spec::Unix; use strict; use Cwd (); our $VERSION = '3.80'; $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.pm000064400000015156000000000000006350 0ustar00package File::Spec::OS2; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.80'; $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 Spec/Win32.pm000064400000025016000000000000006643 0ustar00package File::Spec::Win32; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.80'; $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 L 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; # 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/Epoc.pm000064400000003043000000000000006623 0ustar00package File::Spec::Epoc; use strict; our $VERSION = '3.80'; $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/AmigaOS.pm000064400000001726000000000000007223 0ustar00package File::Spec::AmigaOS; use strict; require File::Spec::Unix; our $VERSION = '3.80'; $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.pm000064400000004454000000000000007714 0ustar00package File::Spec::Functions; use File::Spec; use strict; our $VERSION = '3.80'; $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/Mac.pm000064400000053402000000000000006441 0ustar00package File::Spec::Mac; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.80'; $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/VMS.pm000064400000037706000000000000006417 0ustar00package File::Spec::VMS; use strict; use Cwd (); require File::Spec::Unix; our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); use File::Basename; use VMS::Filespec; =head1 NAME File::Spec::VMS - methods for VMS file specs =head1 SYNOPSIS require File::Spec::VMS; # Done internally by File::Spec if needed =head1 DESCRIPTION See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. The default behavior is to allow either VMS or Unix syntax on input and to return VMS syntax on output unless Unix syntax has been explicitly requested via the C CRTL feature. =over 4 =cut # Need to look up the feature settings. The preferred way is to use the # VMS::Feature module, but that may not be available to dual life modules. my $use_feature; BEGIN { if (eval { local $SIG{__DIE__}; local @INC = @INC; pop @INC if $INC[-1] eq '.'; require VMS::Feature; }) { $use_feature = 1; } } # Need to look up the UNIX report mode. This may become a dynamic mode # in the future. sub _unix_rpt { my $unix_rpt; if ($use_feature) { $unix_rpt = VMS::Feature::current("filename_unix_report"); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; } return $unix_rpt; } =item canonpath (override) Removes redundant portions of file specifications and returns results in native syntax unless Unix filename reporting has been enabled. =cut sub canonpath { my($self,$path) = @_; return undef unless defined $path; my $unix_rpt = $self->_unix_rpt; if ($path =~ m|/|) { my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); return $path if $unix_rpt; $path = $pathify ? vmspath($path) : vmsify($path); } $path =~ s/(? ==> [ and ] $path =~ s/(?/]/; $path =~ s/(? .][ $path =~ s/(? [ $path =~ s/(? [ $path =~ s/(? ] $path =~ s/(? foo.bar 1 while ($path =~ s/(? .--. # [-.-. ==> [--. # .-.-] ==> .--] # [-.-] ==> [--] 1 while ($path =~ s/(? .-. # .foo.--] ==> .-] # [foo.--. ==> [-. # [foo.--] ==> [-] # # And then, the remaining cases $path =~ s/(? [- $path =~ s/(? . $path =~ s/(? [ $path =~ s/(? ] # [foo.-] ==> [000000] $path =~ s/(? $path =~ s/(?_unix_rpt; my @dirs = grep {defined() && length()} @_; my $rslt; if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; if ($unix_rpt) { $spath = unixify($spath) unless $spath =~ m#/#; $sdir= unixify($sdir) unless $sdir =~ m#/#; return $self->SUPER::catdir($spath, $sdir) } $rslt = vmspath( unixify($spath) . '/' . unixify($sdir)); # Special case for VMS absolute directory specs: these will have # had device prepended during trip through Unix syntax in # eliminate_macros(), since Unix syntax has no way to express # "absolute from the top of this device's directory tree". if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } } else { # Single directory. Return an empty string on null input; otherwise # just return a canonical path. if (not defined $dir or not length $dir) { $rslt = ''; } else { $rslt = $unix_rpt ? $dir : vmspath($dir); } } return $self->canonpath($rslt); } =item catfile (override) Concatenates a list of directory specifications with a filename specification to build a path. =cut sub catfile { my $self = shift; my $tfile = pop(); my $file = $self->canonpath($tfile); my @files = grep {defined() && length()} @_; my $unix_rpt = $self->_unix_rpt; my $rslt; if (@files) { my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); my $spath = $path; # Something building a VMS path in pieces may try to pass a # directory name in filename format, so normalize it. $spath =~ s/\.dir\Z(?!\n)//i; # If the spath ends with a directory delimiter and the file is bare, # then just concatenate them. if ($spath =~ /^(?]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; } else { $rslt = unixify($spath); $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); $rslt = vmsify($rslt) unless $unix_rpt; } } else { # Only passed a single file? my $xfile = (defined($file) && length($file)) ? $file : ''; $rslt = $unix_rpt ? $xfile : vmsify($xfile); } return $self->canonpath($rslt) unless $unix_rpt; # In Unix report mode, do not strip off redundant path information. return $rslt; } =item curdir (override) Returns a string representation of the current directory: '[]' or '.' =cut sub curdir { my $self = shift @_; return '.' if ($self->_unix_rpt); return '[]'; } =item devnull (override) Returns a string representation of the null device: '_NLA0:' or '/dev/null' =cut sub devnull { my $self = shift @_; return '/dev/null' if ($self->_unix_rpt); return "_NLA0:"; } =item rootdir (override) Returns a string representation of the root directory: 'SYS$DISK:[000000]' or '/' =cut sub rootdir { my $self = shift @_; if ($self->_unix_rpt) { # Root may exist, try it first. my $try = '/'; my ($dev1, $ino1) = stat('/'); my ($dev2, $ino2) = stat('.'); # Perl falls back to '.' if it can not determine '/' if (($dev1 != $dev2) || ($ino1 != $ino2)) { return $try; } # Fall back to UNIX format sys$disk. return '/sys$disk/'; } return 'SYS$DISK:[000000]'; } =item tmpdir (override) Returns a string representation of the first writable directory from the following list or '' if none are writable: /tmp if C is enabled. sys$scratch: $ENV{TMPDIR} If running under taint mode, and if $ENV{TMPDIR} is tainted, it is not used. =cut sub tmpdir { my $self = shift @_; my $tmpdir = $self->_cached_tmpdir('TMPDIR'); return $tmpdir if defined $tmpdir; if ($self->_unix_rpt) { $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); } else { $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); } $self->_cache_tmpdir($tmpdir, 'TMPDIR'); } =item updir (override) Returns a string representation of the parent directory: '[-]' or '..' =cut sub updir { my $self = shift @_; return '..' if ($self->_unix_rpt); return '[-]'; } =item case_tolerant (override) VMS file specification syntax is case-tolerant. =cut sub case_tolerant { return 1; } =item path (override) Translate logical name DCL$PATH as a searchlist, rather than trying to C string value of C<$ENV{'PATH'}>. =cut sub path { my (@dirs,$dir,$i); while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } return @dirs; } =item file_name_is_absolute (override) Checks for VMS directory spec as well as Unix separators. =cut sub file_name_is_absolute { my ($self,$file) = @_; # If it's a logical name, expand it. $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; return scalar($file =~ m!^/!s || $file =~ m![<\[][^.\-\]>]! || $file =~ /^[A-Za-z0-9_\$\-\~]+(?splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); Passing a true value for C<$no_file> indicates that the path being split only contains directory components, even on systems where you can usually (when not supporting a foreign syntax) tell the difference between directories and files at a glance. =cut sub splitpath { my($self,$path, $nofile) = @_; my($dev,$dir,$file) = ('','',''); my $vmsify_path = vmsify($path); if ( $nofile ) { #vmsify('d1/d2/d3') returns '[.d1.d2]d3' #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' if( $vmsify_path =~ /(.*)\](.+)/ ){ $vmsify_path = $1.'.'.$2.']'; } $vmsify_path =~ /(.+:)?(.*)/s; $dir = defined $2 ? $2 : ''; # dir can be '0' return ($1 || '',$dir,$file); } else { $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; return ($1 || '',$2 || '',$3); } } =item splitdir (override) Split a directory specification into the components. =cut sub splitdir { my($self,$dirspec) = @_; my @dirs = (); return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); $dirspec =~ s/(? ==> [ and ] $dirspec =~ s/(?/]/; $dirspec =~ s/(? .][ $dirspec =~ s/(? [ $dirspec =~ s/(? [ $dirspec =~ s/(? ] $dirspec =~ s/(? foo.bar while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} # That loop does the following # with any amount of dashes: # .--. ==> .-.-. # [--. ==> [-.-. # .--] ==> .-.-] # [--] ==> [-.-] $dirspec = "[$dirspec]" unless $dirspec =~ /(?]\Z(?!\n)//s; @dirs; } =item catpath (override) Construct a complete filespec. =cut sub catpath { my($self,$dev,$dir,$file) = @_; # We look for a volume in $dev, then in $dir, but not both my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); $dev = $dir_volume unless length $dev; $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; if ($dev =~ m|^(?'); "$dev$dir$file"; } =item abs2rel (override) Attempt to convert an absolute file specification to a relative specification. =cut sub abs2rel { my $self = shift; my($path,$base) = @_; $base = Cwd::getcwd() unless defined $base and length $base; # If there is no device or directory syntax on $base, make sure it # is treated as a directory. $base = vmspath($base) unless $base =~ m{(?rel2abs($_) } # Are we even starting $path on the same (node::)device as $base? Note that # logical paths or nodename differences may be on the "same device" # but the comparison that ignores device differences so as to concatenate # [---] up directory specs is not even a good idea in cases where there is # a logical path difference between $path and $base nodename and/or device. # Hence we fall back to returning the absolute $path spec # if there is a case blind device (or node) difference of any sort # and we do not even try to call $parse() or consult %ENV for $trnlnm() # (this module needs to run on non VMS platforms after all). my ($path_volume, $path_directories, $path_file) = $self->splitpath($path); my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume); # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); my $pathchunks = @pathchunks; unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; my @basechunks = $self->splitdir( $base_directories ); my $basechunks = @basechunks; unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; while ( @pathchunks && @basechunks && lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) { shift @pathchunks ; shift @basechunks ; } # @basechunks now contains the directories to climb out of, # @pathchunks now has the directories to descend in to. if ((@basechunks > 0) || ($basechunks != $pathchunks)) { $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; } else { $path_directories = join '.', @pathchunks; } $path_directories = '['.$path_directories.']'; return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; } =item rel2abs (override) Return an absolute file specification from a relative one. =cut sub rel2abs { my $self = shift ; my ($path,$base ) = @_; return undef unless defined $path; if ($path =~ m/\//) { $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about ? vmspath($path) # whether it's a directory : vmsify($path) ); } $base = vmspath($base) if defined $base && $base =~ m/\//; # Clean up and split up $path if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; } else { $base = $self->canonpath( $base ) ; } # Split up paths my ( $path_directories, $path_file ) = ($self->splitpath( $path ))[1,2] ; my ( $base_volume, $base_directories ) = $self->splitpath( $base ) ; $path_directories = '' if $path_directories eq '[]' || $path_directories eq '<>'; my $sep = '' ; $sep = '.' if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && $path_directories =~ m{^[^.\[<]}s ) ; $base_directories = "$base_directories$sep$path_directories"; $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; $path = $self->catpath( $base_volume, $base_directories, $path_file ); } return $self->canonpath( $path ) ; } =back =head1 COPYRIGHT Copyright (c) 2004-14 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. An explanation of VMS file specs can be found at L. =cut 1; Spec/Cygwin.pm000064400000007032000000000000007177 0ustar00package File::Spec::Cygwin; use strict; require File::Spec::Unix; our $VERSION = '3.80'; $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.pm000064400000024513000000000000005742 0ustar00package File::Spec; use strict; our $VERSION = '3.80'; $VERSION =~ tr/_//d; my %module = ( MSWin32 => '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 Glob.pm000064400000030650000000000000005732 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 ) ], ); $EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}]; @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); $VERSION = '1.33'; 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(); } 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 Reader.php000077700000004067000000000000006436 0ustar00 */ public static function read(array $filePaths, bool $shortCircuit = true, ?string $fileEncoding = null) { $output = []; foreach ($filePaths as $filePath) { $content = self::readFromFile($filePath, $fileEncoding); if ($content->isDefined()) { $output[$filePath] = $content->get(); if ($shortCircuit) { break; } } } return $output; } /** * Read the given file. * * @param string $path * @param string|null $encoding * * @throws \Dotenv\Exception\InvalidEncodingException * * @return \PhpOption\Option */ private static function readFromFile(string $path, ?string $encoding = null) { /** @var Option */ $content = Option::fromValue(@\file_get_contents($path), false); return $content->flatMap(static function (string $content) use ($encoding) { return Str::utf8($content, $encoding)->mapError(static function (string $error) { throw new InvalidEncodingException($error); })->success(); }); } } Paths.php000077700000001354000000000000006307 0ustar00 * @copyright 2012 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File; use phpseclib3\Common\Functions\Strings; use phpseclib3\File\ASN1\Element; use phpseclib3\Math\BigInteger; /** * Pure-PHP ASN.1 Parser * * @author Jim Wigginton */ abstract class ASN1 { // Tag Classes // http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf#page=12 const CLASS_UNIVERSAL = 0; const CLASS_APPLICATION = 1; const CLASS_CONTEXT_SPECIFIC = 2; const CLASS_PRIVATE = 3; // Tag Classes // http://www.obj-sys.com/asn1tutorial/node124.html const TYPE_BOOLEAN = 1; const TYPE_INTEGER = 2; const TYPE_BIT_STRING = 3; const TYPE_OCTET_STRING = 4; const TYPE_NULL = 5; const TYPE_OBJECT_IDENTIFIER = 6; //const TYPE_OBJECT_DESCRIPTOR = 7; //const TYPE_INSTANCE_OF = 8; // EXTERNAL const TYPE_REAL = 9; const TYPE_ENUMERATED = 10; //const TYPE_EMBEDDED = 11; const TYPE_UTF8_STRING = 12; //const TYPE_RELATIVE_OID = 13; const TYPE_SEQUENCE = 16; // SEQUENCE OF const TYPE_SET = 17; // SET OF // More Tag Classes // http://www.obj-sys.com/asn1tutorial/node10.html const TYPE_NUMERIC_STRING = 18; const TYPE_PRINTABLE_STRING = 19; const TYPE_TELETEX_STRING = 20; // T61String const TYPE_VIDEOTEX_STRING = 21; const TYPE_IA5_STRING = 22; const TYPE_UTC_TIME = 23; const TYPE_GENERALIZED_TIME = 24; const TYPE_GRAPHIC_STRING = 25; const TYPE_VISIBLE_STRING = 26; // ISO646String const TYPE_GENERAL_STRING = 27; const TYPE_UNIVERSAL_STRING = 28; //const TYPE_CHARACTER_STRING = 29; const TYPE_BMP_STRING = 30; // Tag Aliases // These tags are kinda place holders for other tags. const TYPE_CHOICE = -1; const TYPE_ANY = -2; /** * ASN.1 object identifiers * * @var array * @link http://en.wikipedia.org/wiki/Object_identifier */ private static $oids = []; /** * ASN.1 object identifier reverse mapping * * @var array */ private static $reverseOIDs = []; /** * Default date format * * @var string * @link http://php.net/class.datetime */ private static $format = 'D, d M Y H:i:s O'; /** * Filters * * If the mapping type is self::TYPE_ANY what do we actually encode it as? * * @var array * @see self::encode_der() */ private static $filters; /** * Current Location of most recent ASN.1 encode process * * Useful for debug purposes * * @var array * @see self::encode_der() */ private static $location; /** * DER Encoded String * * In case we need to create ASN1\Element object's.. * * @var string * @see self::decodeDER() */ private static $encoded; /** * Type mapping table for the ANY type. * * Structured or unknown types are mapped to a \phpseclib3\File\ASN1\Element. * Unambiguous types get the direct mapping (int/real/bool). * Others are mapped as a choice, with an extra indexing level. * * @var array */ const ANY_MAP = [ self::TYPE_BOOLEAN => true, self::TYPE_INTEGER => true, self::TYPE_BIT_STRING => 'bitString', self::TYPE_OCTET_STRING => 'octetString', self::TYPE_NULL => 'null', self::TYPE_OBJECT_IDENTIFIER => 'objectIdentifier', self::TYPE_REAL => true, self::TYPE_ENUMERATED => 'enumerated', self::TYPE_UTF8_STRING => 'utf8String', self::TYPE_NUMERIC_STRING => 'numericString', self::TYPE_PRINTABLE_STRING => 'printableString', self::TYPE_TELETEX_STRING => 'teletexString', self::TYPE_VIDEOTEX_STRING => 'videotexString', self::TYPE_IA5_STRING => 'ia5String', self::TYPE_UTC_TIME => 'utcTime', self::TYPE_GENERALIZED_TIME => 'generalTime', self::TYPE_GRAPHIC_STRING => 'graphicString', self::TYPE_VISIBLE_STRING => 'visibleString', self::TYPE_GENERAL_STRING => 'generalString', self::TYPE_UNIVERSAL_STRING => 'universalString', //self::TYPE_CHARACTER_STRING => 'characterString', self::TYPE_BMP_STRING => 'bmpString' ]; /** * String type to character size mapping table. * * Non-convertable types are absent from this table. * size == 0 indicates variable length encoding. * * @var array */ const STRING_TYPE_SIZE = [ self::TYPE_UTF8_STRING => 0, self::TYPE_BMP_STRING => 2, self::TYPE_UNIVERSAL_STRING => 4, self::TYPE_PRINTABLE_STRING => 1, self::TYPE_TELETEX_STRING => 1, self::TYPE_IA5_STRING => 1, self::TYPE_VISIBLE_STRING => 1, ]; /** * Parse BER-encoding * * Serves a similar purpose to openssl's asn1parse * * @param Element|string $encoded * @return ?array */ public static function decodeBER($encoded) { if ($encoded instanceof Element) { $encoded = $encoded->element; } self::$encoded = $encoded; $decoded = self::decode_ber($encoded); if ($decoded === false) { return null; } return [$decoded]; } /** * Parse BER-encoding (Helper function) * * Sometimes we want to get the BER encoding of a particular tag. $start lets us do that without having to reencode. * $encoded is passed by reference for the recursive calls done for self::TYPE_BIT_STRING and * self::TYPE_OCTET_STRING. In those cases, the indefinite length is used. * * @param string $encoded * @param int $start * @param int $encoded_pos * @return array|bool */ private static function decode_ber($encoded, $start = 0, $encoded_pos = 0) { $current = ['start' => $start]; if (!isset($encoded[$encoded_pos])) { return false; } $type = ord($encoded[$encoded_pos++]); $startOffset = 1; $constructed = ($type >> 5) & 1; $tag = $type & 0x1F; if ($tag == 0x1F) { $tag = 0; // process septets (since the eighth bit is ignored, it's not an octet) do { if (!isset($encoded[$encoded_pos])) { return false; } $temp = ord($encoded[$encoded_pos++]); $startOffset++; $loop = $temp >> 7; $tag <<= 7; $temp &= 0x7F; // "bits 7 to 1 of the first subsequent octet shall not all be zero" if ($startOffset == 2 && $temp == 0) { return false; } $tag |= $temp; } while ($loop); } $start += $startOffset; // Length, as discussed in paragraph 8.1.3 of X.690-0207.pdf#page=13 if (!isset($encoded[$encoded_pos])) { return false; } $length = ord($encoded[$encoded_pos++]); $start++; if ($length == 0x80) { // indefinite length // "[A sender shall] use the indefinite form (see 8.1.3.6) if the encoding is constructed and is not all // immediately available." -- paragraph 8.1.3.2.c $length = strlen($encoded) - $encoded_pos; } elseif ($length & 0x80) { // definite length, long form // technically, the long form of the length can be represented by up to 126 octets (bytes), but we'll only // support it up to four. $length &= 0x7F; $temp = substr($encoded, $encoded_pos, $length); $encoded_pos += $length; // tags of indefinte length don't really have a header length; this length includes the tag $current += ['headerlength' => $length + 2]; $start += $length; extract(unpack('Nlength', substr(str_pad($temp, 4, chr(0), STR_PAD_LEFT), -4))); /** @var integer $length */ } else { $current += ['headerlength' => 2]; } if ($length > (strlen($encoded) - $encoded_pos)) { return false; } $content = substr($encoded, $encoded_pos, $length); $content_pos = 0; // at this point $length can be overwritten. it's only accurate for definite length things as is /* Class is UNIVERSAL, APPLICATION, PRIVATE, or CONTEXT-SPECIFIC. The UNIVERSAL class is restricted to the ASN.1 built-in types. It defines an application-independent data type that must be distinguishable from all other data types. The other three classes are user defined. The APPLICATION class distinguishes data types that have a wide, scattered use within a particular presentation context. PRIVATE distinguishes data types within a particular organization or country. CONTEXT-SPECIFIC distinguishes members of a sequence or set, the alternatives of a CHOICE, or universally tagged set members. Only the class number appears in braces for this data type; the term CONTEXT-SPECIFIC does not appear. -- http://www.obj-sys.com/asn1tutorial/node12.html */ $class = ($type >> 6) & 3; switch ($class) { case self::CLASS_APPLICATION: case self::CLASS_PRIVATE: case self::CLASS_CONTEXT_SPECIFIC: if (!$constructed) { return [ 'type' => $class, 'constant' => $tag, 'content' => $content, 'length' => $length + $start - $current['start'] ] + $current; } $newcontent = []; $remainingLength = $length; while ($remainingLength > 0) { $temp = self::decode_ber($content, $start, $content_pos); if ($temp === false) { break; } $length = $temp['length']; // end-of-content octets - see paragraph 8.1.5 if (substr($content, $content_pos + $length, 2) == "\0\0") { $length += 2; $start += $length; $newcontent[] = $temp; break; } $start += $length; $remainingLength -= $length; $newcontent[] = $temp; $content_pos += $length; } return [ 'type' => $class, 'constant' => $tag, // the array encapsulation is for BC with the old format 'content' => $newcontent, // the only time when $content['headerlength'] isn't defined is when the length is indefinite. // the absence of $content['headerlength'] is how we know if something is indefinite or not. // technically, it could be defined to be 2 and then another indicator could be used but whatever. 'length' => $start - $current['start'] ] + $current; } $current += ['type' => $tag]; // decode UNIVERSAL tags switch ($tag) { case self::TYPE_BOOLEAN: // "The contents octets shall consist of a single octet." -- paragraph 8.2.1 if ($constructed || strlen($content) != 1) { return false; } $current['content'] = (bool) ord($content[$content_pos]); break; case self::TYPE_INTEGER: case self::TYPE_ENUMERATED: if ($constructed) { return false; } $current['content'] = new BigInteger(substr($content, $content_pos), -256); break; case self::TYPE_REAL: // not currently supported return false; case self::TYPE_BIT_STRING: // The initial octet shall encode, as an unsigned binary integer with bit 1 as the least significant bit, // the number of unused bits in the final subsequent octet. The number shall be in the range zero to // seven. if (!$constructed) { $current['content'] = substr($content, $content_pos); } else { $temp = self::decode_ber($content, $start, $content_pos); if ($temp === false) { return false; } $length -= (strlen($content) - $content_pos); $last = count($temp) - 1; for ($i = 0; $i < $last; $i++) { // all subtags should be bit strings if ($temp[$i]['type'] != self::TYPE_BIT_STRING) { return false; } $current['content'] .= substr($temp[$i]['content'], 1); } // all subtags should be bit strings if ($temp[$last]['type'] != self::TYPE_BIT_STRING) { return false; } $current['content'] = $temp[$last]['content'][0] . $current['content'] . substr($temp[$i]['content'], 1); } break; case self::TYPE_OCTET_STRING: if (!$constructed) { $current['content'] = substr($content, $content_pos); } else { $current['content'] = ''; $length = 0; while (substr($content, $content_pos, 2) != "\0\0") { $temp = self::decode_ber($content, $length + $start, $content_pos); if ($temp === false) { return false; } $content_pos += $temp['length']; // all subtags should be octet strings if ($temp['type'] != self::TYPE_OCTET_STRING) { return false; } $current['content'] .= $temp['content']; $length += $temp['length']; } if (substr($content, $content_pos, 2) == "\0\0") { $length += 2; // +2 for the EOC } } break; case self::TYPE_NULL: // "The contents octets shall not contain any octets." -- paragraph 8.8.2 if ($constructed || strlen($content)) { return false; } break; case self::TYPE_SEQUENCE: case self::TYPE_SET: if (!$constructed) { return false; } $offset = 0; $current['content'] = []; $content_len = strlen($content); while ($content_pos < $content_len) { // if indefinite length construction was used and we have an end-of-content string next // see paragraphs 8.1.1.3, 8.1.3.2, 8.1.3.6, 8.1.5, and (for an example) 8.6.4.2 if (!isset($current['headerlength']) && substr($content, $content_pos, 2) == "\0\0") { $length = $offset + 2; // +2 for the EOC break 2; } $temp = self::decode_ber($content, $start + $offset, $content_pos); if ($temp === false) { return false; } $content_pos += $temp['length']; $current['content'][] = $temp; $offset += $temp['length']; } break; case self::TYPE_OBJECT_IDENTIFIER: if ($constructed) { return false; } $current['content'] = self::decodeOID(substr($content, $content_pos)); if ($current['content'] === false) { return false; } break; /* Each character string type shall be encoded as if it had been declared: [UNIVERSAL x] IMPLICIT OCTET STRING -- X.690-0207.pdf#page=23 (paragraph 8.21.3) Per that, we're not going to do any validation. If there are any illegal characters in the string, we don't really care */ case self::TYPE_NUMERIC_STRING: // 0,1,2,3,4,5,6,7,8,9, and space case self::TYPE_PRINTABLE_STRING: // Upper and lower case letters, digits, space, apostrophe, left/right parenthesis, plus sign, comma, // hyphen, full stop, solidus, colon, equal sign, question mark case self::TYPE_TELETEX_STRING: // The Teletex character set in CCITT's T61, space, and delete // see http://en.wikipedia.org/wiki/Teletex#Character_sets case self::TYPE_VIDEOTEX_STRING: // The Videotex character set in CCITT's T.100 and T.101, space, and delete case self::TYPE_VISIBLE_STRING: // Printing character sets of international ASCII, and space case self::TYPE_IA5_STRING: // International Alphabet 5 (International ASCII) case self::TYPE_GRAPHIC_STRING: // All registered G sets, and space case self::TYPE_GENERAL_STRING: // All registered C and G sets, space and delete case self::TYPE_UTF8_STRING: // ???? case self::TYPE_BMP_STRING: if ($constructed) { return false; } $current['content'] = substr($content, $content_pos); break; case self::TYPE_UTC_TIME: case self::TYPE_GENERALIZED_TIME: if ($constructed) { return false; } $current['content'] = self::decodeTime(substr($content, $content_pos), $tag); break; default: return false; } $start += $length; // ie. length is the length of the full TLV encoding - it's not just the length of the value return $current + ['length' => $start - $current['start']]; } /** * ASN.1 Map * * Provides an ASN.1 semantic mapping ($mapping) from a parsed BER-encoding to a human readable format. * * "Special" mappings may be applied on a per tag-name basis via $special. * * @param array $decoded * @param array $mapping * @param array $special * @return array|bool|Element|string|null */ public static function asn1map(array $decoded, $mapping, $special = []) { if (isset($mapping['explicit']) && is_array($decoded['content'])) { $decoded = $decoded['content'][0]; } switch (true) { case $mapping['type'] == self::TYPE_ANY: $intype = $decoded['type']; // !isset(self::ANY_MAP[$intype]) produces a fatal error on PHP 5.6 if (isset($decoded['constant']) || !array_key_exists($intype, self::ANY_MAP) || (ord(self::$encoded[$decoded['start']]) & 0x20)) { return new Element(substr(self::$encoded, $decoded['start'], $decoded['length'])); } $inmap = self::ANY_MAP[$intype]; if (is_string($inmap)) { return [$inmap => self::asn1map($decoded, ['type' => $intype] + $mapping, $special)]; } break; case $mapping['type'] == self::TYPE_CHOICE: foreach ($mapping['children'] as $key => $option) { switch (true) { case isset($option['constant']) && $option['constant'] == $decoded['constant']: case !isset($option['constant']) && $option['type'] == $decoded['type']: $value = self::asn1map($decoded, $option, $special); break; case !isset($option['constant']) && $option['type'] == self::TYPE_CHOICE: $v = self::asn1map($decoded, $option, $special); if (isset($v)) { $value = $v; } } if (isset($value)) { if (isset($special[$key])) { $value = $special[$key]($value); } return [$key => $value]; } } return null; case isset($mapping['implicit']): case isset($mapping['explicit']): case $decoded['type'] == $mapping['type']: break; default: // if $decoded['type'] and $mapping['type'] are both strings, but different types of strings, // let it through switch (true) { case $decoded['type'] < 18: // self::TYPE_NUMERIC_STRING == 18 case $decoded['type'] > 30: // self::TYPE_BMP_STRING == 30 case $mapping['type'] < 18: case $mapping['type'] > 30: return null; } } if (isset($mapping['implicit'])) { $decoded['type'] = $mapping['type']; } switch ($decoded['type']) { case self::TYPE_SEQUENCE: $map = []; // ignore the min and max if (isset($mapping['min']) && isset($mapping['max'])) { $child = $mapping['children']; foreach ($decoded['content'] as $content) { if (($map[] = self::asn1map($content, $child, $special)) === null) { return null; } } return $map; } $n = count($decoded['content']); $i = 0; foreach ($mapping['children'] as $key => $child) { $maymatch = $i < $n; // Match only existing input. if ($maymatch) { $temp = $decoded['content'][$i]; if ($child['type'] != self::TYPE_CHOICE) { // Get the mapping and input class & constant. $childClass = $tempClass = self::CLASS_UNIVERSAL; $constant = null; if (isset($temp['constant'])) { $tempClass = $temp['type']; } if (isset($child['class'])) { $childClass = $child['class']; $constant = $child['cast']; } elseif (isset($child['constant'])) { $childClass = self::CLASS_CONTEXT_SPECIFIC; $constant = $child['constant']; } if (isset($constant) && isset($temp['constant'])) { // Can only match if constants and class match. $maymatch = $constant == $temp['constant'] && $childClass == $tempClass; } else { // Can only match if no constant expected and type matches or is generic. $maymatch = !isset($child['constant']) && array_search($child['type'], [$temp['type'], self::TYPE_ANY, self::TYPE_CHOICE]) !== false; } } } if ($maymatch) { // Attempt submapping. $candidate = self::asn1map($temp, $child, $special); $maymatch = $candidate !== null; } if ($maymatch) { // Got the match: use it. if (isset($special[$key])) { $candidate = $special[$key]($candidate); } $map[$key] = $candidate; $i++; } elseif (isset($child['default'])) { $map[$key] = $child['default']; } elseif (!isset($child['optional'])) { return null; // Syntax error. } } // Fail mapping if all input items have not been consumed. return $i < $n ? null : $map; // the main diff between sets and sequences is the encapsulation of the foreach in another for loop case self::TYPE_SET: $map = []; // ignore the min and max if (isset($mapping['min']) && isset($mapping['max'])) { $child = $mapping['children']; foreach ($decoded['content'] as $content) { if (($map[] = self::asn1map($content, $child, $special)) === null) { return null; } } return $map; } for ($i = 0; $i < count($decoded['content']); $i++) { $temp = $decoded['content'][$i]; $tempClass = self::CLASS_UNIVERSAL; if (isset($temp['constant'])) { $tempClass = $temp['type']; } foreach ($mapping['children'] as $key => $child) { if (isset($map[$key])) { continue; } $maymatch = true; if ($child['type'] != self::TYPE_CHOICE) { $childClass = self::CLASS_UNIVERSAL; $constant = null; if (isset($child['class'])) { $childClass = $child['class']; $constant = $child['cast']; } elseif (isset($child['constant'])) { $childClass = self::CLASS_CONTEXT_SPECIFIC; $constant = $child['constant']; } if (isset($constant) && isset($temp['constant'])) { // Can only match if constants and class match. $maymatch = $constant == $temp['constant'] && $childClass == $tempClass; } else { // Can only match if no constant expected and type matches or is generic. $maymatch = !isset($child['constant']) && array_search($child['type'], [$temp['type'], self::TYPE_ANY, self::TYPE_CHOICE]) !== false; } } if ($maymatch) { // Attempt submapping. $candidate = self::asn1map($temp, $child, $special); $maymatch = $candidate !== null; } if (!$maymatch) { break; } // Got the match: use it. if (isset($special[$key])) { $candidate = $special[$key]($candidate); } $map[$key] = $candidate; break; } } foreach ($mapping['children'] as $key => $child) { if (!isset($map[$key])) { if (isset($child['default'])) { $map[$key] = $child['default']; } elseif (!isset($child['optional'])) { return null; } } } return $map; case self::TYPE_OBJECT_IDENTIFIER: return isset(self::$oids[$decoded['content']]) ? self::$oids[$decoded['content']] : $decoded['content']; case self::TYPE_UTC_TIME: case self::TYPE_GENERALIZED_TIME: // for explicitly tagged optional stuff if (is_array($decoded['content'])) { $decoded['content'] = $decoded['content'][0]['content']; } // for implicitly tagged optional stuff // in theory, doing isset($mapping['implicit']) would work but malformed certs do exist // in the wild that OpenSSL decodes without issue so we'll support them as well if (!is_object($decoded['content'])) { $decoded['content'] = self::decodeTime($decoded['content'], $decoded['type']); } return $decoded['content'] ? $decoded['content']->format(self::$format) : false; case self::TYPE_BIT_STRING: if (isset($mapping['mapping'])) { $offset = ord($decoded['content'][0]); $size = (strlen($decoded['content']) - 1) * 8 - $offset; /* From X.680-0207.pdf#page=46 (21.7): "When a "NamedBitList" is used in defining a bitstring type ASN.1 encoding rules are free to add (or remove) arbitrarily any trailing 0 bits to (or from) values that are being encoded or decoded. Application designers should therefore ensure that different semantics are not associated with such values which differ only in the number of trailing 0 bits." */ $bits = count($mapping['mapping']) == $size ? [] : array_fill(0, count($mapping['mapping']) - $size, false); for ($i = strlen($decoded['content']) - 1; $i > 0; $i--) { $current = ord($decoded['content'][$i]); for ($j = $offset; $j < 8; $j++) { $bits[] = (bool) ($current & (1 << $j)); } $offset = 0; } $values = []; $map = array_reverse($mapping['mapping']); foreach ($map as $i => $value) { if ($bits[$i]) { $values[] = $value; } } return $values; } // fall-through case self::TYPE_OCTET_STRING: return $decoded['content']; case self::TYPE_NULL: return ''; case self::TYPE_BOOLEAN: case self::TYPE_NUMERIC_STRING: case self::TYPE_PRINTABLE_STRING: case self::TYPE_TELETEX_STRING: case self::TYPE_VIDEOTEX_STRING: case self::TYPE_IA5_STRING: case self::TYPE_GRAPHIC_STRING: case self::TYPE_VISIBLE_STRING: case self::TYPE_GENERAL_STRING: case self::TYPE_UNIVERSAL_STRING: case self::TYPE_UTF8_STRING: case self::TYPE_BMP_STRING: return $decoded['content']; case self::TYPE_INTEGER: case self::TYPE_ENUMERATED: $temp = $decoded['content']; if (isset($mapping['implicit'])) { $temp = new BigInteger($decoded['content'], -256); } if (isset($mapping['mapping'])) { $temp = (int) $temp->toString(); return isset($mapping['mapping'][$temp]) ? $mapping['mapping'][$temp] : false; } return $temp; } } /** * DER-decode the length * * DER supports lengths up to (2**8)**127, however, we'll only support lengths up to (2**8)**4. See * {@link http://itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf#p=13 X.690 paragraph 8.1.3} for more information. * * @param string $string * @return int */ public static function decodeLength(&$string) { $length = ord(Strings::shift($string)); if ($length & 0x80) { // definite length, long form $length &= 0x7F; $temp = Strings::shift($string, $length); list(, $length) = unpack('N', substr(str_pad($temp, 4, chr(0), STR_PAD_LEFT), -4)); } return $length; } /** * ASN.1 Encode * * DER-encodes an ASN.1 semantic mapping ($mapping). Some libraries would probably call this function * an ASN.1 compiler. * * "Special" mappings can be applied via $special. * * @param Element|string|array $source * @param array $mapping * @param array $special * @return string */ public static function encodeDER($source, $mapping, $special = []) { self::$location = []; return self::encode_der($source, $mapping, null, $special); } /** * ASN.1 Encode (Helper function) * * @param Element|string|array|null $source * @param array $mapping * @param int $idx * @param array $special * @return string */ private static function encode_der($source, array $mapping, $idx = null, array $special = []) { if ($source instanceof Element) { return $source->element; } // do not encode (implicitly optional) fields with value set to default if (isset($mapping['default']) && $source === $mapping['default']) { return ''; } if (isset($idx)) { if (isset($special[$idx])) { $source = $special[$idx]($source); } self::$location[] = $idx; } $tag = $mapping['type']; switch ($tag) { case self::TYPE_SET: // Children order is not important, thus process in sequence. case self::TYPE_SEQUENCE: $tag |= 0x20; // set the constructed bit // ignore the min and max if (isset($mapping['min']) && isset($mapping['max'])) { $value = []; $child = $mapping['children']; foreach ($source as $content) { $temp = self::encode_der($content, $child, null, $special); if ($temp === false) { return false; } $value[] = $temp; } /* "The encodings of the component values of a set-of value shall appear in ascending order, the encodings being compared as octet strings with the shorter components being padded at their trailing end with 0-octets. NOTE - The padding octets are for comparison purposes only and do not appear in the encodings." -- sec 11.6 of http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf */ if ($mapping['type'] == self::TYPE_SET) { sort($value); } $value = implode('', $value); break; } $value = ''; foreach ($mapping['children'] as $key => $child) { if (!array_key_exists($key, $source)) { if (!isset($child['optional'])) { return false; } continue; } $temp = self::encode_der($source[$key], $child, $key, $special); if ($temp === false) { return false; } // An empty child encoding means it has been optimized out. // Else we should have at least one tag byte. if ($temp === '') { continue; } // if isset($child['constant']) is true then isset($child['optional']) should be true as well if (isset($child['constant'])) { /* From X.680-0207.pdf#page=58 (30.6): "The tagging construction specifies explicit tagging if any of the following holds: ... c) the "Tag Type" alternative is used and the value of "TagDefault" for the module is IMPLICIT TAGS or AUTOMATIC TAGS, but the type defined by "Type" is an untagged choice type, an untagged open type, or an untagged "DummyReference" (see ITU-T Rec. X.683 | ISO/IEC 8824-4, 8.3)." */ if (isset($child['explicit']) || $child['type'] == self::TYPE_CHOICE) { $subtag = chr((self::CLASS_CONTEXT_SPECIFIC << 6) | 0x20 | $child['constant']); $temp = $subtag . self::encodeLength(strlen($temp)) . $temp; } else { $subtag = chr((self::CLASS_CONTEXT_SPECIFIC << 6) | (ord($temp[0]) & 0x20) | $child['constant']); $temp = $subtag . substr($temp, 1); } } $value .= $temp; } break; case self::TYPE_CHOICE: $temp = false; foreach ($mapping['children'] as $key => $child) { if (!isset($source[$key])) { continue; } $temp = self::encode_der($source[$key], $child, $key, $special); if ($temp === false) { return false; } // An empty child encoding means it has been optimized out. // Else we should have at least one tag byte. if ($temp === '') { continue; } $tag = ord($temp[0]); // if isset($child['constant']) is true then isset($child['optional']) should be true as well if (isset($child['constant'])) { if (isset($child['explicit']) || $child['type'] == self::TYPE_CHOICE) { $subtag = chr((self::CLASS_CONTEXT_SPECIFIC << 6) | 0x20 | $child['constant']); $temp = $subtag . self::encodeLength(strlen($temp)) . $temp; } else { $subtag = chr((self::CLASS_CONTEXT_SPECIFIC << 6) | (ord($temp[0]) & 0x20) | $child['constant']); $temp = $subtag . substr($temp, 1); } } } if (isset($idx)) { array_pop(self::$location); } if ($temp && isset($mapping['cast'])) { $temp[0] = chr(($mapping['class'] << 6) | ($tag & 0x20) | $mapping['cast']); } return $temp; case self::TYPE_INTEGER: case self::TYPE_ENUMERATED: if (!isset($mapping['mapping'])) { if (is_numeric($source)) { $source = new BigInteger($source); } $value = $source->toBytes(true); } else { $value = array_search($source, $mapping['mapping']); if ($value === false) { return false; } $value = new BigInteger($value); $value = $value->toBytes(true); } if (!strlen($value)) { $value = chr(0); } break; case self::TYPE_UTC_TIME: case self::TYPE_GENERALIZED_TIME: $format = $mapping['type'] == self::TYPE_UTC_TIME ? 'y' : 'Y'; $format .= 'mdHis'; // if $source does _not_ include timezone information within it then assume that the timezone is GMT $date = new \DateTime($source, new \DateTimeZone('GMT')); // if $source _does_ include timezone information within it then convert the time to GMT $date->setTimezone(new \DateTimeZone('GMT')); $value = $date->format($format) . 'Z'; break; case self::TYPE_BIT_STRING: if (isset($mapping['mapping'])) { $bits = array_fill(0, count($mapping['mapping']), 0); $size = 0; for ($i = 0; $i < count($mapping['mapping']); $i++) { if (in_array($mapping['mapping'][$i], $source)) { $bits[$i] = 1; $size = $i; } } if (isset($mapping['min']) && $mapping['min'] >= 1 && $size < $mapping['min']) { $size = $mapping['min'] - 1; } $offset = 8 - (($size + 1) & 7); $offset = $offset !== 8 ? $offset : 0; $value = chr($offset); for ($i = $size + 1; $i < count($mapping['mapping']); $i++) { unset($bits[$i]); } $bits = implode('', array_pad($bits, $size + $offset + 1, 0)); $bytes = explode(' ', rtrim(chunk_split($bits, 8, ' '))); foreach ($bytes as $byte) { $value .= chr(bindec($byte)); } break; } // fall-through case self::TYPE_OCTET_STRING: /* The initial octet shall encode, as an unsigned binary integer with bit 1 as the least significant bit, the number of unused bits in the final subsequent octet. The number shall be in the range zero to seven. -- http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf#page=16 */ $value = $source; break; case self::TYPE_OBJECT_IDENTIFIER: $value = self::encodeOID($source); break; case self::TYPE_ANY: $loc = self::$location; if (isset($idx)) { array_pop(self::$location); } switch (true) { case !isset($source): return self::encode_der(null, ['type' => self::TYPE_NULL] + $mapping, null, $special); case is_int($source): case $source instanceof BigInteger: return self::encode_der($source, ['type' => self::TYPE_INTEGER] + $mapping, null, $special); case is_float($source): return self::encode_der($source, ['type' => self::TYPE_REAL] + $mapping, null, $special); case is_bool($source): return self::encode_der($source, ['type' => self::TYPE_BOOLEAN] + $mapping, null, $special); case is_array($source) && count($source) == 1: $typename = implode('', array_keys($source)); $outtype = array_search($typename, self::ANY_MAP, true); if ($outtype !== false) { return self::encode_der($source[$typename], ['type' => $outtype] + $mapping, null, $special); } } $filters = self::$filters; foreach ($loc as $part) { if (!isset($filters[$part])) { $filters = false; break; } $filters = $filters[$part]; } if ($filters === false) { throw new \RuntimeException('No filters defined for ' . implode('/', $loc)); } return self::encode_der($source, $filters + $mapping, null, $special); case self::TYPE_NULL: $value = ''; break; case self::TYPE_NUMERIC_STRING: case self::TYPE_TELETEX_STRING: case self::TYPE_PRINTABLE_STRING: case self::TYPE_UNIVERSAL_STRING: case self::TYPE_UTF8_STRING: case self::TYPE_BMP_STRING: case self::TYPE_IA5_STRING: case self::TYPE_VISIBLE_STRING: case self::TYPE_VIDEOTEX_STRING: case self::TYPE_GRAPHIC_STRING: case self::TYPE_GENERAL_STRING: $value = $source; break; case self::TYPE_BOOLEAN: $value = $source ? "\xFF" : "\x00"; break; default: throw new \RuntimeException('Mapping provides no type definition for ' . implode('/', self::$location)); } if (isset($idx)) { array_pop(self::$location); } if (isset($mapping['cast'])) { if (isset($mapping['explicit']) || $mapping['type'] == self::TYPE_CHOICE) { $value = chr($tag) . self::encodeLength(strlen($value)) . $value; $tag = ($mapping['class'] << 6) | 0x20 | $mapping['cast']; } else { $tag = ($mapping['class'] << 6) | (ord($temp[0]) & 0x20) | $mapping['cast']; } } return chr($tag) . self::encodeLength(strlen($value)) . $value; } /** * BER-decode the OID * * Called by _decode_ber() * * @param string $content * @return string */ public static function decodeOID($content) { static $eighty; if (!$eighty) { $eighty = new BigInteger(80); } $oid = []; $pos = 0; $len = strlen($content); // see https://github.com/openjdk/jdk/blob/2deb318c9f047ec5a4b160d66a4b52f93688ec42/src/java.base/share/classes/sun/security/util/ObjectIdentifier.java#L55 if ($len > 4096) { //throw new \RuntimeException("Object identifier size is limited to 4096 bytes ($len bytes present)"); return false; } if (ord($content[$len - 1]) & 0x80) { return false; } $n = new BigInteger(); while ($pos < $len) { $temp = ord($content[$pos++]); $n = $n->bitwise_leftShift(7); $n = $n->bitwise_or(new BigInteger($temp & 0x7F)); if (~$temp & 0x80) { $oid[] = $n; $n = new BigInteger(); } } $part1 = array_shift($oid); $first = floor(ord($content[0]) / 40); /* "This packing of the first two object identifier components recognizes that only three values are allocated from the root node, and at most 39 subsequent values from nodes reached by X = 0 and X = 1." -- https://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf#page=22 */ if ($first <= 2) { // ie. 0 <= ord($content[0]) < 120 (0x78) array_unshift($oid, ord($content[0]) % 40); array_unshift($oid, $first); } else { array_unshift($oid, $part1->subtract($eighty)); array_unshift($oid, 2); } return implode('.', $oid); } /** * DER-encode the OID * * Called by _encode_der() * * @param string $source * @return string */ public static function encodeOID($source) { static $mask, $zero, $forty; if (!$mask) { $mask = new BigInteger(0x7F); $zero = new BigInteger(); $forty = new BigInteger(40); } if (!preg_match('#(?:\d+\.)+#', $source)) { $oid = isset(self::$reverseOIDs[$source]) ? self::$reverseOIDs[$source] : false; } else { $oid = $source; } if ($oid === false) { throw new \RuntimeException('Invalid OID'); } $parts = explode('.', $oid); $part1 = array_shift($parts); $part2 = array_shift($parts); $first = new BigInteger($part1); $first = $first->multiply($forty); $first = $first->add(new BigInteger($part2)); array_unshift($parts, $first->toString()); $value = ''; foreach ($parts as $part) { if (!$part) { $temp = "\0"; } else { $temp = ''; $part = new BigInteger($part); while (!$part->equals($zero)) { $submask = $part->bitwise_and($mask); $submask->setPrecision(8); $temp = (chr(0x80) | $submask->toBytes()) . $temp; $part = $part->bitwise_rightShift(7); } $temp[strlen($temp) - 1] = $temp[strlen($temp) - 1] & chr(0x7F); } $value .= $temp; } return $value; } /** * BER-decode the time * * Called by _decode_ber() and in the case of implicit tags asn1map(). * * @param string $content * @param int $tag * @return \DateTime|false */ private static function decodeTime($content, $tag) { /* UTCTime: http://tools.ietf.org/html/rfc5280#section-4.1.2.5.1 http://www.obj-sys.com/asn1tutorial/node15.html GeneralizedTime: http://tools.ietf.org/html/rfc5280#section-4.1.2.5.2 http://www.obj-sys.com/asn1tutorial/node14.html */ $format = 'YmdHis'; if ($tag == self::TYPE_UTC_TIME) { // https://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf#page=28 says "the seconds // element shall always be present" but none-the-less I've seen X509 certs where it isn't and if the // browsers parse it phpseclib ought to too if (preg_match('#^(\d{10})(Z|[+-]\d{4})$#', $content, $matches)) { $content = $matches[1] . '00' . $matches[2]; } $prefix = substr($content, 0, 2) >= 50 ? '19' : '20'; $content = $prefix . $content; } elseif (strpos($content, '.') !== false) { $format .= '.u'; } if ($content[strlen($content) - 1] == 'Z') { $content = substr($content, 0, -1) . '+0000'; } if (strpos($content, '-') !== false || strpos($content, '+') !== false) { $format .= 'O'; } // error supression isn't necessary as of PHP 7.0: // http://php.net/manual/en/migration70.other-changes.php return @\DateTime::createFromFormat($format, $content); } /** * Set the time format * * Sets the time / date format for asn1map(). * * @param string $format */ public static function setTimeFormat($format) { self::$format = $format; } /** * Load OIDs * * Load the relevant OIDs for a particular ASN.1 semantic mapping. * Previously loaded OIDs are retained. * * @param array $oids */ public static function loadOIDs(array $oids) { self::$reverseOIDs += $oids; self::$oids = array_flip(self::$reverseOIDs); } /** * Set filters * * See \phpseclib3\File\X509, etc, for an example. * Previously loaded filters are not retained. * * @param array $filters */ public static function setFilters(array $filters) { self::$filters = $filters; } /** * String type conversion * * This is a lazy conversion, dealing only with character size. * No real conversion table is used. * * @param string $in * @param int $from * @param int $to * @return string */ public static function convert($in, $from = self::TYPE_UTF8_STRING, $to = self::TYPE_UTF8_STRING) { // isset(self::STRING_TYPE_SIZE[$from] returns a fatal error on PHP 5.6 if (!array_key_exists($from, self::STRING_TYPE_SIZE) || !array_key_exists($to, self::STRING_TYPE_SIZE)) { return false; } $insize = self::STRING_TYPE_SIZE[$from]; $outsize = self::STRING_TYPE_SIZE[$to]; $inlength = strlen($in); $out = ''; for ($i = 0; $i < $inlength;) { if ($inlength - $i < $insize) { return false; } // Get an input character as a 32-bit value. $c = ord($in[$i++]); switch (true) { case $insize == 4: $c = ($c << 8) | ord($in[$i++]); $c = ($c << 8) | ord($in[$i++]); // fall-through case $insize == 2: $c = ($c << 8) | ord($in[$i++]); // fall-through case $insize == 1: break; case ($c & 0x80) == 0x00: break; case ($c & 0x40) == 0x00: return false; default: $bit = 6; do { if ($bit > 25 || $i >= $inlength || (ord($in[$i]) & 0xC0) != 0x80) { return false; } $c = ($c << 6) | (ord($in[$i++]) & 0x3F); $bit += 5; $mask = 1 << $bit; } while ($c & $bit); $c &= $mask - 1; break; } // Convert and append the character to output string. $v = ''; switch (true) { case $outsize == 4: $v .= chr($c & 0xFF); $c >>= 8; $v .= chr($c & 0xFF); $c >>= 8; // fall-through case $outsize == 2: $v .= chr($c & 0xFF); $c >>= 8; // fall-through case $outsize == 1: $v .= chr($c & 0xFF); $c >>= 8; if ($c) { return false; } break; case ($c & (PHP_INT_SIZE == 8 ? 0x80000000 : (1 << 31))) != 0: return false; case $c >= 0x04000000: $v .= chr(0x80 | ($c & 0x3F)); $c = ($c >> 6) | 0x04000000; // fall-through case $c >= 0x00200000: $v .= chr(0x80 | ($c & 0x3F)); $c = ($c >> 6) | 0x00200000; // fall-through case $c >= 0x00010000: $v .= chr(0x80 | ($c & 0x3F)); $c = ($c >> 6) | 0x00010000; // fall-through case $c >= 0x00000800: $v .= chr(0x80 | ($c & 0x3F)); $c = ($c >> 6) | 0x00000800; // fall-through case $c >= 0x00000080: $v .= chr(0x80 | ($c & 0x3F)); $c = ($c >> 6) | 0x000000C0; // fall-through default: $v .= chr($c); break; } $out .= strrev($v); } return $out; } /** * Extract raw BER from Base64 encoding * * @param string $str * @return string */ public static function extractBER($str) { /* X.509 certs are assumed to be base64 encoded but sometimes they'll have additional things in them * above and beyond the ceritificate. * ie. some may have the following preceding the -----BEGIN CERTIFICATE----- line: * * Bag Attributes * localKeyID: 01 00 00 00 * subject=/O=organization/OU=org unit/CN=common name * issuer=/O=organization/CN=common name */ if (strlen($str) > ini_get('pcre.backtrack_limit')) { $temp = $str; } else { $temp = preg_replace('#.*?^-+[^-]+-+[\r\n ]*$#ms', '', $str, 1); $temp = preg_replace('#-+END.*[\r\n ]*.*#ms', '', $temp, 1); } // remove new lines $temp = str_replace(["\r", "\n", ' '], '', $temp); // remove the -----BEGIN CERTIFICATE----- and -----END CERTIFICATE----- stuff $temp = preg_replace('#^-+[^-]+-+|-+[^-]+-+$#', '', $temp); $temp = preg_match('#^[a-zA-Z\d/+]*={0,2}$#', $temp) ? Strings::base64_decode($temp) : false; return $temp != false ? $temp : $str; } /** * DER-encode the length * * DER supports lengths up to (2**8)**127, however, we'll only support lengths up to (2**8)**4. See * {@link http://itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf#p=13 X.690 paragraph 8.1.3} for more information. * * @param int $length * @return string */ public static function encodeLength($length) { if ($length <= 0x7F) { return chr($length); } $temp = ltrim(pack('N', $length), chr(0)); return pack('Ca*', 0x80 | strlen($temp), $temp); } /** * Returns the OID corresponding to a name * * What's returned in the associative array returned by loadX509() (or load*()) is either a name or an OID if * no OID to name mapping is available. The problem with this is that what may be an unmapped OID in one version * of phpseclib may not be unmapped in the next version, so apps that are looking at this OID may not be able * to work from version to version. * * This method will return the OID if a name is passed to it and if no mapping is avialable it'll assume that * what's being passed to it already is an OID and return that instead. A few examples. * * getOID('2.16.840.1.101.3.4.2.1') == '2.16.840.1.101.3.4.2.1' * getOID('id-sha256') == '2.16.840.1.101.3.4.2.1' * getOID('zzz') == 'zzz' * * @param string $name * @return string */ public static function getOID($name) { return isset(self::$reverseOIDs[$name]) ? self::$reverseOIDs[$name] : $name; } } ANSI.php000075500000047012000000000000005757 0ustar00 * @copyright 2012 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File; /** * Pure-PHP ANSI Decoder * * @author Jim Wigginton */ class ANSI { /** * Max Width * * @var int */ private $max_x; /** * Max Height * * @var int */ private $max_y; /** * Max History * * @var int */ private $max_history; /** * History * * @var array */ private $history; /** * History Attributes * * @var array */ private $history_attrs; /** * Current Column * * @var int */ private $x; /** * Current Row * * @var int */ private $y; /** * Old Column * * @var int */ private $old_x; /** * Old Row * * @var int */ private $old_y; /** * An empty attribute cell * * @var object */ private $base_attr_cell; /** * The current attribute cell * * @var object */ private $attr_cell; /** * An empty attribute row * * @var array */ private $attr_row; /** * The current screen text * * @var list */ private $screen; /** * The current screen attributes * * @var array */ private $attrs; /** * Current ANSI code * * @var string */ private $ansi; /** * Tokenization * * @var array */ private $tokenization; /** * Default Constructor. * * @return ANSI */ public function __construct() { $attr_cell = new \stdClass(); $attr_cell->bold = false; $attr_cell->underline = false; $attr_cell->blink = false; $attr_cell->background = 'black'; $attr_cell->foreground = 'white'; $attr_cell->reverse = false; $this->base_attr_cell = clone $attr_cell; $this->attr_cell = clone $attr_cell; $this->setHistory(200); $this->setDimensions(80, 24); } /** * Set terminal width and height * * Resets the screen as well * * @param int $x * @param int $y */ public function setDimensions($x, $y) { $this->max_x = $x - 1; $this->max_y = $y - 1; $this->x = $this->y = 0; $this->history = $this->history_attrs = []; $this->attr_row = array_fill(0, $this->max_x + 2, $this->base_attr_cell); $this->screen = array_fill(0, $this->max_y + 1, ''); $this->attrs = array_fill(0, $this->max_y + 1, $this->attr_row); $this->ansi = ''; } /** * Set the number of lines that should be logged past the terminal height * * @param int $history */ public function setHistory($history) { $this->max_history = $history; } /** * Load a string * * @param string $source */ public function loadString($source) { $this->setDimensions($this->max_x + 1, $this->max_y + 1); $this->appendString($source); } /** * Appdend a string * * @param string $source */ public function appendString($source) { $this->tokenization = ['']; for ($i = 0; $i < strlen($source); $i++) { if (strlen($this->ansi)) { $this->ansi .= $source[$i]; $chr = ord($source[$i]); // http://en.wikipedia.org/wiki/ANSI_escape_code#Sequence_elements // single character CSI's not currently supported switch (true) { case $this->ansi == "\x1B=": $this->ansi = ''; continue 2; case strlen($this->ansi) == 2 && $chr >= 64 && $chr <= 95 && $chr != ord('['): case strlen($this->ansi) > 2 && $chr >= 64 && $chr <= 126: break; default: continue 2; } $this->tokenization[] = $this->ansi; $this->tokenization[] = ''; // http://ascii-table.com/ansi-escape-sequences-vt-100.php switch ($this->ansi) { case "\x1B[H": // Move cursor to upper left corner $this->old_x = $this->x; $this->old_y = $this->y; $this->x = $this->y = 0; break; case "\x1B[J": // Clear screen from cursor down $this->history = array_merge($this->history, array_slice(array_splice($this->screen, $this->y + 1), 0, $this->old_y)); $this->screen = array_merge($this->screen, array_fill($this->y, $this->max_y, '')); $this->history_attrs = array_merge($this->history_attrs, array_slice(array_splice($this->attrs, $this->y + 1), 0, $this->old_y)); $this->attrs = array_merge($this->attrs, array_fill($this->y, $this->max_y, $this->attr_row)); if (count($this->history) == $this->max_history) { array_shift($this->history); array_shift($this->history_attrs); } // fall-through case "\x1B[K": // Clear screen from cursor right $this->screen[$this->y] = substr($this->screen[$this->y], 0, $this->x); array_splice($this->attrs[$this->y], $this->x + 1, $this->max_x - $this->x, array_fill($this->x, $this->max_x - ($this->x - 1), $this->base_attr_cell)); break; case "\x1B[2K": // Clear entire line $this->screen[$this->y] = str_repeat(' ', $this->x); $this->attrs[$this->y] = $this->attr_row; break; case "\x1B[?1h": // set cursor key to application case "\x1B[?25h": // show the cursor case "\x1B(B": // set united states g0 character set break; case "\x1BE": // Move to next line $this->newLine(); $this->x = 0; break; default: switch (true) { case preg_match('#\x1B\[(\d+)B#', $this->ansi, $match): // Move cursor down n lines $this->old_y = $this->y; $this->y += (int) $match[1]; break; case preg_match('#\x1B\[(\d+);(\d+)H#', $this->ansi, $match): // Move cursor to screen location v,h $this->old_x = $this->x; $this->old_y = $this->y; $this->x = $match[2] - 1; $this->y = (int) $match[1] - 1; break; case preg_match('#\x1B\[(\d+)C#', $this->ansi, $match): // Move cursor right n lines $this->old_x = $this->x; $this->x += $match[1]; break; case preg_match('#\x1B\[(\d+)D#', $this->ansi, $match): // Move cursor left n lines $this->old_x = $this->x; $this->x -= $match[1]; if ($this->x < 0) { $this->x = 0; } break; case preg_match('#\x1B\[(\d+);(\d+)r#', $this->ansi, $match): // Set top and bottom lines of a window break; case preg_match('#\x1B\[(\d*(?:;\d*)*)m#', $this->ansi, $match): // character attributes $attr_cell = &$this->attr_cell; $mods = explode(';', $match[1]); foreach ($mods as $mod) { switch ($mod) { case '': case '0': // Turn off character attributes $attr_cell = clone $this->base_attr_cell; break; case '1': // Turn bold mode on $attr_cell->bold = true; break; case '4': // Turn underline mode on $attr_cell->underline = true; break; case '5': // Turn blinking mode on $attr_cell->blink = true; break; case '7': // Turn reverse video on $attr_cell->reverse = !$attr_cell->reverse; $temp = $attr_cell->background; $attr_cell->background = $attr_cell->foreground; $attr_cell->foreground = $temp; break; default: // set colors //$front = $attr_cell->reverse ? &$attr_cell->background : &$attr_cell->foreground; $front = &$attr_cell->{ $attr_cell->reverse ? 'background' : 'foreground' }; //$back = $attr_cell->reverse ? &$attr_cell->foreground : &$attr_cell->background; $back = &$attr_cell->{ $attr_cell->reverse ? 'foreground' : 'background' }; switch ($mod) { // @codingStandardsIgnoreStart case '30': $front = 'black'; break; case '31': $front = 'red'; break; case '32': $front = 'green'; break; case '33': $front = 'yellow'; break; case '34': $front = 'blue'; break; case '35': $front = 'magenta'; break; case '36': $front = 'cyan'; break; case '37': $front = 'white'; break; case '40': $back = 'black'; break; case '41': $back = 'red'; break; case '42': $back = 'green'; break; case '43': $back = 'yellow'; break; case '44': $back = 'blue'; break; case '45': $back = 'magenta'; break; case '46': $back = 'cyan'; break; case '47': $back = 'white'; break; // @codingStandardsIgnoreEnd default: //user_error('Unsupported attribute: ' . $mod); $this->ansi = ''; break 2; } } } break; default: //user_error("{$this->ansi} is unsupported\r\n"); } } $this->ansi = ''; continue; } $this->tokenization[count($this->tokenization) - 1] .= $source[$i]; switch ($source[$i]) { case "\r": $this->x = 0; break; case "\n": $this->newLine(); break; case "\x08": // backspace if ($this->x) { $this->x--; $this->attrs[$this->y][$this->x] = clone $this->base_attr_cell; $this->screen[$this->y] = substr_replace( $this->screen[$this->y], $source[$i], $this->x, 1 ); } break; case "\x0F": // shift break; case "\x1B": // start ANSI escape code $this->tokenization[count($this->tokenization) - 1] = substr($this->tokenization[count($this->tokenization) - 1], 0, -1); //if (!strlen($this->tokenization[count($this->tokenization) - 1])) { // array_pop($this->tokenization); //} $this->ansi .= "\x1B"; break; default: $this->attrs[$this->y][$this->x] = clone $this->attr_cell; if ($this->x > strlen($this->screen[$this->y])) { $this->screen[$this->y] = str_repeat(' ', $this->x); } $this->screen[$this->y] = substr_replace( $this->screen[$this->y], $source[$i], $this->x, 1 ); if ($this->x > $this->max_x) { $this->x = 0; $this->newLine(); } else { $this->x++; } } } } /** * Add a new line * * Also update the $this->screen and $this->history buffers * */ private function newLine() { //if ($this->y < $this->max_y) { // $this->y++; //} while ($this->y >= $this->max_y) { $this->history = array_merge($this->history, [array_shift($this->screen)]); $this->screen[] = ''; $this->history_attrs = array_merge($this->history_attrs, [array_shift($this->attrs)]); $this->attrs[] = $this->attr_row; if (count($this->history) >= $this->max_history) { array_shift($this->history); array_shift($this->history_attrs); } $this->y--; } $this->y++; } /** * Returns the current coordinate without preformating * * @param \stdClass $last_attr * @param \stdClass $cur_attr * @param string $char * @return string */ private function processCoordinate(\stdClass $last_attr, \stdClass $cur_attr, $char) { $output = ''; if ($last_attr != $cur_attr) { $close = $open = ''; if ($last_attr->foreground != $cur_attr->foreground) { if ($cur_attr->foreground != 'white') { $open .= ''; } if ($last_attr->foreground != 'white') { $close = '' . $close; } } if ($last_attr->background != $cur_attr->background) { if ($cur_attr->background != 'black') { $open .= ''; } if ($last_attr->background != 'black') { $close = '' . $close; } } if ($last_attr->bold != $cur_attr->bold) { if ($cur_attr->bold) { $open .= ''; } else { $close = '' . $close; } } if ($last_attr->underline != $cur_attr->underline) { if ($cur_attr->underline) { $open .= ''; } else { $close = '' . $close; } } if ($last_attr->blink != $cur_attr->blink) { if ($cur_attr->blink) { $open .= ''; } else { $close = '' . $close; } } $output .= $close . $open; } $output .= htmlspecialchars($char); return $output; } /** * Returns the current screen without preformating * * @return string */ private function getScreenHelper() { $output = ''; $last_attr = $this->base_attr_cell; for ($i = 0; $i <= $this->max_y; $i++) { for ($j = 0; $j <= $this->max_x; $j++) { $cur_attr = $this->attrs[$i][$j]; $output .= $this->processCoordinate($last_attr, $cur_attr, isset($this->screen[$i][$j]) ? $this->screen[$i][$j] : ''); $last_attr = $this->attrs[$i][$j]; } $output .= "\r\n"; } $output = substr($output, 0, -2); // close any remaining open tags $output .= $this->processCoordinate($last_attr, $this->base_attr_cell, ''); return rtrim($output); } /** * Returns the current screen * * @return string */ public function getScreen() { return '
' . $this->getScreenHelper() . '
'; } /** * Returns the current screen and the x previous lines * * @return string */ public function getHistory() { $scrollback = ''; $last_attr = $this->base_attr_cell; for ($i = 0; $i < count($this->history); $i++) { for ($j = 0; $j <= $this->max_x + 1; $j++) { $cur_attr = $this->history_attrs[$i][$j]; $scrollback .= $this->processCoordinate($last_attr, $cur_attr, isset($this->history[$i][$j]) ? $this->history[$i][$j] : ''); $last_attr = $this->history_attrs[$i][$j]; } $scrollback .= "\r\n"; } $base_attr_cell = $this->base_attr_cell; $this->base_attr_cell = $last_attr; $scrollback .= $this->getScreen(); $this->base_attr_cell = $base_attr_cell; return '
' . $scrollback . '
'; } } X509.php000075500000427020000000000000005673 0ustar00 * @copyright 2012 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File; use phpseclib3\Common\Functions\Strings; use phpseclib3\Crypt\Common\PrivateKey; use phpseclib3\Crypt\Common\PublicKey; use phpseclib3\Crypt\DSA; use phpseclib3\Crypt\EC; use phpseclib3\Crypt\Hash; use phpseclib3\Crypt\PublicKeyLoader; use phpseclib3\Crypt\Random; use phpseclib3\Crypt\RSA; use phpseclib3\Crypt\RSA\Formats\Keys\PSS; use phpseclib3\Exception\UnsupportedAlgorithmException; use phpseclib3\File\ASN1\Element; use phpseclib3\File\ASN1\Maps; use phpseclib3\Math\BigInteger; /** * Pure-PHP X.509 Parser * * @author Jim Wigginton */ class X509 { /** * Flag to only accept signatures signed by certificate authorities * * Not really used anymore but retained all the same to suppress E_NOTICEs from old installs * */ const VALIDATE_SIGNATURE_BY_CA = 1; /** * Return internal array representation * * @see \phpseclib3\File\X509::getDN() */ const DN_ARRAY = 0; /** * Return string * * @see \phpseclib3\File\X509::getDN() */ const DN_STRING = 1; /** * Return ASN.1 name string * * @see \phpseclib3\File\X509::getDN() */ const DN_ASN1 = 2; /** * Return OpenSSL compatible array * * @see \phpseclib3\File\X509::getDN() */ const DN_OPENSSL = 3; /** * Return canonical ASN.1 RDNs string * * @see \phpseclib3\File\X509::getDN() */ const DN_CANON = 4; /** * Return name hash for file indexing * * @see \phpseclib3\File\X509::getDN() */ const DN_HASH = 5; /** * Save as PEM * * ie. a base64-encoded PEM with a header and a footer * * @see \phpseclib3\File\X509::saveX509() * @see \phpseclib3\File\X509::saveCSR() * @see \phpseclib3\File\X509::saveCRL() */ const FORMAT_PEM = 0; /** * Save as DER * * @see \phpseclib3\File\X509::saveX509() * @see \phpseclib3\File\X509::saveCSR() * @see \phpseclib3\File\X509::saveCRL() */ const FORMAT_DER = 1; /** * Save as a SPKAC * * @see \phpseclib3\File\X509::saveX509() * @see \phpseclib3\File\X509::saveCSR() * @see \phpseclib3\File\X509::saveCRL() * * Only works on CSRs. Not currently supported. */ const FORMAT_SPKAC = 2; /** * Auto-detect the format * * Used only by the load*() functions * * @see \phpseclib3\File\X509::saveX509() * @see \phpseclib3\File\X509::saveCSR() * @see \phpseclib3\File\X509::saveCRL() */ const FORMAT_AUTO_DETECT = 3; /** * Attribute value disposition. * If disposition is >= 0, this is the index of the target value. */ const ATTR_ALL = -1; // All attribute values (array). const ATTR_APPEND = -2; // Add a value. const ATTR_REPLACE = -3; // Clear first, then add a value. /** * Distinguished Name * * @var array */ private $dn; /** * Public key * * @var string|PublicKey */ private $publicKey; /** * Private key * * @var string|PrivateKey */ private $privateKey; /** * The certificate authorities * * @var array */ private $CAs = []; /** * The currently loaded certificate * * @var array */ private $currentCert; /** * The signature subject * * There's no guarantee \phpseclib3\File\X509 is going to re-encode an X.509 cert in the same way it was originally * encoded so we take save the portion of the original cert that the signature would have made for. * * @var string */ private $signatureSubject; /** * Certificate Start Date * * @var string */ private $startDate; /** * Certificate End Date * * @var string|Element */ private $endDate; /** * Serial Number * * @var string */ private $serialNumber; /** * Key Identifier * * See {@link http://tools.ietf.org/html/rfc5280#section-4.2.1.1 RFC5280#section-4.2.1.1} and * {@link http://tools.ietf.org/html/rfc5280#section-4.2.1.2 RFC5280#section-4.2.1.2}. * * @var string */ private $currentKeyIdentifier; /** * CA Flag * * @var bool */ private $caFlag = false; /** * SPKAC Challenge * * @var string */ private $challenge; /** * @var array */ private $extensionValues = []; /** * OIDs loaded * * @var bool */ private static $oidsLoaded = false; /** * Recursion Limit * * @var int */ private static $recur_limit = 5; /** * URL fetch flag * * @var bool */ private static $disable_url_fetch = false; /** * @var array */ private static $extensions = []; /** * @var ?array */ private $ipAddresses = null; /** * @var ?array */ private $domains = null; /** * Default Constructor. * * @return X509 */ public function __construct() { // Explicitly Tagged Module, 1988 Syntax // http://tools.ietf.org/html/rfc5280#appendix-A.1 if (!self::$oidsLoaded) { // OIDs from RFC5280 and those RFCs mentioned in RFC5280#section-4.1.1.2 ASN1::loadOIDs([ //'id-pkix' => '1.3.6.1.5.5.7', //'id-pe' => '1.3.6.1.5.5.7.1', //'id-qt' => '1.3.6.1.5.5.7.2', //'id-kp' => '1.3.6.1.5.5.7.3', //'id-ad' => '1.3.6.1.5.5.7.48', 'id-qt-cps' => '1.3.6.1.5.5.7.2.1', 'id-qt-unotice' => '1.3.6.1.5.5.7.2.2', 'id-ad-ocsp' => '1.3.6.1.5.5.7.48.1', 'id-ad-caIssuers' => '1.3.6.1.5.5.7.48.2', 'id-ad-timeStamping' => '1.3.6.1.5.5.7.48.3', 'id-ad-caRepository' => '1.3.6.1.5.5.7.48.5', //'id-at' => '2.5.4', 'id-at-name' => '2.5.4.41', 'id-at-surname' => '2.5.4.4', 'id-at-givenName' => '2.5.4.42', 'id-at-initials' => '2.5.4.43', 'id-at-generationQualifier' => '2.5.4.44', 'id-at-commonName' => '2.5.4.3', 'id-at-localityName' => '2.5.4.7', 'id-at-stateOrProvinceName' => '2.5.4.8', 'id-at-organizationName' => '2.5.4.10', 'id-at-organizationalUnitName' => '2.5.4.11', 'id-at-title' => '2.5.4.12', 'id-at-description' => '2.5.4.13', 'id-at-dnQualifier' => '2.5.4.46', 'id-at-countryName' => '2.5.4.6', 'id-at-serialNumber' => '2.5.4.5', 'id-at-pseudonym' => '2.5.4.65', 'id-at-postalCode' => '2.5.4.17', 'id-at-streetAddress' => '2.5.4.9', 'id-at-uniqueIdentifier' => '2.5.4.45', 'id-at-role' => '2.5.4.72', 'id-at-postalAddress' => '2.5.4.16', 'jurisdictionOfIncorporationCountryName' => '1.3.6.1.4.1.311.60.2.1.3', 'jurisdictionOfIncorporationStateOrProvinceName' => '1.3.6.1.4.1.311.60.2.1.2', 'jurisdictionLocalityName' => '1.3.6.1.4.1.311.60.2.1.1', 'id-at-businessCategory' => '2.5.4.15', //'id-domainComponent' => '0.9.2342.19200300.100.1.25', //'pkcs-9' => '1.2.840.113549.1.9', 'pkcs-9-at-emailAddress' => '1.2.840.113549.1.9.1', //'id-ce' => '2.5.29', 'id-ce-authorityKeyIdentifier' => '2.5.29.35', 'id-ce-subjectKeyIdentifier' => '2.5.29.14', 'id-ce-keyUsage' => '2.5.29.15', 'id-ce-privateKeyUsagePeriod' => '2.5.29.16', 'id-ce-certificatePolicies' => '2.5.29.32', //'anyPolicy' => '2.5.29.32.0', 'id-ce-policyMappings' => '2.5.29.33', 'id-ce-subjectAltName' => '2.5.29.17', 'id-ce-issuerAltName' => '2.5.29.18', 'id-ce-subjectDirectoryAttributes' => '2.5.29.9', 'id-ce-basicConstraints' => '2.5.29.19', 'id-ce-nameConstraints' => '2.5.29.30', 'id-ce-policyConstraints' => '2.5.29.36', 'id-ce-cRLDistributionPoints' => '2.5.29.31', 'id-ce-extKeyUsage' => '2.5.29.37', //'anyExtendedKeyUsage' => '2.5.29.37.0', 'id-kp-serverAuth' => '1.3.6.1.5.5.7.3.1', 'id-kp-clientAuth' => '1.3.6.1.5.5.7.3.2', 'id-kp-codeSigning' => '1.3.6.1.5.5.7.3.3', 'id-kp-emailProtection' => '1.3.6.1.5.5.7.3.4', 'id-kp-timeStamping' => '1.3.6.1.5.5.7.3.8', 'id-kp-OCSPSigning' => '1.3.6.1.5.5.7.3.9', 'id-ce-inhibitAnyPolicy' => '2.5.29.54', 'id-ce-freshestCRL' => '2.5.29.46', 'id-pe-authorityInfoAccess' => '1.3.6.1.5.5.7.1.1', 'id-pe-subjectInfoAccess' => '1.3.6.1.5.5.7.1.11', 'id-ce-cRLNumber' => '2.5.29.20', 'id-ce-issuingDistributionPoint' => '2.5.29.28', 'id-ce-deltaCRLIndicator' => '2.5.29.27', 'id-ce-cRLReasons' => '2.5.29.21', 'id-ce-certificateIssuer' => '2.5.29.29', 'id-ce-holdInstructionCode' => '2.5.29.23', //'holdInstruction' => '1.2.840.10040.2', 'id-holdinstruction-none' => '1.2.840.10040.2.1', 'id-holdinstruction-callissuer' => '1.2.840.10040.2.2', 'id-holdinstruction-reject' => '1.2.840.10040.2.3', 'id-ce-invalidityDate' => '2.5.29.24', 'rsaEncryption' => '1.2.840.113549.1.1.1', 'md2WithRSAEncryption' => '1.2.840.113549.1.1.2', 'md5WithRSAEncryption' => '1.2.840.113549.1.1.4', 'sha1WithRSAEncryption' => '1.2.840.113549.1.1.5', 'sha224WithRSAEncryption' => '1.2.840.113549.1.1.14', 'sha256WithRSAEncryption' => '1.2.840.113549.1.1.11', 'sha384WithRSAEncryption' => '1.2.840.113549.1.1.12', 'sha512WithRSAEncryption' => '1.2.840.113549.1.1.13', 'id-ecPublicKey' => '1.2.840.10045.2.1', 'ecdsa-with-SHA1' => '1.2.840.10045.4.1', // from https://tools.ietf.org/html/rfc5758#section-3.2 'ecdsa-with-SHA224' => '1.2.840.10045.4.3.1', 'ecdsa-with-SHA256' => '1.2.840.10045.4.3.2', 'ecdsa-with-SHA384' => '1.2.840.10045.4.3.3', 'ecdsa-with-SHA512' => '1.2.840.10045.4.3.4', 'id-dsa' => '1.2.840.10040.4.1', 'id-dsa-with-sha1' => '1.2.840.10040.4.3', // from https://tools.ietf.org/html/rfc5758#section-3.1 'id-dsa-with-sha224' => '2.16.840.1.101.3.4.3.1', 'id-dsa-with-sha256' => '2.16.840.1.101.3.4.3.2', // from https://tools.ietf.org/html/rfc8410: 'id-Ed25519' => '1.3.101.112', 'id-Ed448' => '1.3.101.113', 'id-RSASSA-PSS' => '1.2.840.113549.1.1.10', //'id-sha224' => '2.16.840.1.101.3.4.2.4', //'id-sha256' => '2.16.840.1.101.3.4.2.1', //'id-sha384' => '2.16.840.1.101.3.4.2.2', //'id-sha512' => '2.16.840.1.101.3.4.2.3', //'id-GostR3411-94-with-GostR3410-94' => '1.2.643.2.2.4', //'id-GostR3411-94-with-GostR3410-2001' => '1.2.643.2.2.3', //'id-GostR3410-2001' => '1.2.643.2.2.20', //'id-GostR3410-94' => '1.2.643.2.2.19', // Netscape Object Identifiers from "Netscape Certificate Extensions" 'netscape' => '2.16.840.1.113730', 'netscape-cert-extension' => '2.16.840.1.113730.1', 'netscape-cert-type' => '2.16.840.1.113730.1.1', 'netscape-comment' => '2.16.840.1.113730.1.13', 'netscape-ca-policy-url' => '2.16.840.1.113730.1.8', // the following are X.509 extensions not supported by phpseclib 'id-pe-logotype' => '1.3.6.1.5.5.7.1.12', 'entrustVersInfo' => '1.2.840.113533.7.65.0', 'verisignPrivate' => '2.16.840.1.113733.1.6.9', // for Certificate Signing Requests // see http://tools.ietf.org/html/rfc2985 'pkcs-9-at-unstructuredName' => '1.2.840.113549.1.9.2', // PKCS #9 unstructured name 'pkcs-9-at-challengePassword' => '1.2.840.113549.1.9.7', // Challenge password for certificate revocations 'pkcs-9-at-extensionRequest' => '1.2.840.113549.1.9.14' // Certificate extension request ]); } } /** * Load X.509 certificate * * Returns an associative array describing the X.509 cert or a false if the cert failed to load * * @param array|string $cert * @param int $mode * @return mixed */ public function loadX509($cert, $mode = self::FORMAT_AUTO_DETECT) { if (is_array($cert) && isset($cert['tbsCertificate'])) { unset($this->currentCert); unset($this->currentKeyIdentifier); $this->dn = $cert['tbsCertificate']['subject']; if (!isset($this->dn)) { return false; } $this->currentCert = $cert; $currentKeyIdentifier = $this->getExtension('id-ce-subjectKeyIdentifier'); $this->currentKeyIdentifier = is_string($currentKeyIdentifier) ? $currentKeyIdentifier : null; unset($this->signatureSubject); return $cert; } if ($mode != self::FORMAT_DER) { $newcert = ASN1::extractBER($cert); if ($mode == self::FORMAT_PEM && $cert == $newcert) { return false; } $cert = $newcert; } if ($cert === false) { $this->currentCert = false; return false; } $decoded = ASN1::decodeBER($cert); if ($decoded) { $x509 = ASN1::asn1map($decoded[0], Maps\Certificate::MAP); } if (!isset($x509) || $x509 === false) { $this->currentCert = false; return false; } $this->signatureSubject = substr($cert, $decoded[0]['content'][0]['start'], $decoded[0]['content'][0]['length']); if ($this->isSubArrayValid($x509, 'tbsCertificate/extensions')) { $this->mapInExtensions($x509, 'tbsCertificate/extensions'); } $this->mapInDNs($x509, 'tbsCertificate/issuer/rdnSequence'); $this->mapInDNs($x509, 'tbsCertificate/subject/rdnSequence'); $key = $x509['tbsCertificate']['subjectPublicKeyInfo']; $key = ASN1::encodeDER($key, Maps\SubjectPublicKeyInfo::MAP); $x509['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey'] = "-----BEGIN PUBLIC KEY-----\r\n" . chunk_split(base64_encode($key), 64) . "-----END PUBLIC KEY-----"; $this->currentCert = $x509; $this->dn = $x509['tbsCertificate']['subject']; $currentKeyIdentifier = $this->getExtension('id-ce-subjectKeyIdentifier'); $this->currentKeyIdentifier = is_string($currentKeyIdentifier) ? $currentKeyIdentifier : null; return $x509; } /** * Save X.509 certificate * * @param array $cert * @param int $format optional * @return string */ public function saveX509(array $cert, $format = self::FORMAT_PEM) { if (!is_array($cert) || !isset($cert['tbsCertificate'])) { return false; } switch (true) { // "case !$a: case !$b: break; default: whatever();" is the same thing as "if ($a && $b) whatever()" case !($algorithm = $this->subArray($cert, 'tbsCertificate/subjectPublicKeyInfo/algorithm/algorithm')): case is_object($cert['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey']): break; default: $cert['tbsCertificate']['subjectPublicKeyInfo'] = new Element( base64_decode(preg_replace('#-.+-|[\r\n]#', '', $cert['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey'])) ); } if ($algorithm == 'rsaEncryption') { $cert['signatureAlgorithm']['parameters'] = null; $cert['tbsCertificate']['signature']['parameters'] = null; } $filters = []; $type_utf8_string = ['type' => ASN1::TYPE_UTF8_STRING]; $filters['tbsCertificate']['signature']['parameters'] = $type_utf8_string; $filters['tbsCertificate']['signature']['issuer']['rdnSequence']['value'] = $type_utf8_string; $filters['tbsCertificate']['issuer']['rdnSequence']['value'] = $type_utf8_string; $filters['tbsCertificate']['subject']['rdnSequence']['value'] = $type_utf8_string; $filters['tbsCertificate']['subjectPublicKeyInfo']['algorithm']['parameters'] = $type_utf8_string; $filters['signatureAlgorithm']['parameters'] = $type_utf8_string; $filters['authorityCertIssuer']['directoryName']['rdnSequence']['value'] = $type_utf8_string; //$filters['policyQualifiers']['qualifier'] = $type_utf8_string; $filters['distributionPoint']['fullName']['directoryName']['rdnSequence']['value'] = $type_utf8_string; $filters['directoryName']['rdnSequence']['value'] = $type_utf8_string; foreach (self::$extensions as $extension) { $filters['tbsCertificate']['extensions'][] = $extension; } /* in the case of policyQualifiers/qualifier, the type has to be \phpseclib3\File\ASN1::TYPE_IA5_STRING. \phpseclib3\File\ASN1::TYPE_PRINTABLE_STRING will cause OpenSSL's X.509 parser to spit out random characters. */ $filters['policyQualifiers']['qualifier'] = ['type' => ASN1::TYPE_IA5_STRING]; ASN1::setFilters($filters); $this->mapOutExtensions($cert, 'tbsCertificate/extensions'); $this->mapOutDNs($cert, 'tbsCertificate/issuer/rdnSequence'); $this->mapOutDNs($cert, 'tbsCertificate/subject/rdnSequence'); $cert = ASN1::encodeDER($cert, Maps\Certificate::MAP); switch ($format) { case self::FORMAT_DER: return $cert; // case self::FORMAT_PEM: default: return "-----BEGIN CERTIFICATE-----\r\n" . chunk_split(Strings::base64_encode($cert), 64) . '-----END CERTIFICATE-----'; } } /** * Map extension values from octet string to extension-specific internal * format. * * @param array $root (by reference) * @param string $path */ private function mapInExtensions(array &$root, $path) { $extensions = &$this->subArrayUnchecked($root, $path); if ($extensions) { for ($i = 0; $i < count($extensions); $i++) { $id = $extensions[$i]['extnId']; $value = &$extensions[$i]['extnValue']; /* [extnValue] contains the DER encoding of an ASN.1 value corresponding to the extension type identified by extnID */ $map = $this->getMapping($id); if (!is_bool($map)) { $decoder = $id == 'id-ce-nameConstraints' ? [static::class, 'decodeNameConstraintIP'] : [static::class, 'decodeIP']; $decoded = ASN1::decodeBER($value); if (!$decoded) { continue; } $mapped = ASN1::asn1map($decoded[0], $map, ['iPAddress' => $decoder]); $value = $mapped === false ? $decoded[0] : $mapped; if ($id == 'id-ce-certificatePolicies') { for ($j = 0; $j < count($value); $j++) { if (!isset($value[$j]['policyQualifiers'])) { continue; } for ($k = 0; $k < count($value[$j]['policyQualifiers']); $k++) { $subid = $value[$j]['policyQualifiers'][$k]['policyQualifierId']; $map = $this->getMapping($subid); $subvalue = &$value[$j]['policyQualifiers'][$k]['qualifier']; if ($map !== false) { $decoded = ASN1::decodeBER($subvalue); if (!$decoded) { continue; } $mapped = ASN1::asn1map($decoded[0], $map); $subvalue = $mapped === false ? $decoded[0] : $mapped; } } } } } } } } /** * Map extension values from extension-specific internal format to * octet string. * * @param array $root (by reference) * @param string $path */ private function mapOutExtensions(array &$root, $path) { $extensions = &$this->subArray($root, $path, !empty($this->extensionValues)); foreach ($this->extensionValues as $id => $data) { extract($data); $newext = [ 'extnId' => $id, 'extnValue' => $value, 'critical' => $critical ]; if ($replace) { foreach ($extensions as $key => $value) { if ($value['extnId'] == $id) { $extensions[$key] = $newext; continue 2; } } } $extensions[] = $newext; } if (is_array($extensions)) { $size = count($extensions); for ($i = 0; $i < $size; $i++) { if ($extensions[$i] instanceof Element) { continue; } $id = $extensions[$i]['extnId']; $value = &$extensions[$i]['extnValue']; switch ($id) { case 'id-ce-certificatePolicies': for ($j = 0; $j < count($value); $j++) { if (!isset($value[$j]['policyQualifiers'])) { continue; } for ($k = 0; $k < count($value[$j]['policyQualifiers']); $k++) { $subid = $value[$j]['policyQualifiers'][$k]['policyQualifierId']; $map = $this->getMapping($subid); $subvalue = &$value[$j]['policyQualifiers'][$k]['qualifier']; if ($map !== false) { // by default \phpseclib3\File\ASN1 will try to render qualifier as a \phpseclib3\File\ASN1::TYPE_IA5_STRING since it's // actual type is \phpseclib3\File\ASN1::TYPE_ANY $subvalue = new Element(ASN1::encodeDER($subvalue, $map)); } } } break; case 'id-ce-authorityKeyIdentifier': // use 00 as the serial number instead of an empty string if (isset($value['authorityCertSerialNumber'])) { if ($value['authorityCertSerialNumber']->toBytes() == '') { $temp = chr((ASN1::CLASS_CONTEXT_SPECIFIC << 6) | 2) . "\1\0"; $value['authorityCertSerialNumber'] = new Element($temp); } } } /* [extnValue] contains the DER encoding of an ASN.1 value corresponding to the extension type identified by extnID */ $map = $this->getMapping($id); if (is_bool($map)) { if (!$map) { //user_error($id . ' is not a currently supported extension'); unset($extensions[$i]); } } else { $value = ASN1::encodeDER($value, $map, ['iPAddress' => [static::class, 'encodeIP']]); } } } } /** * Map attribute values from ANY type to attribute-specific internal * format. * * @param array $root (by reference) * @param string $path */ private function mapInAttributes(&$root, $path) { $attributes = &$this->subArray($root, $path); if (is_array($attributes)) { for ($i = 0; $i < count($attributes); $i++) { $id = $attributes[$i]['type']; /* $value contains the DER encoding of an ASN.1 value corresponding to the attribute type identified by type */ $map = $this->getMapping($id); if (is_array($attributes[$i]['value'])) { $values = &$attributes[$i]['value']; for ($j = 0; $j < count($values); $j++) { $value = ASN1::encodeDER($values[$j], Maps\AttributeValue::MAP); $decoded = ASN1::decodeBER($value); if (!is_bool($map)) { if (!$decoded) { continue; } $mapped = ASN1::asn1map($decoded[0], $map); if ($mapped !== false) { $values[$j] = $mapped; } if ($id == 'pkcs-9-at-extensionRequest' && $this->isSubArrayValid($values, $j)) { $this->mapInExtensions($values, $j); } } elseif ($map) { $values[$j] = $value; } } } } } } /** * Map attribute values from attribute-specific internal format to * ANY type. * * @param array $root (by reference) * @param string $path */ private function mapOutAttributes(&$root, $path) { $attributes = &$this->subArray($root, $path); if (is_array($attributes)) { $size = count($attributes); for ($i = 0; $i < $size; $i++) { /* [value] contains the DER encoding of an ASN.1 value corresponding to the attribute type identified by type */ $id = $attributes[$i]['type']; $map = $this->getMapping($id); if ($map === false) { //user_error($id . ' is not a currently supported attribute', E_USER_NOTICE); unset($attributes[$i]); } elseif (is_array($attributes[$i]['value'])) { $values = &$attributes[$i]['value']; for ($j = 0; $j < count($values); $j++) { switch ($id) { case 'pkcs-9-at-extensionRequest': $this->mapOutExtensions($values, $j); break; } if (!is_bool($map)) { $temp = ASN1::encodeDER($values[$j], $map); $decoded = ASN1::decodeBER($temp); if (!$decoded) { continue; } $values[$j] = ASN1::asn1map($decoded[0], Maps\AttributeValue::MAP); } } } } } } /** * Map DN values from ANY type to DN-specific internal * format. * * @param array $root (by reference) * @param string $path */ private function mapInDNs(array &$root, $path) { $dns = &$this->subArray($root, $path); if (is_array($dns)) { for ($i = 0; $i < count($dns); $i++) { for ($j = 0; $j < count($dns[$i]); $j++) { $type = $dns[$i][$j]['type']; $value = &$dns[$i][$j]['value']; if (is_object($value) && $value instanceof Element) { $map = $this->getMapping($type); if (!is_bool($map)) { $decoded = ASN1::decodeBER($value); if (!$decoded) { continue; } $value = ASN1::asn1map($decoded[0], $map); } } } } } } /** * Map DN values from DN-specific internal format to * ANY type. * * @param array $root (by reference) * @param string $path */ private function mapOutDNs(array &$root, $path) { $dns = &$this->subArray($root, $path); if (is_array($dns)) { $size = count($dns); for ($i = 0; $i < $size; $i++) { for ($j = 0; $j < count($dns[$i]); $j++) { $type = $dns[$i][$j]['type']; $value = &$dns[$i][$j]['value']; if (is_object($value) && $value instanceof Element) { continue; } $map = $this->getMapping($type); if (!is_bool($map)) { $value = new Element(ASN1::encodeDER($value, $map)); } } } } } /** * Associate an extension ID to an extension mapping * * @param string $extnId * @return mixed */ private function getMapping($extnId) { if (!is_string($extnId)) { // eg. if it's a \phpseclib3\File\ASN1\Element object return true; } if (isset(self::$extensions[$extnId])) { return self::$extensions[$extnId]; } switch ($extnId) { case 'id-ce-keyUsage': return Maps\KeyUsage::MAP; case 'id-ce-basicConstraints': return Maps\BasicConstraints::MAP; case 'id-ce-subjectKeyIdentifier': return Maps\KeyIdentifier::MAP; case 'id-ce-cRLDistributionPoints': return Maps\CRLDistributionPoints::MAP; case 'id-ce-authorityKeyIdentifier': return Maps\AuthorityKeyIdentifier::MAP; case 'id-ce-certificatePolicies': return Maps\CertificatePolicies::MAP; case 'id-ce-extKeyUsage': return Maps\ExtKeyUsageSyntax::MAP; case 'id-pe-authorityInfoAccess': return Maps\AuthorityInfoAccessSyntax::MAP; case 'id-ce-subjectAltName': return Maps\SubjectAltName::MAP; case 'id-ce-subjectDirectoryAttributes': return Maps\SubjectDirectoryAttributes::MAP; case 'id-ce-privateKeyUsagePeriod': return Maps\PrivateKeyUsagePeriod::MAP; case 'id-ce-issuerAltName': return Maps\IssuerAltName::MAP; case 'id-ce-policyMappings': return Maps\PolicyMappings::MAP; case 'id-ce-nameConstraints': return Maps\NameConstraints::MAP; case 'netscape-cert-type': return Maps\netscape_cert_type::MAP; case 'netscape-comment': return Maps\netscape_comment::MAP; case 'netscape-ca-policy-url': return Maps\netscape_ca_policy_url::MAP; // since id-qt-cps isn't a constructed type it will have already been decoded as a string by the time it gets // back around to asn1map() and we don't want it decoded again. //case 'id-qt-cps': // return Maps\CPSuri::MAP; case 'id-qt-unotice': return Maps\UserNotice::MAP; // the following OIDs are unsupported but we don't want them to give notices when calling saveX509(). case 'id-pe-logotype': // http://www.ietf.org/rfc/rfc3709.txt case 'entrustVersInfo': // http://support.microsoft.com/kb/287547 case '1.3.6.1.4.1.311.20.2': // szOID_ENROLL_CERTTYPE_EXTENSION case '1.3.6.1.4.1.311.21.1': // szOID_CERTSRV_CA_VERSION // "SET Secure Electronic Transaction Specification" // http://www.maithean.com/docs/set_bk3.pdf case '2.23.42.7.0': // id-set-hashedRootKey // "Certificate Transparency" // https://tools.ietf.org/html/rfc6962 case '1.3.6.1.4.1.11129.2.4.2': // "Qualified Certificate statements" // https://tools.ietf.org/html/rfc3739#section-3.2.6 case '1.3.6.1.5.5.7.1.3': return true; // CSR attributes case 'pkcs-9-at-unstructuredName': return Maps\PKCS9String::MAP; case 'pkcs-9-at-challengePassword': return Maps\DirectoryString::MAP; case 'pkcs-9-at-extensionRequest': return Maps\Extensions::MAP; // CRL extensions. case 'id-ce-cRLNumber': return Maps\CRLNumber::MAP; case 'id-ce-deltaCRLIndicator': return Maps\CRLNumber::MAP; case 'id-ce-issuingDistributionPoint': return Maps\IssuingDistributionPoint::MAP; case 'id-ce-freshestCRL': return Maps\CRLDistributionPoints::MAP; case 'id-ce-cRLReasons': return Maps\CRLReason::MAP; case 'id-ce-invalidityDate': return Maps\InvalidityDate::MAP; case 'id-ce-certificateIssuer': return Maps\CertificateIssuer::MAP; case 'id-ce-holdInstructionCode': return Maps\HoldInstructionCode::MAP; case 'id-at-postalAddress': return Maps\PostalAddress::MAP; } return false; } /** * Load an X.509 certificate as a certificate authority * * @param string $cert * @return bool */ public function loadCA($cert) { $olddn = $this->dn; $oldcert = $this->currentCert; $oldsigsubj = $this->signatureSubject; $oldkeyid = $this->currentKeyIdentifier; $cert = $this->loadX509($cert); if (!$cert) { $this->dn = $olddn; $this->currentCert = $oldcert; $this->signatureSubject = $oldsigsubj; $this->currentKeyIdentifier = $oldkeyid; return false; } /* From RFC5280 "PKIX Certificate and CRL Profile": If the keyUsage extension is present, then the subject public key MUST NOT be used to verify signatures on certificates or CRLs unless the corresponding keyCertSign or cRLSign bit is set. */ //$keyUsage = $this->getExtension('id-ce-keyUsage'); //if ($keyUsage && !in_array('keyCertSign', $keyUsage)) { // return false; //} /* From RFC5280 "PKIX Certificate and CRL Profile": The cA boolean indicates whether the certified public key may be used to verify certificate signatures. If the cA boolean is not asserted, then the keyCertSign bit in the key usage extension MUST NOT be asserted. If the basic constraints extension is not present in a version 3 certificate, or the extension is present but the cA boolean is not asserted, then the certified public key MUST NOT be used to verify certificate signatures. */ //$basicConstraints = $this->getExtension('id-ce-basicConstraints'); //if (!$basicConstraints || !$basicConstraints['cA']) { // return false; //} $this->CAs[] = $cert; $this->dn = $olddn; $this->currentCert = $oldcert; $this->signatureSubject = $oldsigsubj; return true; } /** * Validate an X.509 certificate against a URL * * From RFC2818 "HTTP over TLS": * * Matching is performed using the matching rules specified by * [RFC2459]. If more than one identity of a given type is present in * the certificate (e.g., more than one dNSName name, a match in any one * of the set is considered acceptable.) Names may contain the wildcard * character * which is considered to match any single domain name * component or component fragment. E.g., *.a.com matches foo.a.com but * not bar.foo.a.com. f*.com matches foo.com but not bar.com. * * @param string $url * @return bool */ public function validateURL($url) { if (!is_array($this->currentCert) || !isset($this->currentCert['tbsCertificate'])) { return false; } $components = parse_url($url); if (!isset($components['host'])) { return false; } if ($names = $this->getExtension('id-ce-subjectAltName')) { foreach ($names as $name) { foreach ($name as $key => $value) { $value = preg_quote($value); $value = str_replace('\*', '[^.]*', $value); switch ($key) { case 'dNSName': /* From RFC2818 "HTTP over TLS": If a subjectAltName extension of type dNSName is present, that MUST be used as the identity. Otherwise, the (most specific) Common Name field in the Subject field of the certificate MUST be used. Although the use of the Common Name is existing practice, it is deprecated and Certification Authorities are encouraged to use the dNSName instead. */ if (preg_match('#^' . $value . '$#', $components['host'])) { return true; } break; case 'iPAddress': /* From RFC2818 "HTTP over TLS": In some cases, the URI is specified as an IP address rather than a hostname. In this case, the iPAddress subjectAltName must be present in the certificate and must exactly match the IP in the URI. */ if (preg_match('#(?:\d{1-3}\.){4}#', $components['host'] . '.') && preg_match('#^' . $value . '$#', $components['host'])) { return true; } } } } return false; } if ($value = $this->getDNProp('id-at-commonName')) { $value = str_replace(['.', '*'], ['\.', '[^.]*'], $value[0]); return preg_match('#^' . $value . '$#', $components['host']) === 1; } return false; } /** * Validate a date * * If $date isn't defined it is assumed to be the current date. * * @param \DateTimeInterface|string $date optional * @return bool */ public function validateDate($date = null) { if (!is_array($this->currentCert) || !isset($this->currentCert['tbsCertificate'])) { return false; } if (!isset($date)) { $date = new \DateTimeImmutable('now', new \DateTimeZone(@date_default_timezone_get())); } $notBefore = $this->currentCert['tbsCertificate']['validity']['notBefore']; $notBefore = isset($notBefore['generalTime']) ? $notBefore['generalTime'] : $notBefore['utcTime']; $notAfter = $this->currentCert['tbsCertificate']['validity']['notAfter']; $notAfter = isset($notAfter['generalTime']) ? $notAfter['generalTime'] : $notAfter['utcTime']; if (is_string($date)) { $date = new \DateTimeImmutable($date, new \DateTimeZone(@date_default_timezone_get())); } $notBefore = new \DateTimeImmutable($notBefore, new \DateTimeZone(@date_default_timezone_get())); $notAfter = new \DateTimeImmutable($notAfter, new \DateTimeZone(@date_default_timezone_get())); return $date >= $notBefore && $date <= $notAfter; } /** * Fetches a URL * * @param string $url * @return bool|string */ private static function fetchURL($url) { if (self::$disable_url_fetch) { return false; } $parts = parse_url($url); $data = ''; switch ($parts['scheme']) { case 'http': $fsock = @fsockopen($parts['host'], isset($parts['port']) ? $parts['port'] : 80); if (!$fsock) { return false; } $path = $parts['path']; if (isset($parts['query'])) { $path .= '?' . $parts['query']; } fputs($fsock, "GET $path HTTP/1.0\r\n"); fputs($fsock, "Host: $parts[host]\r\n\r\n"); $line = fgets($fsock, 1024); if (strlen($line) < 3) { return false; } preg_match('#HTTP/1.\d (\d{3})#', $line, $temp); if ($temp[1] != '200') { return false; } // skip the rest of the headers in the http response while (!feof($fsock) && fgets($fsock, 1024) != "\r\n") { } while (!feof($fsock)) { $temp = fread($fsock, 1024); if ($temp === false) { return false; } $data .= $temp; } break; //case 'ftp': //case 'ldap': //default: } return $data; } /** * Validates an intermediate cert as identified via authority info access extension * * See https://tools.ietf.org/html/rfc4325 for more info * * @param bool $caonly * @param int $count * @return bool */ private function testForIntermediate($caonly, $count) { $opts = $this->getExtension('id-pe-authorityInfoAccess'); if (!is_array($opts)) { return false; } foreach ($opts as $opt) { if ($opt['accessMethod'] == 'id-ad-caIssuers') { // accessLocation is a GeneralName. GeneralName fields support stuff like email addresses, IP addresses, LDAP, // etc, but we're only supporting URI's. URI's and LDAP are the only thing https://tools.ietf.org/html/rfc4325 // discusses if (isset($opt['accessLocation']['uniformResourceIdentifier'])) { $url = $opt['accessLocation']['uniformResourceIdentifier']; break; } } } if (!isset($url)) { return false; } $cert = static::fetchURL($url); if (!is_string($cert)) { return false; } $parent = new static(); $parent->CAs = $this->CAs; /* "Conforming applications that support HTTP or FTP for accessing certificates MUST be able to accept .cer files and SHOULD be able to accept .p7c files." -- https://tools.ietf.org/html/rfc4325 A .p7c file is 'a "certs-only" CMS message as specified in RFC 2797" These are currently unsupported */ if (!is_array($parent->loadX509($cert))) { return false; } if (!$parent->validateSignatureCountable($caonly, ++$count)) { return false; } $this->CAs[] = $parent->currentCert; //$this->loadCA($cert); return true; } /** * Validate a signature * * Works on X.509 certs, CSR's and CRL's. * Returns true if the signature is verified, false if it is not correct or null on error * * By default returns false for self-signed certs. Call validateSignature(false) to make this support * self-signed. * * The behavior of this function is inspired by {@link http://php.net/openssl-verify openssl_verify}. * * @param bool $caonly optional * @return mixed */ public function validateSignature($caonly = true) { return $this->validateSignatureCountable($caonly, 0); } /** * Validate a signature * * Performs said validation whilst keeping track of how many times validation method is called * * @param bool $caonly * @param int $count * @return mixed */ private function validateSignatureCountable($caonly, $count) { if (!is_array($this->currentCert) || !isset($this->signatureSubject)) { return null; } if ($count == self::$recur_limit) { return false; } /* TODO: "emailAddress attribute values are not case-sensitive (e.g., "subscriber@example.com" is the same as "SUBSCRIBER@EXAMPLE.COM")." -- http://tools.ietf.org/html/rfc5280#section-4.1.2.6 implement pathLenConstraint in the id-ce-basicConstraints extension */ switch (true) { case isset($this->currentCert['tbsCertificate']): // self-signed cert switch (true) { case !defined('FILE_X509_IGNORE_TYPE') && $this->currentCert['tbsCertificate']['issuer'] === $this->currentCert['tbsCertificate']['subject']: case defined('FILE_X509_IGNORE_TYPE') && $this->getIssuerDN(self::DN_STRING) === $this->getDN(self::DN_STRING): $authorityKey = $this->getExtension('id-ce-authorityKeyIdentifier'); $subjectKeyID = $this->getExtension('id-ce-subjectKeyIdentifier'); switch (true) { case !is_array($authorityKey): case !$subjectKeyID: case isset($authorityKey['keyIdentifier']) && $authorityKey['keyIdentifier'] === $subjectKeyID: $signingCert = $this->currentCert; // working cert } } if (!empty($this->CAs)) { for ($i = 0; $i < count($this->CAs); $i++) { // even if the cert is a self-signed one we still want to see if it's a CA; // if not, we'll conditionally return an error $ca = $this->CAs[$i]; switch (true) { case !defined('FILE_X509_IGNORE_TYPE') && $this->currentCert['tbsCertificate']['issuer'] === $ca['tbsCertificate']['subject']: case defined('FILE_X509_IGNORE_TYPE') && $this->getDN(self::DN_STRING, $this->currentCert['tbsCertificate']['issuer']) === $this->getDN(self::DN_STRING, $ca['tbsCertificate']['subject']): $authorityKey = $this->getExtension('id-ce-authorityKeyIdentifier'); $subjectKeyID = $this->getExtension('id-ce-subjectKeyIdentifier', $ca); switch (true) { case !is_array($authorityKey): case !$subjectKeyID: case isset($authorityKey['keyIdentifier']) && $authorityKey['keyIdentifier'] === $subjectKeyID: if (is_array($authorityKey) && isset($authorityKey['authorityCertSerialNumber']) && !$authorityKey['authorityCertSerialNumber']->equals($ca['tbsCertificate']['serialNumber'])) { break 2; // serial mismatch - check other ca } $signingCert = $ca; // working cert break 3; } } } if (count($this->CAs) == $i && $caonly) { return $this->testForIntermediate($caonly, $count) && $this->validateSignature($caonly); } } elseif (!isset($signingCert) || $caonly) { return $this->testForIntermediate($caonly, $count) && $this->validateSignature($caonly); } return $this->validateSignatureHelper( $signingCert['tbsCertificate']['subjectPublicKeyInfo']['algorithm']['algorithm'], $signingCert['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey'], $this->currentCert['signatureAlgorithm']['algorithm'], substr($this->currentCert['signature'], 1), $this->signatureSubject ); case isset($this->currentCert['certificationRequestInfo']): return $this->validateSignatureHelper( $this->currentCert['certificationRequestInfo']['subjectPKInfo']['algorithm']['algorithm'], $this->currentCert['certificationRequestInfo']['subjectPKInfo']['subjectPublicKey'], $this->currentCert['signatureAlgorithm']['algorithm'], substr($this->currentCert['signature'], 1), $this->signatureSubject ); case isset($this->currentCert['publicKeyAndChallenge']): return $this->validateSignatureHelper( $this->currentCert['publicKeyAndChallenge']['spki']['algorithm']['algorithm'], $this->currentCert['publicKeyAndChallenge']['spki']['subjectPublicKey'], $this->currentCert['signatureAlgorithm']['algorithm'], substr($this->currentCert['signature'], 1), $this->signatureSubject ); case isset($this->currentCert['tbsCertList']): if (!empty($this->CAs)) { for ($i = 0; $i < count($this->CAs); $i++) { $ca = $this->CAs[$i]; switch (true) { case !defined('FILE_X509_IGNORE_TYPE') && $this->currentCert['tbsCertList']['issuer'] === $ca['tbsCertificate']['subject']: case defined('FILE_X509_IGNORE_TYPE') && $this->getDN(self::DN_STRING, $this->currentCert['tbsCertList']['issuer']) === $this->getDN(self::DN_STRING, $ca['tbsCertificate']['subject']): $authorityKey = $this->getExtension('id-ce-authorityKeyIdentifier'); $subjectKeyID = $this->getExtension('id-ce-subjectKeyIdentifier', $ca); switch (true) { case !is_array($authorityKey): case !$subjectKeyID: case isset($authorityKey['keyIdentifier']) && $authorityKey['keyIdentifier'] === $subjectKeyID: if (is_array($authorityKey) && isset($authorityKey['authorityCertSerialNumber']) && !$authorityKey['authorityCertSerialNumber']->equals($ca['tbsCertificate']['serialNumber'])) { break 2; // serial mismatch - check other ca } $signingCert = $ca; // working cert break 3; } } } } if (!isset($signingCert)) { return false; } return $this->validateSignatureHelper( $signingCert['tbsCertificate']['subjectPublicKeyInfo']['algorithm']['algorithm'], $signingCert['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey'], $this->currentCert['signatureAlgorithm']['algorithm'], substr($this->currentCert['signature'], 1), $this->signatureSubject ); default: return false; } } /** * Validates a signature * * Returns true if the signature is verified and false if it is not correct. * If the algorithms are unsupposed an exception is thrown. * * @param string $publicKeyAlgorithm * @param string $publicKey * @param string $signatureAlgorithm * @param string $signature * @param string $signatureSubject * @throws UnsupportedAlgorithmException if the algorithm is unsupported * @return bool */ private function validateSignatureHelper($publicKeyAlgorithm, $publicKey, $signatureAlgorithm, $signature, $signatureSubject) { switch ($publicKeyAlgorithm) { case 'id-RSASSA-PSS': $key = RSA::loadFormat('PSS', $publicKey); break; case 'rsaEncryption': $key = RSA::loadFormat('PKCS8', $publicKey); switch ($signatureAlgorithm) { case 'id-RSASSA-PSS': break; case 'md2WithRSAEncryption': case 'md5WithRSAEncryption': case 'sha1WithRSAEncryption': case 'sha224WithRSAEncryption': case 'sha256WithRSAEncryption': case 'sha384WithRSAEncryption': case 'sha512WithRSAEncryption': $key = $key ->withHash(preg_replace('#WithRSAEncryption$#', '', $signatureAlgorithm)) ->withPadding(RSA::SIGNATURE_PKCS1); break; default: throw new UnsupportedAlgorithmException('Signature algorithm unsupported'); } break; case 'id-Ed25519': case 'id-Ed448': $key = EC::loadFormat('PKCS8', $publicKey); break; case 'id-ecPublicKey': $key = EC::loadFormat('PKCS8', $publicKey); switch ($signatureAlgorithm) { case 'ecdsa-with-SHA1': case 'ecdsa-with-SHA224': case 'ecdsa-with-SHA256': case 'ecdsa-with-SHA384': case 'ecdsa-with-SHA512': $key = $key ->withHash(preg_replace('#^ecdsa-with-#', '', strtolower($signatureAlgorithm))); break; default: throw new UnsupportedAlgorithmException('Signature algorithm unsupported'); } break; case 'id-dsa': $key = DSA::loadFormat('PKCS8', $publicKey); switch ($signatureAlgorithm) { case 'id-dsa-with-sha1': case 'id-dsa-with-sha224': case 'id-dsa-with-sha256': $key = $key ->withHash(preg_replace('#^id-dsa-with-#', '', strtolower($signatureAlgorithm))); break; default: throw new UnsupportedAlgorithmException('Signature algorithm unsupported'); } break; default: throw new UnsupportedAlgorithmException('Public key algorithm unsupported'); } return $key->verify($signatureSubject, $signature); } /** * Sets the recursion limit * * When validating a signature it may be necessary to download intermediate certs from URI's. * An intermediate cert that linked to itself would result in an infinite loop so to prevent * that we set a recursion limit. A negative number means that there is no recursion limit. * * @param int $count */ public static function setRecurLimit($count) { self::$recur_limit = $count; } /** * Prevents URIs from being automatically retrieved * */ public static function disableURLFetch() { self::$disable_url_fetch = true; } /** * Allows URIs to be automatically retrieved * */ public static function enableURLFetch() { self::$disable_url_fetch = false; } /** * Decodes an IP address * * Takes in a base64 encoded "blob" and returns a human readable IP address * * @param string $ip * @return string */ public static function decodeIP($ip) { return inet_ntop($ip); } /** * Decodes an IP address in a name constraints extension * * Takes in a base64 encoded "blob" and returns a human readable IP address / mask * * @param string $ip * @return array */ public static function decodeNameConstraintIP($ip) { $size = strlen($ip) >> 1; $mask = substr($ip, $size); $ip = substr($ip, 0, $size); return [inet_ntop($ip), inet_ntop($mask)]; } /** * Encodes an IP address * * Takes a human readable IP address into a base64-encoded "blob" * * @param string|array $ip * @return string */ public static function encodeIP($ip) { return is_string($ip) ? inet_pton($ip) : inet_pton($ip[0]) . inet_pton($ip[1]); } /** * "Normalizes" a Distinguished Name property * * @param string $propName * @return mixed */ private function translateDNProp($propName) { switch (strtolower($propName)) { case 'jurisdictionofincorporationcountryname': case 'jurisdictioncountryname': case 'jurisdictionc': return 'jurisdictionOfIncorporationCountryName'; case 'jurisdictionofincorporationstateorprovincename': case 'jurisdictionstateorprovincename': case 'jurisdictionst': return 'jurisdictionOfIncorporationStateOrProvinceName'; case 'jurisdictionlocalityname': case 'jurisdictionl': return 'jurisdictionLocalityName'; case 'id-at-businesscategory': case 'businesscategory': return 'id-at-businessCategory'; case 'id-at-countryname': case 'countryname': case 'c': return 'id-at-countryName'; case 'id-at-organizationname': case 'organizationname': case 'o': return 'id-at-organizationName'; case 'id-at-dnqualifier': case 'dnqualifier': return 'id-at-dnQualifier'; case 'id-at-commonname': case 'commonname': case 'cn': return 'id-at-commonName'; case 'id-at-stateorprovincename': case 'stateorprovincename': case 'state': case 'province': case 'provincename': case 'st': return 'id-at-stateOrProvinceName'; case 'id-at-localityname': case 'localityname': case 'l': return 'id-at-localityName'; case 'id-emailaddress': case 'emailaddress': return 'pkcs-9-at-emailAddress'; case 'id-at-serialnumber': case 'serialnumber': return 'id-at-serialNumber'; case 'id-at-postalcode': case 'postalcode': return 'id-at-postalCode'; case 'id-at-streetaddress': case 'streetaddress': return 'id-at-streetAddress'; case 'id-at-name': case 'name': return 'id-at-name'; case 'id-at-givenname': case 'givenname': return 'id-at-givenName'; case 'id-at-surname': case 'surname': case 'sn': return 'id-at-surname'; case 'id-at-initials': case 'initials': return 'id-at-initials'; case 'id-at-generationqualifier': case 'generationqualifier': return 'id-at-generationQualifier'; case 'id-at-organizationalunitname': case 'organizationalunitname': case 'ou': return 'id-at-organizationalUnitName'; case 'id-at-pseudonym': case 'pseudonym': return 'id-at-pseudonym'; case 'id-at-title': case 'title': return 'id-at-title'; case 'id-at-description': case 'description': return 'id-at-description'; case 'id-at-role': case 'role': return 'id-at-role'; case 'id-at-uniqueidentifier': case 'uniqueidentifier': case 'x500uniqueidentifier': return 'id-at-uniqueIdentifier'; case 'postaladdress': case 'id-at-postaladdress': return 'id-at-postalAddress'; default: return false; } } /** * Set a Distinguished Name property * * @param string $propName * @param mixed $propValue * @param string $type optional * @return bool */ public function setDNProp($propName, $propValue, $type = 'utf8String') { if (empty($this->dn)) { $this->dn = ['rdnSequence' => []]; } if (($propName = $this->translateDNProp($propName)) === false) { return false; } foreach ((array) $propValue as $v) { if (!is_array($v) && isset($type)) { $v = [$type => $v]; } $this->dn['rdnSequence'][] = [ [ 'type' => $propName, 'value' => $v ] ]; } return true; } /** * Remove Distinguished Name properties * * @param string $propName */ public function removeDNProp($propName) { if (empty($this->dn)) { return; } if (($propName = $this->translateDNProp($propName)) === false) { return; } $dn = &$this->dn['rdnSequence']; $size = count($dn); for ($i = 0; $i < $size; $i++) { if ($dn[$i][0]['type'] == $propName) { unset($dn[$i]); } } $dn = array_values($dn); // fix for https://bugs.php.net/75433 affecting PHP 7.2 if (!isset($dn[0])) { $dn = array_splice($dn, 0, 0); } } /** * Get Distinguished Name properties * * @param string $propName * @param array $dn optional * @param bool $withType optional * @return mixed */ public function getDNProp($propName, array $dn = null, $withType = false) { if (!isset($dn)) { $dn = $this->dn; } if (empty($dn)) { return false; } if (($propName = $this->translateDNProp($propName)) === false) { return false; } $filters = []; $filters['value'] = ['type' => ASN1::TYPE_UTF8_STRING]; ASN1::setFilters($filters); $this->mapOutDNs($dn, 'rdnSequence'); $dn = $dn['rdnSequence']; $result = []; for ($i = 0; $i < count($dn); $i++) { if ($dn[$i][0]['type'] == $propName) { $v = $dn[$i][0]['value']; if (!$withType) { if (is_array($v)) { foreach ($v as $type => $s) { $type = array_search($type, ASN1::ANY_MAP); if ($type !== false && array_key_exists($type, ASN1::STRING_TYPE_SIZE)) { $s = ASN1::convert($s, $type); if ($s !== false) { $v = $s; break; } } } if (is_array($v)) { $v = array_pop($v); // Always strip data type. } } elseif (is_object($v) && $v instanceof Element) { $map = $this->getMapping($propName); if (!is_bool($map)) { $decoded = ASN1::decodeBER($v); if (!$decoded) { return false; } $v = ASN1::asn1map($decoded[0], $map); } } } $result[] = $v; } } return $result; } /** * Set a Distinguished Name * * @param mixed $dn * @param bool $merge optional * @param string $type optional * @return bool */ public function setDN($dn, $merge = false, $type = 'utf8String') { if (!$merge) { $this->dn = null; } if (is_array($dn)) { if (isset($dn['rdnSequence'])) { $this->dn = $dn; // No merge here. return true; } // handles stuff generated by openssl_x509_parse() foreach ($dn as $prop => $value) { if (!$this->setDNProp($prop, $value, $type)) { return false; } } return true; } // handles everything else $results = preg_split('#((?:^|, *|/)(?:C=|O=|OU=|CN=|L=|ST=|SN=|postalCode=|streetAddress=|emailAddress=|serialNumber=|organizationalUnitName=|title=|description=|role=|x500UniqueIdentifier=|postalAddress=))#', $dn, -1, PREG_SPLIT_DELIM_CAPTURE); for ($i = 1; $i < count($results); $i += 2) { $prop = trim($results[$i], ', =/'); $value = $results[$i + 1]; if (!$this->setDNProp($prop, $value, $type)) { return false; } } return true; } /** * Get the Distinguished Name for a certificates subject * * @param mixed $format optional * @param array $dn optional * @return array|bool|string */ public function getDN($format = self::DN_ARRAY, array $dn = null) { if (!isset($dn)) { $dn = isset($this->currentCert['tbsCertList']) ? $this->currentCert['tbsCertList']['issuer'] : $this->dn; } switch ((int) $format) { case self::DN_ARRAY: return $dn; case self::DN_ASN1: $filters = []; $filters['rdnSequence']['value'] = ['type' => ASN1::TYPE_UTF8_STRING]; ASN1::setFilters($filters); $this->mapOutDNs($dn, 'rdnSequence'); return ASN1::encodeDER($dn, Maps\Name::MAP); case self::DN_CANON: // No SEQUENCE around RDNs and all string values normalized as // trimmed lowercase UTF-8 with all spacing as one blank. // constructed RDNs will not be canonicalized $filters = []; $filters['value'] = ['type' => ASN1::TYPE_UTF8_STRING]; ASN1::setFilters($filters); $result = ''; $this->mapOutDNs($dn, 'rdnSequence'); foreach ($dn['rdnSequence'] as $rdn) { foreach ($rdn as $i => $attr) { $attr = &$rdn[$i]; if (is_array($attr['value'])) { foreach ($attr['value'] as $type => $v) { $type = array_search($type, ASN1::ANY_MAP, true); if ($type !== false && array_key_exists($type, ASN1::STRING_TYPE_SIZE)) { $v = ASN1::convert($v, $type); if ($v !== false) { $v = preg_replace('/\s+/', ' ', $v); $attr['value'] = strtolower(trim($v)); break; } } } } } $result .= ASN1::encodeDER($rdn, Maps\RelativeDistinguishedName::MAP); } return $result; case self::DN_HASH: $dn = $this->getDN(self::DN_CANON, $dn); $hash = new Hash('sha1'); $hash = $hash->hash($dn); extract(unpack('Vhash', $hash)); return strtolower(Strings::bin2hex(pack('N', $hash))); } // Default is to return a string. $start = true; $output = ''; $result = []; $filters = []; $filters['rdnSequence']['value'] = ['type' => ASN1::TYPE_UTF8_STRING]; ASN1::setFilters($filters); $this->mapOutDNs($dn, 'rdnSequence'); foreach ($dn['rdnSequence'] as $field) { $prop = $field[0]['type']; $value = $field[0]['value']; $delim = ', '; switch ($prop) { case 'id-at-countryName': $desc = 'C'; break; case 'id-at-stateOrProvinceName': $desc = 'ST'; break; case 'id-at-organizationName': $desc = 'O'; break; case 'id-at-organizationalUnitName': $desc = 'OU'; break; case 'id-at-commonName': $desc = 'CN'; break; case 'id-at-localityName': $desc = 'L'; break; case 'id-at-surname': $desc = 'SN'; break; case 'id-at-uniqueIdentifier': $delim = '/'; $desc = 'x500UniqueIdentifier'; break; case 'id-at-postalAddress': $delim = '/'; $desc = 'postalAddress'; break; default: $delim = '/'; $desc = preg_replace('#.+-([^-]+)$#', '$1', $prop); } if (!$start) { $output .= $delim; } if (is_array($value)) { foreach ($value as $type => $v) { $type = array_search($type, ASN1::ANY_MAP, true); if ($type !== false && array_key_exists($type, ASN1::STRING_TYPE_SIZE)) { $v = ASN1::convert($v, $type); if ($v !== false) { $value = $v; break; } } } if (is_array($value)) { $value = array_pop($value); // Always strip data type. } } elseif (is_object($value) && $value instanceof Element) { $callback = function ($x) { return '\x' . bin2hex($x[0]); }; $value = strtoupper(preg_replace_callback('#[^\x20-\x7E]#', $callback, $value->element)); } $output .= $desc . '=' . $value; $result[$desc] = isset($result[$desc]) ? array_merge((array) $result[$desc], [$value]) : $value; $start = false; } return $format == self::DN_OPENSSL ? $result : $output; } /** * Get the Distinguished Name for a certificate/crl issuer * * @param int $format optional * @return mixed */ public function getIssuerDN($format = self::DN_ARRAY) { switch (true) { case !isset($this->currentCert) || !is_array($this->currentCert): break; case isset($this->currentCert['tbsCertificate']): return $this->getDN($format, $this->currentCert['tbsCertificate']['issuer']); case isset($this->currentCert['tbsCertList']): return $this->getDN($format, $this->currentCert['tbsCertList']['issuer']); } return false; } /** * Get the Distinguished Name for a certificate/csr subject * Alias of getDN() * * @param int $format optional * @return mixed */ public function getSubjectDN($format = self::DN_ARRAY) { switch (true) { case !empty($this->dn): return $this->getDN($format); case !isset($this->currentCert) || !is_array($this->currentCert): break; case isset($this->currentCert['tbsCertificate']): return $this->getDN($format, $this->currentCert['tbsCertificate']['subject']); case isset($this->currentCert['certificationRequestInfo']): return $this->getDN($format, $this->currentCert['certificationRequestInfo']['subject']); } return false; } /** * Get an individual Distinguished Name property for a certificate/crl issuer * * @param string $propName * @param bool $withType optional * @return mixed */ public function getIssuerDNProp($propName, $withType = false) { switch (true) { case !isset($this->currentCert) || !is_array($this->currentCert): break; case isset($this->currentCert['tbsCertificate']): return $this->getDNProp($propName, $this->currentCert['tbsCertificate']['issuer'], $withType); case isset($this->currentCert['tbsCertList']): return $this->getDNProp($propName, $this->currentCert['tbsCertList']['issuer'], $withType); } return false; } /** * Get an individual Distinguished Name property for a certificate/csr subject * * @param string $propName * @param bool $withType optional * @return mixed */ public function getSubjectDNProp($propName, $withType = false) { switch (true) { case !empty($this->dn): return $this->getDNProp($propName, null, $withType); case !isset($this->currentCert) || !is_array($this->currentCert): break; case isset($this->currentCert['tbsCertificate']): return $this->getDNProp($propName, $this->currentCert['tbsCertificate']['subject'], $withType); case isset($this->currentCert['certificationRequestInfo']): return $this->getDNProp($propName, $this->currentCert['certificationRequestInfo']['subject'], $withType); } return false; } /** * Get the certificate chain for the current cert * * @return mixed */ public function getChain() { $chain = [$this->currentCert]; if (!is_array($this->currentCert) || !isset($this->currentCert['tbsCertificate'])) { return false; } while (true) { $currentCert = $chain[count($chain) - 1]; for ($i = 0; $i < count($this->CAs); $i++) { $ca = $this->CAs[$i]; if ($currentCert['tbsCertificate']['issuer'] === $ca['tbsCertificate']['subject']) { $authorityKey = $this->getExtension('id-ce-authorityKeyIdentifier', $currentCert); $subjectKeyID = $this->getExtension('id-ce-subjectKeyIdentifier', $ca); switch (true) { case !is_array($authorityKey): case is_array($authorityKey) && isset($authorityKey['keyIdentifier']) && $authorityKey['keyIdentifier'] === $subjectKeyID: if ($currentCert === $ca) { break 3; } $chain[] = $ca; break 2; } } } if ($i == count($this->CAs)) { break; } } foreach ($chain as $key => $value) { $chain[$key] = new X509(); $chain[$key]->loadX509($value); } return $chain; } /** * Returns the current cert * * @return array|bool */ public function &getCurrentCert() { return $this->currentCert; } /** * Set public key * * Key needs to be a \phpseclib3\Crypt\RSA object * * @param PublicKey $key * @return void */ public function setPublicKey(PublicKey $key) { $this->publicKey = $key; } /** * Set private key * * Key needs to be a \phpseclib3\Crypt\RSA object * * @param PrivateKey $key */ public function setPrivateKey(PrivateKey $key) { $this->privateKey = $key; } /** * Set challenge * * Used for SPKAC CSR's * * @param string $challenge */ public function setChallenge($challenge) { $this->challenge = $challenge; } /** * Gets the public key * * Returns a \phpseclib3\Crypt\RSA object or a false. * * @return mixed */ public function getPublicKey() { if (isset($this->publicKey)) { return $this->publicKey; } if (isset($this->currentCert) && is_array($this->currentCert)) { $paths = [ 'tbsCertificate/subjectPublicKeyInfo', 'certificationRequestInfo/subjectPKInfo', 'publicKeyAndChallenge/spki' ]; foreach ($paths as $path) { $keyinfo = $this->subArray($this->currentCert, $path); if (!empty($keyinfo)) { break; } } } if (empty($keyinfo)) { return false; } $key = $keyinfo['subjectPublicKey']; switch ($keyinfo['algorithm']['algorithm']) { case 'id-RSASSA-PSS': return RSA::loadFormat('PSS', $key); case 'rsaEncryption': return RSA::loadFormat('PKCS8', $key)->withPadding(RSA::SIGNATURE_PKCS1); case 'id-ecPublicKey': case 'id-Ed25519': case 'id-Ed448': return EC::loadFormat('PKCS8', $key); case 'id-dsa': return DSA::loadFormat('PKCS8', $key); } return false; } /** * Load a Certificate Signing Request * * @param string $csr * @param int $mode * @return mixed */ public function loadCSR($csr, $mode = self::FORMAT_AUTO_DETECT) { if (is_array($csr) && isset($csr['certificationRequestInfo'])) { unset($this->currentCert); unset($this->currentKeyIdentifier); unset($this->signatureSubject); $this->dn = $csr['certificationRequestInfo']['subject']; if (!isset($this->dn)) { return false; } $this->currentCert = $csr; return $csr; } // see http://tools.ietf.org/html/rfc2986 if ($mode != self::FORMAT_DER) { $newcsr = ASN1::extractBER($csr); if ($mode == self::FORMAT_PEM && $csr == $newcsr) { return false; } $csr = $newcsr; } $orig = $csr; if ($csr === false) { $this->currentCert = false; return false; } $decoded = ASN1::decodeBER($csr); if (!$decoded) { $this->currentCert = false; return false; } $csr = ASN1::asn1map($decoded[0], Maps\CertificationRequest::MAP); if (!isset($csr) || $csr === false) { $this->currentCert = false; return false; } $this->mapInAttributes($csr, 'certificationRequestInfo/attributes'); $this->mapInDNs($csr, 'certificationRequestInfo/subject/rdnSequence'); $this->dn = $csr['certificationRequestInfo']['subject']; $this->signatureSubject = substr($orig, $decoded[0]['content'][0]['start'], $decoded[0]['content'][0]['length']); $key = $csr['certificationRequestInfo']['subjectPKInfo']; $key = ASN1::encodeDER($key, Maps\SubjectPublicKeyInfo::MAP); $csr['certificationRequestInfo']['subjectPKInfo']['subjectPublicKey'] = "-----BEGIN PUBLIC KEY-----\r\n" . chunk_split(base64_encode($key), 64) . "-----END PUBLIC KEY-----"; $this->currentKeyIdentifier = null; $this->currentCert = $csr; $this->publicKey = null; $this->publicKey = $this->getPublicKey(); return $csr; } /** * Save CSR request * * @param array $csr * @param int $format optional * @return string */ public function saveCSR(array $csr, $format = self::FORMAT_PEM) { if (!is_array($csr) || !isset($csr['certificationRequestInfo'])) { return false; } switch (true) { case !($algorithm = $this->subArray($csr, 'certificationRequestInfo/subjectPKInfo/algorithm/algorithm')): case is_object($csr['certificationRequestInfo']['subjectPKInfo']['subjectPublicKey']): break; default: $csr['certificationRequestInfo']['subjectPKInfo'] = new Element( base64_decode(preg_replace('#-.+-|[\r\n]#', '', $csr['certificationRequestInfo']['subjectPKInfo']['subjectPublicKey'])) ); } $filters = []; $filters['certificationRequestInfo']['subject']['rdnSequence']['value'] = ['type' => ASN1::TYPE_UTF8_STRING]; ASN1::setFilters($filters); $this->mapOutDNs($csr, 'certificationRequestInfo/subject/rdnSequence'); $this->mapOutAttributes($csr, 'certificationRequestInfo/attributes'); $csr = ASN1::encodeDER($csr, Maps\CertificationRequest::MAP); switch ($format) { case self::FORMAT_DER: return $csr; // case self::FORMAT_PEM: default: return "-----BEGIN CERTIFICATE REQUEST-----\r\n" . chunk_split(Strings::base64_encode($csr), 64) . '-----END CERTIFICATE REQUEST-----'; } } /** * Load a SPKAC CSR * * SPKAC's are produced by the HTML5 keygen element: * * https://developer.mozilla.org/en-US/docs/HTML/Element/keygen * * @param string $spkac * @return mixed */ public function loadSPKAC($spkac) { if (is_array($spkac) && isset($spkac['publicKeyAndChallenge'])) { unset($this->currentCert); unset($this->currentKeyIdentifier); unset($this->signatureSubject); $this->currentCert = $spkac; return $spkac; } // see http://www.w3.org/html/wg/drafts/html/master/forms.html#signedpublickeyandchallenge // OpenSSL produces SPKAC's that are preceded by the string SPKAC= $temp = preg_replace('#(?:SPKAC=)|[ \r\n\\\]#', '', $spkac); $temp = preg_match('#^[a-zA-Z\d/+]*={0,2}$#', $temp) ? Strings::base64_decode($temp) : false; if ($temp != false) { $spkac = $temp; } $orig = $spkac; if ($spkac === false) { $this->currentCert = false; return false; } $decoded = ASN1::decodeBER($spkac); if (!$decoded) { $this->currentCert = false; return false; } $spkac = ASN1::asn1map($decoded[0], Maps\SignedPublicKeyAndChallenge::MAP); if (!isset($spkac) || !is_array($spkac)) { $this->currentCert = false; return false; } $this->signatureSubject = substr($orig, $decoded[0]['content'][0]['start'], $decoded[0]['content'][0]['length']); $key = $spkac['publicKeyAndChallenge']['spki']; $key = ASN1::encodeDER($key, Maps\SubjectPublicKeyInfo::MAP); $spkac['publicKeyAndChallenge']['spki']['subjectPublicKey'] = "-----BEGIN PUBLIC KEY-----\r\n" . chunk_split(base64_encode($key), 64) . "-----END PUBLIC KEY-----"; $this->currentKeyIdentifier = null; $this->currentCert = $spkac; $this->publicKey = null; $this->publicKey = $this->getPublicKey(); return $spkac; } /** * Save a SPKAC CSR request * * @param array $spkac * @param int $format optional * @return string */ public function saveSPKAC(array $spkac, $format = self::FORMAT_PEM) { if (!is_array($spkac) || !isset($spkac['publicKeyAndChallenge'])) { return false; } $algorithm = $this->subArray($spkac, 'publicKeyAndChallenge/spki/algorithm/algorithm'); switch (true) { case !$algorithm: case is_object($spkac['publicKeyAndChallenge']['spki']['subjectPublicKey']): break; default: $spkac['publicKeyAndChallenge']['spki'] = new Element( base64_decode(preg_replace('#-.+-|[\r\n]#', '', $spkac['publicKeyAndChallenge']['spki']['subjectPublicKey'])) ); } $spkac = ASN1::encodeDER($spkac, Maps\SignedPublicKeyAndChallenge::MAP); switch ($format) { case self::FORMAT_DER: return $spkac; // case self::FORMAT_PEM: default: // OpenSSL's implementation of SPKAC requires the SPKAC be preceded by SPKAC= and since there are pretty much // no other SPKAC decoders phpseclib will use that same format return 'SPKAC=' . Strings::base64_encode($spkac); } } /** * Load a Certificate Revocation List * * @param string $crl * @param int $mode * @return mixed */ public function loadCRL($crl, $mode = self::FORMAT_AUTO_DETECT) { if (is_array($crl) && isset($crl['tbsCertList'])) { $this->currentCert = $crl; unset($this->signatureSubject); return $crl; } if ($mode != self::FORMAT_DER) { $newcrl = ASN1::extractBER($crl); if ($mode == self::FORMAT_PEM && $crl == $newcrl) { return false; } $crl = $newcrl; } $orig = $crl; if ($crl === false) { $this->currentCert = false; return false; } $decoded = ASN1::decodeBER($crl); if (!$decoded) { $this->currentCert = false; return false; } $crl = ASN1::asn1map($decoded[0], Maps\CertificateList::MAP); if (!isset($crl) || $crl === false) { $this->currentCert = false; return false; } $this->signatureSubject = substr($orig, $decoded[0]['content'][0]['start'], $decoded[0]['content'][0]['length']); $this->mapInDNs($crl, 'tbsCertList/issuer/rdnSequence'); if ($this->isSubArrayValid($crl, 'tbsCertList/crlExtensions')) { $this->mapInExtensions($crl, 'tbsCertList/crlExtensions'); } if ($this->isSubArrayValid($crl, 'tbsCertList/revokedCertificates')) { $rclist_ref = &$this->subArrayUnchecked($crl, 'tbsCertList/revokedCertificates'); if ($rclist_ref) { $rclist = $crl['tbsCertList']['revokedCertificates']; foreach ($rclist as $i => $extension) { if ($this->isSubArrayValid($rclist, "$i/crlEntryExtensions")) { $this->mapInExtensions($rclist_ref, "$i/crlEntryExtensions"); } } } } $this->currentKeyIdentifier = null; $this->currentCert = $crl; return $crl; } /** * Save Certificate Revocation List. * * @param array $crl * @param int $format optional * @return string */ public function saveCRL(array $crl, $format = self::FORMAT_PEM) { if (!is_array($crl) || !isset($crl['tbsCertList'])) { return false; } $filters = []; $filters['tbsCertList']['issuer']['rdnSequence']['value'] = ['type' => ASN1::TYPE_UTF8_STRING]; $filters['tbsCertList']['signature']['parameters'] = ['type' => ASN1::TYPE_UTF8_STRING]; $filters['signatureAlgorithm']['parameters'] = ['type' => ASN1::TYPE_UTF8_STRING]; if (empty($crl['tbsCertList']['signature']['parameters'])) { $filters['tbsCertList']['signature']['parameters'] = ['type' => ASN1::TYPE_NULL]; } if (empty($crl['signatureAlgorithm']['parameters'])) { $filters['signatureAlgorithm']['parameters'] = ['type' => ASN1::TYPE_NULL]; } ASN1::setFilters($filters); $this->mapOutDNs($crl, 'tbsCertList/issuer/rdnSequence'); $this->mapOutExtensions($crl, 'tbsCertList/crlExtensions'); $rclist = &$this->subArray($crl, 'tbsCertList/revokedCertificates'); if (is_array($rclist)) { foreach ($rclist as $i => $extension) { $this->mapOutExtensions($rclist, "$i/crlEntryExtensions"); } } $crl = ASN1::encodeDER($crl, Maps\CertificateList::MAP); switch ($format) { case self::FORMAT_DER: return $crl; // case self::FORMAT_PEM: default: return "-----BEGIN X509 CRL-----\r\n" . chunk_split(Strings::base64_encode($crl), 64) . '-----END X509 CRL-----'; } } /** * Helper function to build a time field according to RFC 3280 section * - 4.1.2.5 Validity * - 5.1.2.4 This Update * - 5.1.2.5 Next Update * - 5.1.2.6 Revoked Certificates * by choosing utcTime iff year of date given is before 2050 and generalTime else. * * @param string $date in format date('D, d M Y H:i:s O') * @return array|Element */ private function timeField($date) { if ($date instanceof Element) { return $date; } $dateObj = new \DateTimeImmutable($date, new \DateTimeZone('GMT')); $year = $dateObj->format('Y'); // the same way ASN1.php parses this if ($year < 2050) { return ['utcTime' => $date]; } else { return ['generalTime' => $date]; } } /** * Sign an X.509 certificate * * $issuer's private key needs to be loaded. * $subject can be either an existing X.509 cert (if you want to resign it), * a CSR or something with the DN and public key explicitly set. * * @return mixed */ public function sign(X509 $issuer, X509 $subject) { if (!is_object($issuer->privateKey) || empty($issuer->dn)) { return false; } if (isset($subject->publicKey) && !($subjectPublicKey = $subject->formatSubjectPublicKey())) { return false; } $currentCert = isset($this->currentCert) ? $this->currentCert : null; $signatureSubject = isset($this->signatureSubject) ? $this->signatureSubject : null; $signatureAlgorithm = self::identifySignatureAlgorithm($issuer->privateKey); if (isset($subject->currentCert) && is_array($subject->currentCert) && isset($subject->currentCert['tbsCertificate'])) { $this->currentCert = $subject->currentCert; $this->currentCert['tbsCertificate']['signature'] = $signatureAlgorithm; $this->currentCert['signatureAlgorithm'] = $signatureAlgorithm; if (!empty($this->startDate)) { $this->currentCert['tbsCertificate']['validity']['notBefore'] = $this->timeField($this->startDate); } if (!empty($this->endDate)) { $this->currentCert['tbsCertificate']['validity']['notAfter'] = $this->timeField($this->endDate); } if (!empty($this->serialNumber)) { $this->currentCert['tbsCertificate']['serialNumber'] = $this->serialNumber; } if (!empty($subject->dn)) { $this->currentCert['tbsCertificate']['subject'] = $subject->dn; } if (!empty($subject->publicKey)) { $this->currentCert['tbsCertificate']['subjectPublicKeyInfo'] = $subjectPublicKey; } $this->removeExtension('id-ce-authorityKeyIdentifier'); if (isset($subject->domains)) { $this->removeExtension('id-ce-subjectAltName'); } } elseif (isset($subject->currentCert) && is_array($subject->currentCert) && isset($subject->currentCert['tbsCertList'])) { return false; } else { if (!isset($subject->publicKey)) { return false; } $startDate = new \DateTimeImmutable('now', new \DateTimeZone(@date_default_timezone_get())); $startDate = !empty($this->startDate) ? $this->startDate : $startDate->format('D, d M Y H:i:s O'); $endDate = new \DateTimeImmutable('+1 year', new \DateTimeZone(@date_default_timezone_get())); $endDate = !empty($this->endDate) ? $this->endDate : $endDate->format('D, d M Y H:i:s O'); /* "The serial number MUST be a positive integer" "Conforming CAs MUST NOT use serialNumber values longer than 20 octets." -- https://tools.ietf.org/html/rfc5280#section-4.1.2.2 for the integer to be positive the leading bit needs to be 0 hence the application of a bitmap */ $serialNumber = !empty($this->serialNumber) ? $this->serialNumber : new BigInteger(Random::string(20) & ("\x7F" . str_repeat("\xFF", 19)), 256); $this->currentCert = [ 'tbsCertificate' => [ 'version' => 'v3', 'serialNumber' => $serialNumber, // $this->setSerialNumber() 'signature' => $signatureAlgorithm, 'issuer' => false, // this is going to be overwritten later 'validity' => [ 'notBefore' => $this->timeField($startDate), // $this->setStartDate() 'notAfter' => $this->timeField($endDate) // $this->setEndDate() ], 'subject' => $subject->dn, 'subjectPublicKeyInfo' => $subjectPublicKey ], 'signatureAlgorithm' => $signatureAlgorithm, 'signature' => false // this is going to be overwritten later ]; // Copy extensions from CSR. $csrexts = $subject->getAttribute('pkcs-9-at-extensionRequest', 0); if (!empty($csrexts)) { $this->currentCert['tbsCertificate']['extensions'] = $csrexts; } } $this->currentCert['tbsCertificate']['issuer'] = $issuer->dn; if (isset($issuer->currentKeyIdentifier)) { $this->setExtension('id-ce-authorityKeyIdentifier', [ //'authorityCertIssuer' => array( // array( // 'directoryName' => $issuer->dn // ) //), 'keyIdentifier' => $issuer->currentKeyIdentifier ]); //$extensions = &$this->currentCert['tbsCertificate']['extensions']; //if (isset($issuer->serialNumber)) { // $extensions[count($extensions) - 1]['authorityCertSerialNumber'] = $issuer->serialNumber; //} //unset($extensions); } if (isset($subject->currentKeyIdentifier)) { $this->setExtension('id-ce-subjectKeyIdentifier', $subject->currentKeyIdentifier); } $altName = []; if (isset($subject->domains) && count($subject->domains)) { $altName = array_map(['\phpseclib3\File\X509', 'dnsName'], $subject->domains); } if (isset($subject->ipAddresses) && count($subject->ipAddresses)) { // should an IP address appear as the CN if no domain name is specified? idk //$ips = count($subject->domains) ? $subject->ipAddresses : array_slice($subject->ipAddresses, 1); $ipAddresses = []; foreach ($subject->ipAddresses as $ipAddress) { $encoded = $subject->ipAddress($ipAddress); if ($encoded !== false) { $ipAddresses[] = $encoded; } } if (count($ipAddresses)) { $altName = array_merge($altName, $ipAddresses); } } if (!empty($altName)) { $this->setExtension('id-ce-subjectAltName', $altName); } if ($this->caFlag) { $keyUsage = $this->getExtension('id-ce-keyUsage'); if (!$keyUsage) { $keyUsage = []; } $this->setExtension( 'id-ce-keyUsage', array_values(array_unique(array_merge($keyUsage, ['cRLSign', 'keyCertSign']))) ); $basicConstraints = $this->getExtension('id-ce-basicConstraints'); if (!$basicConstraints) { $basicConstraints = []; } $this->setExtension( 'id-ce-basicConstraints', array_merge(['cA' => true], $basicConstraints), true ); if (!isset($subject->currentKeyIdentifier)) { $this->setExtension('id-ce-subjectKeyIdentifier', $this->computeKeyIdentifier($this->currentCert), false, false); } } // resync $this->signatureSubject // save $tbsCertificate in case there are any \phpseclib3\File\ASN1\Element objects in it $tbsCertificate = $this->currentCert['tbsCertificate']; $this->loadX509($this->saveX509($this->currentCert)); $result = $this->currentCert; $this->currentCert['signature'] = $result['signature'] = "\0" . $issuer->privateKey->sign($this->signatureSubject); $result['tbsCertificate'] = $tbsCertificate; $this->currentCert = $currentCert; $this->signatureSubject = $signatureSubject; return $result; } /** * Sign a CSR * * @return mixed */ public function signCSR() { if (!is_object($this->privateKey) || empty($this->dn)) { return false; } $origPublicKey = $this->publicKey; $this->publicKey = $this->privateKey->getPublicKey(); $publicKey = $this->formatSubjectPublicKey(); $this->publicKey = $origPublicKey; $currentCert = isset($this->currentCert) ? $this->currentCert : null; $signatureSubject = isset($this->signatureSubject) ? $this->signatureSubject : null; $signatureAlgorithm = self::identifySignatureAlgorithm($this->privateKey); if (isset($this->currentCert) && is_array($this->currentCert) && isset($this->currentCert['certificationRequestInfo'])) { $this->currentCert['signatureAlgorithm'] = $signatureAlgorithm; if (!empty($this->dn)) { $this->currentCert['certificationRequestInfo']['subject'] = $this->dn; } $this->currentCert['certificationRequestInfo']['subjectPKInfo'] = $publicKey; } else { $this->currentCert = [ 'certificationRequestInfo' => [ 'version' => 'v1', 'subject' => $this->dn, 'subjectPKInfo' => $publicKey ], 'signatureAlgorithm' => $signatureAlgorithm, 'signature' => false // this is going to be overwritten later ]; } // resync $this->signatureSubject // save $certificationRequestInfo in case there are any \phpseclib3\File\ASN1\Element objects in it $certificationRequestInfo = $this->currentCert['certificationRequestInfo']; $this->loadCSR($this->saveCSR($this->currentCert)); $result = $this->currentCert; $this->currentCert['signature'] = $result['signature'] = "\0" . $this->privateKey->sign($this->signatureSubject); $result['certificationRequestInfo'] = $certificationRequestInfo; $this->currentCert = $currentCert; $this->signatureSubject = $signatureSubject; return $result; } /** * Sign a SPKAC * * @return mixed */ public function signSPKAC() { if (!is_object($this->privateKey)) { return false; } $origPublicKey = $this->publicKey; $this->publicKey = $this->privateKey->getPublicKey(); $publicKey = $this->formatSubjectPublicKey(); $this->publicKey = $origPublicKey; $currentCert = isset($this->currentCert) ? $this->currentCert : null; $signatureSubject = isset($this->signatureSubject) ? $this->signatureSubject : null; $signatureAlgorithm = self::identifySignatureAlgorithm($this->privateKey); // re-signing a SPKAC seems silly but since everything else supports re-signing why not? if (isset($this->currentCert) && is_array($this->currentCert) && isset($this->currentCert['publicKeyAndChallenge'])) { $this->currentCert['signatureAlgorithm'] = $signatureAlgorithm; $this->currentCert['publicKeyAndChallenge']['spki'] = $publicKey; if (!empty($this->challenge)) { // the bitwise AND ensures that the output is a valid IA5String $this->currentCert['publicKeyAndChallenge']['challenge'] = $this->challenge & str_repeat("\x7F", strlen($this->challenge)); } } else { $this->currentCert = [ 'publicKeyAndChallenge' => [ 'spki' => $publicKey, // quoting , // "A challenge string that is submitted along with the public key. Defaults to an empty string if not specified." // both Firefox and OpenSSL ("openssl spkac -key private.key") behave this way // we could alternatively do this instead if we ignored the specs: // Random::string(8) & str_repeat("\x7F", 8) 'challenge' => !empty($this->challenge) ? $this->challenge : '' ], 'signatureAlgorithm' => $signatureAlgorithm, 'signature' => false // this is going to be overwritten later ]; } // resync $this->signatureSubject // save $publicKeyAndChallenge in case there are any \phpseclib3\File\ASN1\Element objects in it $publicKeyAndChallenge = $this->currentCert['publicKeyAndChallenge']; $this->loadSPKAC($this->saveSPKAC($this->currentCert)); $result = $this->currentCert; $this->currentCert['signature'] = $result['signature'] = "\0" . $this->privateKey->sign($this->signatureSubject); $result['publicKeyAndChallenge'] = $publicKeyAndChallenge; $this->currentCert = $currentCert; $this->signatureSubject = $signatureSubject; return $result; } /** * Sign a CRL * * $issuer's private key needs to be loaded. * * @return mixed */ public function signCRL(X509 $issuer, X509 $crl) { if (!is_object($issuer->privateKey) || empty($issuer->dn)) { return false; } $currentCert = isset($this->currentCert) ? $this->currentCert : null; $signatureSubject = isset($this->signatureSubject) ? $this->signatureSubject : null; $signatureAlgorithm = self::identifySignatureAlgorithm($issuer->privateKey); $thisUpdate = new \DateTimeImmutable('now', new \DateTimeZone(@date_default_timezone_get())); $thisUpdate = !empty($this->startDate) ? $this->startDate : $thisUpdate->format('D, d M Y H:i:s O'); if (isset($crl->currentCert) && is_array($crl->currentCert) && isset($crl->currentCert['tbsCertList'])) { $this->currentCert = $crl->currentCert; $this->currentCert['tbsCertList']['signature'] = $signatureAlgorithm; $this->currentCert['signatureAlgorithm'] = $signatureAlgorithm; } else { $this->currentCert = [ 'tbsCertList' => [ 'version' => 'v2', 'signature' => $signatureAlgorithm, 'issuer' => false, // this is going to be overwritten later 'thisUpdate' => $this->timeField($thisUpdate) // $this->setStartDate() ], 'signatureAlgorithm' => $signatureAlgorithm, 'signature' => false // this is going to be overwritten later ]; } $tbsCertList = &$this->currentCert['tbsCertList']; $tbsCertList['issuer'] = $issuer->dn; $tbsCertList['thisUpdate'] = $this->timeField($thisUpdate); if (!empty($this->endDate)) { $tbsCertList['nextUpdate'] = $this->timeField($this->endDate); // $this->setEndDate() } else { unset($tbsCertList['nextUpdate']); } if (!empty($this->serialNumber)) { $crlNumber = $this->serialNumber; } else { $crlNumber = $this->getExtension('id-ce-cRLNumber'); // "The CRL number is a non-critical CRL extension that conveys a // monotonically increasing sequence number for a given CRL scope and // CRL issuer. This extension allows users to easily determine when a // particular CRL supersedes another CRL." // -- https://tools.ietf.org/html/rfc5280#section-5.2.3 $crlNumber = $crlNumber !== false ? $crlNumber->add(new BigInteger(1)) : null; } $this->removeExtension('id-ce-authorityKeyIdentifier'); $this->removeExtension('id-ce-issuerAltName'); // Be sure version >= v2 if some extension found. $version = isset($tbsCertList['version']) ? $tbsCertList['version'] : 0; if (!$version) { if (!empty($tbsCertList['crlExtensions'])) { $version = 'v2'; // v2. } elseif (!empty($tbsCertList['revokedCertificates'])) { foreach ($tbsCertList['revokedCertificates'] as $cert) { if (!empty($cert['crlEntryExtensions'])) { $version = 'v2'; // v2. } } } if ($version) { $tbsCertList['version'] = $version; } } // Store additional extensions. if (!empty($tbsCertList['version'])) { // At least v2. if (!empty($crlNumber)) { $this->setExtension('id-ce-cRLNumber', $crlNumber); } if (isset($issuer->currentKeyIdentifier)) { $this->setExtension('id-ce-authorityKeyIdentifier', [ //'authorityCertIssuer' => array( // ] // 'directoryName' => $issuer->dn // ] //), 'keyIdentifier' => $issuer->currentKeyIdentifier ]); //$extensions = &$tbsCertList['crlExtensions']; //if (isset($issuer->serialNumber)) { // $extensions[count($extensions) - 1]['authorityCertSerialNumber'] = $issuer->serialNumber; //} //unset($extensions); } $issuerAltName = $this->getExtension('id-ce-subjectAltName', $issuer->currentCert); if ($issuerAltName !== false) { $this->setExtension('id-ce-issuerAltName', $issuerAltName); } } if (empty($tbsCertList['revokedCertificates'])) { unset($tbsCertList['revokedCertificates']); } unset($tbsCertList); // resync $this->signatureSubject // save $tbsCertList in case there are any \phpseclib3\File\ASN1\Element objects in it $tbsCertList = $this->currentCert['tbsCertList']; $this->loadCRL($this->saveCRL($this->currentCert)); $result = $this->currentCert; $this->currentCert['signature'] = $result['signature'] = "\0" . $issuer->privateKey->sign($this->signatureSubject); $result['tbsCertList'] = $tbsCertList; $this->currentCert = $currentCert; $this->signatureSubject = $signatureSubject; return $result; } /** * Identify signature algorithm from key settings * * @param PrivateKey $key * @throws UnsupportedAlgorithmException if the algorithm is unsupported * @return array */ private static function identifySignatureAlgorithm(PrivateKey $key) { if ($key instanceof RSA) { if ($key->getPadding() & RSA::SIGNATURE_PSS) { $r = PSS::load($key->withPassword()->toString('PSS')); return [ 'algorithm' => 'id-RSASSA-PSS', 'parameters' => PSS::savePSSParams($r) ]; } switch ($key->getHash()) { case 'md2': case 'md5': case 'sha1': case 'sha224': case 'sha256': case 'sha384': case 'sha512': return ['algorithm' => $key->getHash() . 'WithRSAEncryption']; } throw new UnsupportedAlgorithmException('The only supported hash algorithms for RSA are: md2, md5, sha1, sha224, sha256, sha384, sha512'); } if ($key instanceof DSA) { switch ($key->getHash()) { case 'sha1': case 'sha224': case 'sha256': return ['algorithm' => 'id-dsa-with-' . $key->getHash()]; } throw new UnsupportedAlgorithmException('The only supported hash algorithms for DSA are: sha1, sha224, sha256'); } if ($key instanceof EC) { switch ($key->getCurve()) { case 'Ed25519': case 'Ed448': return ['algorithm' => 'id-' . $key->getCurve()]; } switch ($key->getHash()) { case 'sha1': case 'sha224': case 'sha256': case 'sha384': case 'sha512': return ['algorithm' => 'ecdsa-with-' . strtoupper($key->getHash())]; } throw new UnsupportedAlgorithmException('The only supported hash algorithms for EC are: sha1, sha224, sha256, sha384, sha512'); } throw new UnsupportedAlgorithmException('The only supported public key classes are: RSA, DSA, EC'); } /** * Set certificate start date * * @param \DateTimeInterface|string $date */ public function setStartDate($date) { if (!is_object($date) || !($date instanceof \DateTimeInterface)) { $date = new \DateTimeImmutable($date, new \DateTimeZone(@date_default_timezone_get())); } $this->startDate = $date->format('D, d M Y H:i:s O'); } /** * Set certificate end date * * @param \DateTimeInterface|string $date */ public function setEndDate($date) { /* To indicate that a certificate has no well-defined expiration date, the notAfter SHOULD be assigned the GeneralizedTime value of 99991231235959Z. -- http://tools.ietf.org/html/rfc5280#section-4.1.2.5 */ if (is_string($date) && strtolower($date) === 'lifetime') { $temp = '99991231235959Z'; $temp = chr(ASN1::TYPE_GENERALIZED_TIME) . ASN1::encodeLength(strlen($temp)) . $temp; $this->endDate = new Element($temp); } else { if (!is_object($date) || !($date instanceof \DateTimeInterface)) { $date = new \DateTimeImmutable($date, new \DateTimeZone(@date_default_timezone_get())); } $this->endDate = $date->format('D, d M Y H:i:s O'); } } /** * Set Serial Number * * @param string $serial * @param int $base optional */ public function setSerialNumber($serial, $base = -256) { $this->serialNumber = new BigInteger($serial, $base); } /** * Turns the certificate into a certificate authority * */ public function makeCA() { $this->caFlag = true; } /** * Check for validity of subarray * * This is intended for use in conjunction with _subArrayUnchecked(), * implementing the checks included in _subArray() but without copying * a potentially large array by passing its reference by-value to is_array(). * * @param array $root * @param string $path * @return boolean */ private function isSubArrayValid(array $root, $path) { if (!is_array($root)) { return false; } foreach (explode('/', $path) as $i) { if (!is_array($root)) { return false; } if (!isset($root[$i])) { return true; } $root = $root[$i]; } return true; } /** * Get a reference to a subarray * * This variant of _subArray() does no is_array() checking, * so $root should be checked with _isSubArrayValid() first. * * This is here for performance reasons: * Passing a reference (i.e. $root) by-value (i.e. to is_array()) * creates a copy. If $root is an especially large array, this is expensive. * * @param array $root * @param string $path absolute path with / as component separator * @param bool $create optional * @return array|false */ private function &subArrayUnchecked(array &$root, $path, $create = false) { $false = false; foreach (explode('/', $path) as $i) { if (!isset($root[$i])) { if (!$create) { return $false; } $root[$i] = []; } $root = &$root[$i]; } return $root; } /** * Get a reference to a subarray * * @param array $root * @param string $path absolute path with / as component separator * @param bool $create optional * @return array|false */ private function &subArray(array &$root = null, $path, $create = false) { $false = false; if (!is_array($root)) { return $false; } foreach (explode('/', $path) as $i) { if (!is_array($root)) { return $false; } if (!isset($root[$i])) { if (!$create) { return $false; } $root[$i] = []; } $root = &$root[$i]; } return $root; } /** * Get a reference to an extension subarray * * @param array $root * @param string $path optional absolute path with / as component separator * @param bool $create optional * @return array|false */ private function &extensions(array &$root = null, $path = null, $create = false) { if (!isset($root)) { $root = $this->currentCert; } switch (true) { case !empty($path): case !is_array($root): break; case isset($root['tbsCertificate']): $path = 'tbsCertificate/extensions'; break; case isset($root['tbsCertList']): $path = 'tbsCertList/crlExtensions'; break; case isset($root['certificationRequestInfo']): $pth = 'certificationRequestInfo/attributes'; $attributes = &$this->subArray($root, $pth, $create); if (is_array($attributes)) { foreach ($attributes as $key => $value) { if ($value['type'] == 'pkcs-9-at-extensionRequest') { $path = "$pth/$key/value/0"; break 2; } } if ($create) { $key = count($attributes); $attributes[] = ['type' => 'pkcs-9-at-extensionRequest', 'value' => []]; $path = "$pth/$key/value/0"; } } break; } $extensions = &$this->subArray($root, $path, $create); if (!is_array($extensions)) { $false = false; return $false; } return $extensions; } /** * Remove an Extension * * @param string $id * @param string $path optional * @return bool */ private function removeExtensionHelper($id, $path = null) { $extensions = &$this->extensions($this->currentCert, $path); if (!is_array($extensions)) { return false; } $result = false; foreach ($extensions as $key => $value) { if ($value['extnId'] == $id) { unset($extensions[$key]); $result = true; } } $extensions = array_values($extensions); // fix for https://bugs.php.net/75433 affecting PHP 7.2 if (!isset($extensions[0])) { $extensions = array_splice($extensions, 0, 0); } return $result; } /** * Get an Extension * * Returns the extension if it exists and false if not * * @param string $id * @param array $cert optional * @param string $path optional * @return mixed */ private function getExtensionHelper($id, array $cert = null, $path = null) { $extensions = $this->extensions($cert, $path); if (!is_array($extensions)) { return false; } foreach ($extensions as $key => $value) { if ($value['extnId'] == $id) { return $value['extnValue']; } } return false; } /** * Returns a list of all extensions in use * * @param array $cert optional * @param string $path optional * @return array */ private function getExtensionsHelper(array $cert = null, $path = null) { $exts = $this->extensions($cert, $path); $extensions = []; if (is_array($exts)) { foreach ($exts as $extension) { $extensions[] = $extension['extnId']; } } return $extensions; } /** * Set an Extension * * @param string $id * @param mixed $value * @param bool $critical optional * @param bool $replace optional * @param string $path optional * @return bool */ private function setExtensionHelper($id, $value, $critical = false, $replace = true, $path = null) { $extensions = &$this->extensions($this->currentCert, $path, true); if (!is_array($extensions)) { return false; } $newext = ['extnId' => $id, 'critical' => $critical, 'extnValue' => $value]; foreach ($extensions as $key => $value) { if ($value['extnId'] == $id) { if (!$replace) { return false; } $extensions[$key] = $newext; return true; } } $extensions[] = $newext; return true; } /** * Remove a certificate, CSR or CRL Extension * * @param string $id * @return bool */ public function removeExtension($id) { return $this->removeExtensionHelper($id); } /** * Get a certificate, CSR or CRL Extension * * Returns the extension if it exists and false if not * * @param string $id * @param array $cert optional * @param string $path * @return mixed */ public function getExtension($id, array $cert = null, $path = null) { return $this->getExtensionHelper($id, $cert, $path); } /** * Returns a list of all extensions in use in certificate, CSR or CRL * * @param array $cert optional * @param string $path optional * @return array */ public function getExtensions(array $cert = null, $path = null) { return $this->getExtensionsHelper($cert, $path); } /** * Set a certificate, CSR or CRL Extension * * @param string $id * @param mixed $value * @param bool $critical optional * @param bool $replace optional * @return bool */ public function setExtension($id, $value, $critical = false, $replace = true) { return $this->setExtensionHelper($id, $value, $critical, $replace); } /** * Remove a CSR attribute. * * @param string $id * @param int $disposition optional * @return bool */ public function removeAttribute($id, $disposition = self::ATTR_ALL) { $attributes = &$this->subArray($this->currentCert, 'certificationRequestInfo/attributes'); if (!is_array($attributes)) { return false; } $result = false; foreach ($attributes as $key => $attribute) { if ($attribute['type'] == $id) { $n = count($attribute['value']); switch (true) { case $disposition == self::ATTR_APPEND: case $disposition == self::ATTR_REPLACE: return false; case $disposition >= $n: $disposition -= $n; break; case $disposition == self::ATTR_ALL: case $n == 1: unset($attributes[$key]); $result = true; break; default: unset($attributes[$key]['value'][$disposition]); $attributes[$key]['value'] = array_values($attributes[$key]['value']); $result = true; break; } if ($result && $disposition != self::ATTR_ALL) { break; } } } $attributes = array_values($attributes); return $result; } /** * Get a CSR attribute * * Returns the attribute if it exists and false if not * * @param string $id * @param int $disposition optional * @param array $csr optional * @return mixed */ public function getAttribute($id, $disposition = self::ATTR_ALL, array $csr = null) { if (empty($csr)) { $csr = $this->currentCert; } $attributes = $this->subArray($csr, 'certificationRequestInfo/attributes'); if (!is_array($attributes)) { return false; } foreach ($attributes as $key => $attribute) { if ($attribute['type'] == $id) { $n = count($attribute['value']); switch (true) { case $disposition == self::ATTR_APPEND: case $disposition == self::ATTR_REPLACE: return false; case $disposition == self::ATTR_ALL: return $attribute['value']; case $disposition >= $n: $disposition -= $n; break; default: return $attribute['value'][$disposition]; } } } return false; } /** * Returns a list of all CSR attributes in use * * @param array $csr optional * @return array */ public function getAttributes(array $csr = null) { if (empty($csr)) { $csr = $this->currentCert; } $attributes = $this->subArray($csr, 'certificationRequestInfo/attributes'); $attrs = []; if (is_array($attributes)) { foreach ($attributes as $attribute) { $attrs[] = $attribute['type']; } } return $attrs; } /** * Set a CSR attribute * * @param string $id * @param mixed $value * @param int $disposition optional * @return bool */ public function setAttribute($id, $value, $disposition = self::ATTR_ALL) { $attributes = &$this->subArray($this->currentCert, 'certificationRequestInfo/attributes', true); if (!is_array($attributes)) { return false; } switch ($disposition) { case self::ATTR_REPLACE: $disposition = self::ATTR_APPEND; // fall-through case self::ATTR_ALL: $this->removeAttribute($id); break; } foreach ($attributes as $key => $attribute) { if ($attribute['type'] == $id) { $n = count($attribute['value']); switch (true) { case $disposition == self::ATTR_APPEND: $last = $key; break; case $disposition >= $n: $disposition -= $n; break; default: $attributes[$key]['value'][$disposition] = $value; return true; } } } switch (true) { case $disposition >= 0: return false; case isset($last): $attributes[$last]['value'][] = $value; break; default: $attributes[] = ['type' => $id, 'value' => $disposition == self::ATTR_ALL ? $value : [$value]]; break; } return true; } /** * Sets the subject key identifier * * This is used by the id-ce-authorityKeyIdentifier and the id-ce-subjectKeyIdentifier extensions. * * @param string $value */ public function setKeyIdentifier($value) { if (empty($value)) { unset($this->currentKeyIdentifier); } else { $this->currentKeyIdentifier = $value; } } /** * Compute a public key identifier. * * Although key identifiers may be set to any unique value, this function * computes key identifiers from public key according to the two * recommended methods (4.2.1.2 RFC 3280). * Highly polymorphic: try to accept all possible forms of key: * - Key object * - \phpseclib3\File\X509 object with public or private key defined * - Certificate or CSR array * - \phpseclib3\File\ASN1\Element object * - PEM or DER string * * @param mixed $key optional * @param int $method optional * @return string binary key identifier */ public function computeKeyIdentifier($key = null, $method = 1) { if (is_null($key)) { $key = $this; } switch (true) { case is_string($key): break; case is_array($key) && isset($key['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey']): return $this->computeKeyIdentifier($key['tbsCertificate']['subjectPublicKeyInfo']['subjectPublicKey'], $method); case is_array($key) && isset($key['certificationRequestInfo']['subjectPKInfo']['subjectPublicKey']): return $this->computeKeyIdentifier($key['certificationRequestInfo']['subjectPKInfo']['subjectPublicKey'], $method); case !is_object($key): return false; case $key instanceof Element: // Assume the element is a bitstring-packed key. $decoded = ASN1::decodeBER($key->element); if (!$decoded) { return false; } $raw = ASN1::asn1map($decoded[0], ['type' => ASN1::TYPE_BIT_STRING]); if (empty($raw)) { return false; } // If the key is private, compute identifier from its corresponding public key. $key = PublicKeyLoader::load($raw); if ($key instanceof PrivateKey) { // If private. return $this->computeKeyIdentifier($key, $method); } $key = $raw; // Is a public key. break; case $key instanceof X509: if (isset($key->publicKey)) { return $this->computeKeyIdentifier($key->publicKey, $method); } if (isset($key->privateKey)) { return $this->computeKeyIdentifier($key->privateKey, $method); } if (isset($key->currentCert['tbsCertificate']) || isset($key->currentCert['certificationRequestInfo'])) { return $this->computeKeyIdentifier($key->currentCert, $method); } return false; default: // Should be a key object (i.e.: \phpseclib3\Crypt\RSA). $key = $key->getPublicKey(); break; } // If in PEM format, convert to binary. $key = ASN1::extractBER($key); // Now we have the key string: compute its sha-1 sum. $hash = new Hash('sha1'); $hash = $hash->hash($key); if ($method == 2) { $hash = substr($hash, -8); $hash[0] = chr((ord($hash[0]) & 0x0F) | 0x40); } return $hash; } /** * Format a public key as appropriate * * @return array|false */ private function formatSubjectPublicKey() { $format = $this->publicKey instanceof RSA && ($this->publicKey->getPadding() & RSA::SIGNATURE_PSS) ? 'PSS' : 'PKCS8'; $publicKey = base64_decode(preg_replace('#-.+-|[\r\n]#', '', $this->publicKey->toString($format))); $decoded = ASN1::decodeBER($publicKey); if (!$decoded) { return false; } $mapped = ASN1::asn1map($decoded[0], Maps\SubjectPublicKeyInfo::MAP); if (!is_array($mapped)) { return false; } $mapped['subjectPublicKey'] = $this->publicKey->toString($format); return $mapped; } /** * Set the domain name's which the cert is to be valid for * * @param mixed ...$domains * @return void */ public function setDomain(...$domains) { $this->domains = $domains; $this->removeDNProp('id-at-commonName'); $this->setDNProp('id-at-commonName', $this->domains[0]); } /** * Set the IP Addresses's which the cert is to be valid for * * @param mixed[] ...$ipAddresses */ public function setIPAddress(...$ipAddresses) { $this->ipAddresses = $ipAddresses; /* if (!isset($this->domains)) { $this->removeDNProp('id-at-commonName'); $this->setDNProp('id-at-commonName', $this->ipAddresses[0]); } */ } /** * Helper function to build domain array * * @param string $domain * @return array */ private static function dnsName($domain) { return ['dNSName' => $domain]; } /** * Helper function to build IP Address array * * (IPv6 is not currently supported) * * @param string $address * @return array */ private function iPAddress($address) { return ['iPAddress' => $address]; } /** * Get the index of a revoked certificate. * * @param array $rclist * @param string $serial * @param bool $create optional * @return int|false */ private function revokedCertificate(array &$rclist, $serial, $create = false) { $serial = new BigInteger($serial); foreach ($rclist as $i => $rc) { if (!($serial->compare($rc['userCertificate']))) { return $i; } } if (!$create) { return false; } $i = count($rclist); $revocationDate = new \DateTimeImmutable('now', new \DateTimeZone(@date_default_timezone_get())); $rclist[] = ['userCertificate' => $serial, 'revocationDate' => $this->timeField($revocationDate->format('D, d M Y H:i:s O'))]; return $i; } /** * Revoke a certificate. * * @param string $serial * @param string $date optional * @return bool */ public function revoke($serial, $date = null) { if (isset($this->currentCert['tbsCertList'])) { if (is_array($rclist = &$this->subArray($this->currentCert, 'tbsCertList/revokedCertificates', true))) { if ($this->revokedCertificate($rclist, $serial) === false) { // If not yet revoked if (($i = $this->revokedCertificate($rclist, $serial, true)) !== false) { if (!empty($date)) { $rclist[$i]['revocationDate'] = $this->timeField($date); } return true; } } } } return false; } /** * Unrevoke a certificate. * * @param string $serial * @return bool */ public function unrevoke($serial) { if (is_array($rclist = &$this->subArray($this->currentCert, 'tbsCertList/revokedCertificates'))) { if (($i = $this->revokedCertificate($rclist, $serial)) !== false) { unset($rclist[$i]); $rclist = array_values($rclist); return true; } } return false; } /** * Get a revoked certificate. * * @param string $serial * @return mixed */ public function getRevoked($serial) { if (is_array($rclist = $this->subArray($this->currentCert, 'tbsCertList/revokedCertificates'))) { if (($i = $this->revokedCertificate($rclist, $serial)) !== false) { return $rclist[$i]; } } return false; } /** * List revoked certificates * * @param array $crl optional * @return array|bool */ public function listRevoked(array $crl = null) { if (!isset($crl)) { $crl = $this->currentCert; } if (!isset($crl['tbsCertList'])) { return false; } $result = []; if (is_array($rclist = $this->subArray($crl, 'tbsCertList/revokedCertificates'))) { foreach ($rclist as $rc) { $result[] = $rc['userCertificate']->toString(); } } return $result; } /** * Remove a Revoked Certificate Extension * * @param string $serial * @param string $id * @return bool */ public function removeRevokedCertificateExtension($serial, $id) { if (is_array($rclist = &$this->subArray($this->currentCert, 'tbsCertList/revokedCertificates'))) { if (($i = $this->revokedCertificate($rclist, $serial)) !== false) { return $this->removeExtensionHelper($id, "tbsCertList/revokedCertificates/$i/crlEntryExtensions"); } } return false; } /** * Get a Revoked Certificate Extension * * Returns the extension if it exists and false if not * * @param string $serial * @param string $id * @param array $crl optional * @return mixed */ public function getRevokedCertificateExtension($serial, $id, array $crl = null) { if (!isset($crl)) { $crl = $this->currentCert; } if (is_array($rclist = $this->subArray($crl, 'tbsCertList/revokedCertificates'))) { if (($i = $this->revokedCertificate($rclist, $serial)) !== false) { return $this->getExtension($id, $crl, "tbsCertList/revokedCertificates/$i/crlEntryExtensions"); } } return false; } /** * Returns a list of all extensions in use for a given revoked certificate * * @param string $serial * @param array $crl optional * @return array|bool */ public function getRevokedCertificateExtensions($serial, array $crl = null) { if (!isset($crl)) { $crl = $this->currentCert; } if (is_array($rclist = $this->subArray($crl, 'tbsCertList/revokedCertificates'))) { if (($i = $this->revokedCertificate($rclist, $serial)) !== false) { return $this->getExtensions($crl, "tbsCertList/revokedCertificates/$i/crlEntryExtensions"); } } return false; } /** * Set a Revoked Certificate Extension * * @param string $serial * @param string $id * @param mixed $value * @param bool $critical optional * @param bool $replace optional * @return bool */ public function setRevokedCertificateExtension($serial, $id, $value, $critical = false, $replace = true) { if (isset($this->currentCert['tbsCertList'])) { if (is_array($rclist = &$this->subArray($this->currentCert, 'tbsCertList/revokedCertificates', true))) { if (($i = $this->revokedCertificate($rclist, $serial, true)) !== false) { return $this->setExtensionHelper($id, $value, $critical, $replace, "tbsCertList/revokedCertificates/$i/crlEntryExtensions"); } } } return false; } /** * Register the mapping for a custom/unsupported extension. * * @param string $id * @param array $mapping */ public static function registerExtension($id, array $mapping) { if (isset(self::$extensions[$id]) && self::$extensions[$id] !== $mapping) { throw new \RuntimeException( 'Extension ' . $id . ' has already been defined with a different mapping.' ); } self::$extensions[$id] = $mapping; } /** * Register the mapping for a custom/unsupported extension. * * @param string $id * * @return array|null */ public static function getRegisteredExtension($id) { return isset(self::$extensions[$id]) ? self::$extensions[$id] : null; } /** * Register the mapping for a custom/unsupported extension. * * @param string $id * @param mixed $value * @param bool $critical * @param bool $replace */ public function setExtensionValue($id, $value, $critical = false, $replace = false) { $this->extensionValues[$id] = compact('critical', 'replace', 'value'); } } ASN1/Element.php000075500000001464000000000000007321 0ustar00 * @copyright 2012 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1; /** * ASN.1 Raw Element * * An ASN.1 ANY mapping will return an ASN1\Element object. Use of this object * will also bypass the normal encoding rules in ASN1::encodeDER() * * @author Jim Wigginton */ class Element { /** * Raw element value * * @var string */ public $element; /** * Constructor * * @param string $encoded * @return Element */ public function __construct($encoded) { $this->element = $encoded; } } ASN1/Maps/GeneralSubtree.php000075500000001660000000000000011535 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * GeneralSubtree * * @author Jim Wigginton */ abstract class GeneralSubtree { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'base' => GeneralName::MAP, 'minimum' => [ 'constant' => 0, 'optional' => true, 'implicit' => true, 'default' => '0' ] + BaseDistance::MAP, 'maximum' => [ 'constant' => 1, 'optional' => true, 'implicit' => true, ] + BaseDistance::MAP ] ]; } ASN1/Maps/PolicyMappings.php000075500000001416000000000000011563 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PolicyMappings * * @author Jim Wigginton */ abstract class PolicyMappings { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'issuerDomainPolicy' => CertPolicyId::MAP, 'subjectDomainPolicy' => CertPolicyId::MAP ] ] ]; } ASN1/Maps/OrganizationName.php000075500000000767000000000000012102 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * OrganizationName * * @author Jim Wigginton */ abstract class OrganizationName { const MAP = ['type' => ASN1::TYPE_PRINTABLE_STRING]; } ASN1/Maps/PrivateKey.php000075500000000741000000000000010710 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PrivateKey * * @author Jim Wigginton */ abstract class PrivateKey { const MAP = ['type' => ASN1::TYPE_OCTET_STRING]; } ASN1/Maps/CertificateList.php000075500000001307000000000000011702 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CertificateList * * @author Jim Wigginton */ abstract class CertificateList { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'tbsCertList' => TBSCertList::MAP, 'signatureAlgorithm' => AlgorithmIdentifier::MAP, 'signature' => ['type' => ASN1::TYPE_BIT_STRING] ] ]; } ASN1/Maps/DistributionPointName.php000075500000001626000000000000013122 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DistributionPointName * * @author Jim Wigginton */ abstract class DistributionPointName { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'fullName' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + GeneralNames::MAP, 'nameRelativeToCRLIssuer' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + RelativeDistinguishedName::MAP ] ]; } ASN1/Maps/DssSigValue.php000075500000001166000000000000011020 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DssSigValue * * @author Jim Wigginton */ abstract class DssSigValue { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'r' => ['type' => ASN1::TYPE_INTEGER], 's' => ['type' => ASN1::TYPE_INTEGER] ] ]; } ASN1/Maps/TBSCertificate.php000075500000004127000000000000011422 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * TBSCertificate * * @author Jim Wigginton */ abstract class TBSCertificate { // assert($TBSCertificate['children']['signature'] == $Certificate['children']['signatureAlgorithm']) const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ // technically, default implies optional, but we'll define it as being optional, none-the-less, just to // reenforce that fact 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'constant' => 0, 'optional' => true, 'explicit' => true, 'mapping' => ['v1', 'v2', 'v3'], 'default' => 'v1' ], 'serialNumber' => CertificateSerialNumber::MAP, 'signature' => AlgorithmIdentifier::MAP, 'issuer' => Name::MAP, 'validity' => Validity::MAP, 'subject' => Name::MAP, 'subjectPublicKeyInfo' => SubjectPublicKeyInfo::MAP, // implicit means that the T in the TLV structure is to be rewritten, regardless of the type 'issuerUniqueID' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + UniqueIdentifier::MAP, 'subjectUniqueID' => [ 'constant' => 2, 'optional' => true, 'implicit' => true ] + UniqueIdentifier::MAP, // doesn't use the EXPLICIT keyword but if // it's not IMPLICIT, it's EXPLICIT 'extensions' => [ 'constant' => 3, 'optional' => true, 'explicit' => true ] + Extensions::MAP ] ]; } ASN1/Maps/AttributeTypeAndValue.php000075500000001204000000000000013045 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AttributeTypeAndValue * * @author Jim Wigginton */ abstract class AttributeTypeAndValue { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'type' => AttributeType::MAP, 'value' => AttributeValue::MAP ] ]; } ASN1/Maps/netscape_ca_policy_url.php000075500000001003000000000000013323 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * netscape_ca_policy_url * * @author Jim Wigginton */ abstract class netscape_ca_policy_url { const MAP = ['type' => ASN1::TYPE_IA5_STRING]; } ASN1/Maps/ExtensionAttributes.php000075500000001165000000000000012651 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ExtensionAttributes * * @author Jim Wigginton */ abstract class ExtensionAttributes { const MAP = [ 'type' => ASN1::TYPE_SET, 'min' => 1, 'max' => 256, // ub-extension-attributes 'children' => ExtensionAttribute::MAP ]; } ASN1/Maps/PBES2params.php000075500000001305000000000000010641 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PBES2params * * from https://tools.ietf.org/html/rfc2898#appendix-A.3 * * @author Jim Wigginton */ abstract class PBES2params { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'keyDerivationFunc' => AlgorithmIdentifier::MAP, 'encryptionScheme' => AlgorithmIdentifier::MAP ] ]; } ASN1/Maps/KeyIdentifier.php000075500000000752000000000000011362 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * KeyIdentifier * * @author Jim Wigginton */ abstract class KeyIdentifier { const MAP = ['type' => ASN1::TYPE_OCTET_STRING]; } ASN1/Maps/AttributeValue.php000075500000000744000000000000011570 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AttributeValue * * @author Jim Wigginton */ abstract class AttributeValue { const MAP = ['type' => ASN1::TYPE_ANY]; } ASN1/Maps/PrivateKeyInfo.php000075500000001650000000000000011524 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PrivateKeyInfo * * @author Jim Wigginton */ abstract class PrivateKeyInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => ['v1'] ], 'privateKeyAlgorithm' => AlgorithmIdentifier::MAP, 'privateKey' => PrivateKey::MAP, 'attributes' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + Attributes::MAP ] ]; } ASN1/Maps/HoldInstructionCode.php000075500000001001000000000000012536 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * HoldInstructionCode * * @author Jim Wigginton */ abstract class HoldInstructionCode { const MAP = ['type' => ASN1::TYPE_OBJECT_IDENTIFIER]; } ASN1/Maps/NameConstraints.php000075500000001601000000000000011731 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * NameConstraints * * @author Jim Wigginton */ abstract class NameConstraints { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'permittedSubtrees' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + GeneralSubtrees::MAP, 'excludedSubtrees' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + GeneralSubtrees::MAP ] ]; } ASN1/Maps/SubjectDirectoryAttributes.php000075500000001152000000000000014155 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * SubjectDirectoryAttributes * * @author Jim Wigginton */ abstract class SubjectDirectoryAttributes { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => Attribute::MAP ]; } ASN1/Maps/RDNSequence.php000075500000002010000000000000010730 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RDNSequence * * In practice, RDNs containing multiple name-value pairs (called "multivalued RDNs") are rare, * but they can be useful at times when either there is no unique attribute in the entry or you * want to ensure that the entry's DN contains some useful identifying information. * * - https://www.opends.org/wiki/page/DefinitionRelativeDistinguishedName * * @author Jim Wigginton */ abstract class RDNSequence { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, // RDNSequence does not define a min or a max, which means it doesn't have one 'min' => 0, 'max' => -1, 'children' => RelativeDistinguishedName::MAP ]; } ASN1/Maps/SubjectInfoAccessSyntax.php000075500000001151000000000000013365 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * SubjectInfoAccessSyntax * * @author Jim Wigginton */ abstract class SubjectInfoAccessSyntax { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => AccessDescription::MAP ]; } ASN1/Maps/CertificationRequest.php000075500000001360000000000000012757 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CertificationRequest * * @author Jim Wigginton */ abstract class CertificationRequest { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'certificationRequestInfo' => CertificationRequestInfo::MAP, 'signatureAlgorithm' => AlgorithmIdentifier::MAP, 'signature' => ['type' => ASN1::TYPE_BIT_STRING] ] ]; } ASN1/Maps/Time.php000075500000001171000000000000007521 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Time * * @author Jim Wigginton */ abstract class Time { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'utcTime' => ['type' => ASN1::TYPE_UTC_TIME], 'generalTime' => ['type' => ASN1::TYPE_GENERALIZED_TIME] ] ]; } ASN1/Maps/netscape_comment.php000075500000000761000000000000012153 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * netscape_comment * * @author Jim Wigginton */ abstract class netscape_comment { const MAP = ['type' => ASN1::TYPE_IA5_STRING]; } ASN1/Maps/OrganizationalUnitNames.php000075500000001224000000000000013427 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * OrganizationalUnitNames * * @author Jim Wigginton */ abstract class OrganizationalUnitNames { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => 4, // ub-organizational-units 'children' => ['type' => ASN1::TYPE_PRINTABLE_STRING] ]; } ASN1/Maps/SpecifiedECDomain.php000075500000002130000000000000012052 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * SpecifiedECDomain * * @author Jim Wigginton */ abstract class SpecifiedECDomain { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => [1 => 'ecdpVer1', 'ecdpVer2', 'ecdpVer3'] ], 'fieldID' => FieldID::MAP, 'curve' => Curve::MAP, 'base' => ECPoint::MAP, 'order' => ['type' => ASN1::TYPE_INTEGER], 'cofactor' => [ 'type' => ASN1::TYPE_INTEGER, 'optional' => true ], 'hash' => ['optional' => true] + HashAlgorithm::MAP ] ]; } ASN1/Maps/PrivateKeyUsagePeriod.php000075500000001651000000000000013041 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PrivateKeyUsagePeriod * * @author Jim Wigginton */ abstract class PrivateKeyUsagePeriod { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'notBefore' => [ 'constant' => 0, 'optional' => true, 'implicit' => true, 'type' => ASN1::TYPE_GENERALIZED_TIME], 'notAfter' => [ 'constant' => 1, 'optional' => true, 'implicit' => true, 'type' => ASN1::TYPE_GENERALIZED_TIME] ] ]; } ASN1/Maps/AnotherName.php000075500000001415000000000000011025 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AnotherName * * @author Jim Wigginton */ abstract class AnotherName { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'type-id' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'value' => [ 'type' => ASN1::TYPE_ANY, 'constant' => 0, 'optional' => true, 'explicit' => true ] ] ]; } ASN1/Maps/ORAddress.php000075500000001437000000000000010456 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ORAddress * * @author Jim Wigginton */ abstract class ORAddress { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'built-in-standard-attributes' => BuiltInStandardAttributes::MAP, 'built-in-domain-defined-attributes' => ['optional' => true] + BuiltInDomainDefinedAttributes::MAP, 'extension-attributes' => ['optional' => true] + ExtensionAttributes::MAP ] ]; } ASN1/Maps/InvalidityDate.php000075500000000761000000000000011541 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * InvalidityDate * * @author Jim Wigginton */ abstract class InvalidityDate { const MAP = ['type' => ASN1::TYPE_GENERALIZED_TIME]; } ASN1/Maps/HashAlgorithm.php000075500000000704000000000000011356 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; /** * HashAglorithm * * @author Jim Wigginton */ abstract class HashAlgorithm { const MAP = AlgorithmIdentifier::MAP; } ASN1/Maps/CRLNumber.php000075500000000731000000000000010415 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CRLNumber * * @author Jim Wigginton */ abstract class CRLNumber { const MAP = ['type' => ASN1::TYPE_INTEGER]; } ASN1/Maps/Extensions.php000075500000001316000000000000010763 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Extensions * * @author Jim Wigginton */ abstract class Extensions { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, // technically, it's MAX, but we'll assume anything < 0 is MAX 'max' => -1, // if 'children' isn't an array then 'min' and 'max' must be defined 'children' => Extension::MAP ]; } ASN1/Maps/FieldID.php000075500000001303000000000000010060 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * FieldID * * @author Jim Wigginton */ abstract class FieldID { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'fieldType' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'parameters' => [ 'type' => ASN1::TYPE_ANY, 'optional' => true ] ] ]; } ASN1/Maps/netscape_cert_type.php000075500000001512000000000000012502 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * netscape_cert_type * * mapping is from * * @author Jim Wigginton */ abstract class netscape_cert_type { const MAP = [ 'type' => ASN1::TYPE_BIT_STRING, 'mapping' => [ 'SSLClient', 'SSLServer', 'Email', 'ObjectSigning', 'Reserved', 'SSLCA', 'EmailCA', 'ObjectSigningCA' ] ]; } ASN1/Maps/Name.php000075500000001050000000000000007477 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Name * * @author Jim Wigginton */ abstract class Name { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'rdnSequence' => RDNSequence::MAP ] ]; } ASN1/Maps/NumericUserIdentifier.php000075500000001004000000000000013062 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * NumericUserIdentifier * * @author Jim Wigginton */ abstract class NumericUserIdentifier { const MAP = ['type' => ASN1::TYPE_NUMERIC_STRING]; } ASN1/Maps/RelativeDistinguishedName.php000075500000001722000000000000013725 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RelativeDistinguishedName * * In practice, RDNs containing multiple name-value pairs (called "multivalued RDNs") are rare, * but they can be useful at times when either there is no unique attribute in the entry or you * want to ensure that the entry's DN contains some useful identifying information. * * - https://www.opends.org/wiki/page/DefinitionRelativeDistinguishedName * * @author Jim Wigginton */ abstract class RelativeDistinguishedName { const MAP = [ 'type' => ASN1::TYPE_SET, 'min' => 1, 'max' => -1, 'children' => AttributeTypeAndValue::MAP ]; } ASN1/Maps/OtherPrimeInfos.php000075500000001206000000000000011677 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * OtherPrimeInfos * * @author Jim Wigginton */ abstract class OtherPrimeInfos { // version must be multi if otherPrimeInfos present const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => OtherPrimeInfo::MAP ]; } ASN1/Maps/Curve.php000075500000001305000000000000007706 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Curve * * @author Jim Wigginton */ abstract class Curve { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'a' => FieldElement::MAP, 'b' => FieldElement::MAP, 'seed' => [ 'type' => ASN1::TYPE_BIT_STRING, 'optional' => true ] ] ]; } ASN1/Maps/TerminalIdentifier.php000075500000000775000000000000012412 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * TerminalIdentifier * * @author Jim Wigginton */ abstract class TerminalIdentifier { const MAP = ['type' => ASN1::TYPE_PRINTABLE_STRING]; } ASN1/Maps/CertificateSerialNumber.php000075500000001003000000000000013350 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CertificateSerialNumber * * @author Jim Wigginton */ abstract class CertificateSerialNumber { const MAP = ['type' => ASN1::TYPE_INTEGER]; } ASN1/Maps/RevokedCertificate.php000075500000001371000000000000012367 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RevokedCertificate * * @author Jim Wigginton */ abstract class RevokedCertificate { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'userCertificate' => CertificateSerialNumber::MAP, 'revocationDate' => Time::MAP, 'crlEntryExtensions' => [ 'optional' => true ] + Extensions::MAP ] ]; } ASN1/Maps/AccessDescription.php000075500000001234000000000000012230 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AccessDescription * * @author Jim Wigginton */ abstract class AccessDescription { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'accessMethod' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'accessLocation' => GeneralName::MAP ] ]; } ASN1/Maps/Characteristic_two.php000075500000001446000000000000012451 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Characteristic_two * * @author Jim Wigginton */ abstract class Characteristic_two { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'm' => ['type' => ASN1::TYPE_INTEGER], // field size 2**m 'basis' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'parameters' => [ 'type' => ASN1::TYPE_ANY, 'optional' => true ] ] ]; } ASN1/Maps/PublicKey.php000075500000000734000000000000010516 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PublicKey * * @author Jim Wigginton */ abstract class PublicKey { const MAP = ['type' => ASN1::TYPE_BIT_STRING]; } ASN1/Maps/RC2CBCParameter.php000075500000001431000000000000011361 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RC2CBCParameter * * from https://tools.ietf.org/html/rfc2898#appendix-A.3 * * @author Jim Wigginton */ abstract class RC2CBCParameter { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'rc2ParametersVersion' => [ 'type' => ASN1::TYPE_INTEGER, 'optional' => true ], 'iv' => ['type' => ASN1::TYPE_OCTET_STRING] ] ]; } ASN1/Maps/ECPrivateKey.php000075500000002176000000000000011124 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ECPrivateKey * * @author Jim Wigginton */ abstract class ECPrivateKey { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => [1 => 'ecPrivkeyVer1'] ], 'privateKey' => ['type' => ASN1::TYPE_OCTET_STRING], 'parameters' => [ 'constant' => 0, 'optional' => true, 'explicit' => true ] + ECParameters::MAP, 'publicKey' => [ 'type' => ASN1::TYPE_BIT_STRING, 'constant' => 1, 'optional' => true, 'explicit' => true ] ] ]; } ASN1/Maps/BuiltInDomainDefinedAttribute.php000075500000001305000000000000014463 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * BuiltInDomainDefinedAttribute * * @author Jim Wigginton */ abstract class BuiltInDomainDefinedAttribute { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'type' => ['type' => ASN1::TYPE_PRINTABLE_STRING], 'value' => ['type' => ASN1::TYPE_PRINTABLE_STRING] ] ]; } ASN1/Maps/PolicyQualifierInfo.php000075500000001232000000000000012536 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PolicyQualifierInfo * * @author Jim Wigginton */ abstract class PolicyQualifierInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'policyQualifierId' => PolicyQualifierId::MAP, 'qualifier' => ['type' => ASN1::TYPE_ANY] ] ]; } ASN1/Maps/DSAParams.php000075500000001243000000000000010376 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DSAParams * * @author Jim Wigginton */ abstract class DSAParams { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'p' => ['type' => ASN1::TYPE_INTEGER], 'q' => ['type' => ASN1::TYPE_INTEGER], 'g' => ['type' => ASN1::TYPE_INTEGER] ] ]; } ASN1/Maps/PolicyQualifierId.php000075500000000773000000000000012210 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PolicyQualifierId * * @author Jim Wigginton */ abstract class PolicyQualifierId { const MAP = ['type' => ASN1::TYPE_OBJECT_IDENTIFIER]; } ASN1/Maps/PBEParameter.php000075500000001312000000000000011067 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PBEParameter * * from https://tools.ietf.org/html/rfc2898#appendix-A.3 * * @author Jim Wigginton */ abstract class PBEParameter { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'salt' => ['type' => ASN1::TYPE_OCTET_STRING], 'iterationCount' => ['type' => ASN1::TYPE_INTEGER] ] ]; } ASN1/Maps/SignedPublicKeyAndChallenge.php000075500000001377000000000000014102 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * SignedPublicKeyAndChallenge * * @author Jim Wigginton */ abstract class SignedPublicKeyAndChallenge { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'publicKeyAndChallenge' => PublicKeyAndChallenge::MAP, 'signatureAlgorithm' => AlgorithmIdentifier::MAP, 'signature' => ['type' => ASN1::TYPE_BIT_STRING] ] ]; } ASN1/Maps/RSASSA_PSS_params.php000075500000002767000000000000011723 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RSASSA_PSS_params * * @author Jim Wigginton */ abstract class RSASSA_PSS_params { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'hashAlgorithm' => [ 'constant' => 0, 'optional' => true, 'explicit' => true, //'default' => 'sha1Identifier' ] + HashAlgorithm::MAP, 'maskGenAlgorithm' => [ 'constant' => 1, 'optional' => true, 'explicit' => true, //'default' => 'mgf1SHA1Identifier' ] + MaskGenAlgorithm::MAP, 'saltLength' => [ 'type' => ASN1::TYPE_INTEGER, 'constant' => 2, 'optional' => true, 'explicit' => true, 'default' => 20 ], 'trailerField' => [ 'type' => ASN1::TYPE_INTEGER, 'constant' => 3, 'optional' => true, 'explicit' => true, 'default' => 1 ] ] ]; } ASN1/Maps/CPSuri.php000075500000000723000000000000007772 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CPSuri * * @author Jim Wigginton */ abstract class CPSuri { const MAP = ['type' => ASN1::TYPE_IA5_STRING]; } ASN1/Maps/Validity.php000075500000001122000000000000010404 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Validity * * @author Jim Wigginton */ abstract class Validity { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'notBefore' => Time::MAP, 'notAfter' => Time::MAP ] ]; } ASN1/Maps/TBSCertList.php000075500000002526000000000000010732 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * TBSCertList * * @author Jim Wigginton */ abstract class TBSCertList { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => ['v1', 'v2'], 'optional' => true, 'default' => 'v1' ], 'signature' => AlgorithmIdentifier::MAP, 'issuer' => Name::MAP, 'thisUpdate' => Time::MAP, 'nextUpdate' => [ 'optional' => true ] + Time::MAP, 'revokedCertificates' => [ 'type' => ASN1::TYPE_SEQUENCE, 'optional' => true, 'min' => 0, 'max' => -1, 'children' => RevokedCertificate::MAP ], 'crlExtensions' => [ 'constant' => 0, 'optional' => true, 'explicit' => true ] + Extensions::MAP ] ]; } ASN1/Maps/DSAPrivateKey.php000075500000001516000000000000011241 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DSAPrivateKey * * @author Jim Wigginton */ abstract class DSAPrivateKey { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => ['type' => ASN1::TYPE_INTEGER], 'p' => ['type' => ASN1::TYPE_INTEGER], 'q' => ['type' => ASN1::TYPE_INTEGER], 'g' => ['type' => ASN1::TYPE_INTEGER], 'y' => ['type' => ASN1::TYPE_INTEGER], 'x' => ['type' => ASN1::TYPE_INTEGER] ] ]; } ASN1/Maps/PolicyInformation.php000075500000001515000000000000012272 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PolicyInformation * * @author Jim Wigginton */ abstract class PolicyInformation { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'policyIdentifier' => CertPolicyId::MAP, 'policyQualifiers' => [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 0, 'max' => -1, 'optional' => true, 'children' => PolicyQualifierInfo::MAP ] ] ]; } ASN1/Maps/CRLDistributionPoints.php000075500000001143000000000000013037 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CRLDistributionPoints * * @author Jim Wigginton */ abstract class CRLDistributionPoints { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => DistributionPoint::MAP ]; } ASN1/Maps/AdministrationDomainName.php000075500000001653000000000000013546 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AdministrationDomainName * * @author Jim Wigginton */ abstract class AdministrationDomainName { const MAP = [ 'type' => ASN1::TYPE_CHOICE, // if class isn't present it's assumed to be \phpseclib3\File\ASN1::CLASS_UNIVERSAL or // (if constant is present) \phpseclib3\File\ASN1::CLASS_CONTEXT_SPECIFIC 'class' => ASN1::CLASS_APPLICATION, 'cast' => 2, 'children' => [ 'numeric' => ['type' => ASN1::TYPE_NUMERIC_STRING], 'printable' => ['type' => ASN1::TYPE_PRINTABLE_STRING] ] ]; } ASN1/Maps/BasicConstraints.php000075500000001476000000000000012104 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * BasicConstraints * * @author Jim Wigginton */ abstract class BasicConstraints { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'cA' => [ 'type' => ASN1::TYPE_BOOLEAN, 'optional' => true, 'default' => false ], 'pathLenConstraint' => [ 'type' => ASN1::TYPE_INTEGER, 'optional' => true ] ] ]; } ASN1/Maps/PBKDF2params.php000075500000002033000000000000010735 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PBKDF2params * * from https://tools.ietf.org/html/rfc2898#appendix-A.3 * * @author Jim Wigginton */ abstract class PBKDF2params { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ // technically, this is a CHOICE in RFC2898 but the other "choice" is, currently, more of a placeholder // in the RFC 'salt' => ['type' => ASN1::TYPE_OCTET_STRING], 'iterationCount' => ['type' => ASN1::TYPE_INTEGER], 'keyLength' => [ 'type' => ASN1::TYPE_INTEGER, 'optional' => true ], 'prf' => AlgorithmIdentifier::MAP + ['optional' => true] ] ]; } ASN1/Maps/KeyUsage.php000075500000001413000000000000010337 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * KeyUsage * * @author Jim Wigginton */ abstract class KeyUsage { const MAP = [ 'type' => ASN1::TYPE_BIT_STRING, 'mapping' => [ 'digitalSignature', 'nonRepudiation', 'keyEncipherment', 'dataEncipherment', 'keyAgreement', 'keyCertSign', 'cRLSign', 'encipherOnly', 'decipherOnly' ] ]; } ASN1/Maps/CertificatePolicies.php000075500000001135000000000000012535 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CertificatePolicies * * @author Jim Wigginton */ abstract class CertificatePolicies { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => PolicyInformation::MAP ]; } ASN1/Maps/DSAPublicKey.php000075500000000742000000000000011045 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DSAPublicKey * * @author Jim Wigginton */ abstract class DSAPublicKey { const MAP = ['type' => ASN1::TYPE_INTEGER]; } ASN1/Maps/CRLReason.php000075500000001542000000000000010415 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CRLReason * * @author Jim Wigginton */ abstract class CRLReason { const MAP = [ 'type' => ASN1::TYPE_ENUMERATED, 'mapping' => [ 'unspecified', 'keyCompromise', 'cACompromise', 'affiliationChanged', 'superseded', 'cessationOfOperation', 'certificateHold', // Value 7 is not used. 8 => 'removeFromCRL', 'privilegeWithdrawn', 'aACompromise' ] ]; } ASN1/Maps/SubjectPublicKeyInfo.php000075500000001245000000000000012650 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * SubjectPublicKeyInfo * * @author Jim Wigginton */ abstract class SubjectPublicKeyInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'algorithm' => AlgorithmIdentifier::MAP, 'subjectPublicKey' => ['type' => ASN1::TYPE_BIT_STRING] ] ]; } ASN1/Maps/EncryptedData.php000075500000000752000000000000011356 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * EncryptedData * * @author Jim Wigginton */ abstract class EncryptedData { const MAP = ['type' => ASN1::TYPE_OCTET_STRING]; } ASN1/Maps/ReasonFlags.php000075500000001435000000000000011032 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ReasonFlags * * @author Jim Wigginton */ abstract class ReasonFlags { const MAP = [ 'type' => ASN1::TYPE_BIT_STRING, 'mapping' => [ 'unused', 'keyCompromise', 'cACompromise', 'affiliationChanged', 'superseded', 'cessationOfOperation', 'certificateHold', 'privilegeWithdrawn', 'aACompromise' ] ]; } ASN1/Maps/DHParameter.php000075500000001526000000000000010763 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DHParameter * * @author Jim Wigginton */ abstract class DHParameter { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'prime' => ['type' => ASN1::TYPE_INTEGER], 'base' => ['type' => ASN1::TYPE_INTEGER], 'privateValueLength' => [ 'type' => ASN1::TYPE_INTEGER, 'optional' => true ] ] ]; } ASN1/Maps/UniqueIdentifier.php000075500000000761000000000000012100 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * UniqueIdentifier * * @author Jim Wigginton */ abstract class UniqueIdentifier { const MAP = ['type' => ASN1::TYPE_BIT_STRING]; } ASN1/Maps/ECParameters.php000075500000002164000000000000011141 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ECParameters * * ECParameters ::= CHOICE { * namedCurve OBJECT IDENTIFIER * -- implicitCurve NULL * -- specifiedCurve SpecifiedECDomain * } * -- implicitCurve and specifiedCurve MUST NOT be used in PKIX. * -- Details for SpecifiedECDomain can be found in [X9.62]. * -- Any future additions to this CHOICE should be coordinated * -- with ANSI X9. * * @author Jim Wigginton */ abstract class ECParameters { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'namedCurve' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'implicitCurve' => ['type' => ASN1::TYPE_NULL], 'specifiedCurve' => SpecifiedECDomain::MAP ] ]; } ASN1/Maps/PostalAddress.php000075500000001145000000000000011374 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PostalAddress * * @author Jim Wigginton */ abstract class PostalAddress { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'optional' => true, 'min' => 1, 'max' => -1, 'children' => DirectoryString::MAP ]; } ASN1/Maps/GeneralName.php000075500000004237000000000000011007 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * GeneralName * * @author Jim Wigginton */ abstract class GeneralName { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'otherName' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + AnotherName::MAP, 'rfc822Name' => [ 'type' => ASN1::TYPE_IA5_STRING, 'constant' => 1, 'optional' => true, 'implicit' => true ], 'dNSName' => [ 'type' => ASN1::TYPE_IA5_STRING, 'constant' => 2, 'optional' => true, 'implicit' => true ], 'x400Address' => [ 'constant' => 3, 'optional' => true, 'implicit' => true ] + ORAddress::MAP, 'directoryName' => [ 'constant' => 4, 'optional' => true, 'explicit' => true ] + Name::MAP, 'ediPartyName' => [ 'constant' => 5, 'optional' => true, 'implicit' => true ] + EDIPartyName::MAP, 'uniformResourceIdentifier' => [ 'type' => ASN1::TYPE_IA5_STRING, 'constant' => 6, 'optional' => true, 'implicit' => true ], 'iPAddress' => [ 'type' => ASN1::TYPE_OCTET_STRING, 'constant' => 7, 'optional' => true, 'implicit' => true ], 'registeredID' => [ 'type' => ASN1::TYPE_OBJECT_IDENTIFIER, 'constant' => 8, 'optional' => true, 'implicit' => true ] ] ]; } ASN1/Maps/Attribute.php000075500000001361000000000000010567 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Attribute * * @author Jim Wigginton */ abstract class Attribute { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'type' => AttributeType::MAP, 'value' => [ 'type' => ASN1::TYPE_SET, 'min' => 1, 'max' => -1, 'children' => AttributeValue::MAP ] ] ]; } ASN1/Maps/SubjectAltName.php000075500000000700000000000000011461 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; /** * SubjectAltName * * @author Jim Wigginton */ abstract class SubjectAltName { const MAP = GeneralNames::MAP; } ASN1/Maps/EncryptedPrivateKeyInfo.php000075500000001246000000000000013403 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * EncryptedPrivateKeyInfo * * @author Jim Wigginton */ abstract class EncryptedPrivateKeyInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'encryptionAlgorithm' => AlgorithmIdentifier::MAP, 'encryptedData' => EncryptedData::MAP ] ]; } ASN1/Maps/Trinomial.php000075500000000731000000000000010562 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Trinomial * * @author Jim Wigginton */ abstract class Trinomial { const MAP = ['type' => ASN1::TYPE_INTEGER]; } ASN1/Maps/GeneralNames.php000075500000001102000000000000011156 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * GeneralNames * * @author Jim Wigginton */ abstract class GeneralNames { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => GeneralName::MAP ]; } ASN1/Maps/ExtensionAttribute.php000075500000001715000000000000012467 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ExtensionAttribute * * @author Jim Wigginton */ abstract class ExtensionAttribute { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'extension-attribute-type' => [ 'type' => ASN1::TYPE_PRINTABLE_STRING, 'constant' => 0, 'optional' => true, 'implicit' => true ], 'extension-attribute-value' => [ 'type' => ASN1::TYPE_ANY, 'constant' => 1, 'optional' => true, 'explicit' => true ] ] ]; } ASN1/Maps/PublicKeyInfo.php000075500000001455000000000000011333 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PublicKeyInfo * * this format is not formally defined anywhere but is none-the-less the form you * get when you do "openssl rsa -in private.pem -outform PEM -pubout" * * @author Jim Wigginton */ abstract class PublicKeyInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'publicKeyAlgorithm' => AlgorithmIdentifier::MAP, 'publicKey' => ['type' => ASN1::TYPE_BIT_STRING] ] ]; } ASN1/Maps/CountryName.php000075500000001625000000000000011073 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CountryName * * @author Jim Wigginton */ abstract class CountryName { const MAP = [ 'type' => ASN1::TYPE_CHOICE, // if class isn't present it's assumed to be \phpseclib3\File\ASN1::CLASS_UNIVERSAL or // (if constant is present) \phpseclib3\File\ASN1::CLASS_CONTEXT_SPECIFIC 'class' => ASN1::CLASS_APPLICATION, 'cast' => 1, 'children' => [ 'x121-dcc-code' => ['type' => ASN1::TYPE_NUMERIC_STRING], 'iso-3166-alpha2-code' => ['type' => ASN1::TYPE_PRINTABLE_STRING] ] ]; } ASN1/Maps/Pentanomial.php000075500000001315000000000000011072 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Pentanomial * * @author Jim Wigginton */ abstract class Pentanomial { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'k1' => ['type' => ASN1::TYPE_INTEGER], // k1 > 0 'k2' => ['type' => ASN1::TYPE_INTEGER], // k2 > k1 'k3' => ['type' => ASN1::TYPE_INTEGER], // k3 > h2 ] ]; } ASN1/Maps/OneAsymmetricKey.php000075500000002207000000000000012054 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * OneAsymmetricKey * * @author Jim Wigginton */ abstract class OneAsymmetricKey { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => ['v1', 'v2'] ], 'privateKeyAlgorithm' => AlgorithmIdentifier::MAP, 'privateKey' => PrivateKey::MAP, 'attributes' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + Attributes::MAP, 'publicKey' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + PublicKey::MAP ] ]; } ASN1/Maps/CertificateIssuer.php000075500000000711000000000000012237 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; /** * CertificateIssuer * * @author Jim Wigginton */ abstract class CertificateIssuer { const MAP = GeneralNames::MAP; } ASN1/Maps/ECPoint.php000075500000000730000000000000010124 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ECPoint * * @author Jim Wigginton */ abstract class ECPoint { const MAP = ['type' => ASN1::TYPE_OCTET_STRING]; } ASN1/Maps/Certificate.php000075500000001301000000000000011040 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Certificate * * @author Jim Wigginton */ abstract class Certificate { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'tbsCertificate' => TBSCertificate::MAP, 'signatureAlgorithm' => AlgorithmIdentifier::MAP, 'signature' => ['type' => ASN1::TYPE_BIT_STRING] ] ]; } ASN1/Maps/GeneralSubtrees.php000075500000001116000000000000011714 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * GeneralSubtrees * * @author Jim Wigginton */ abstract class GeneralSubtrees { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => GeneralSubtree::MAP ]; } ASN1/Maps/AuthorityInfoAccessSyntax.php000075500000001157000000000000013764 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AuthorityInfoAccessSyntax * * @author Jim Wigginton */ abstract class AuthorityInfoAccessSyntax { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => AccessDescription::MAP ]; } ASN1/Maps/UserNotice.php000075500000001440000000000000010702 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * UserNotice * * @author Jim Wigginton */ abstract class UserNotice { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'noticeRef' => [ 'optional' => true, 'implicit' => true ] + NoticeReference::MAP, 'explicitText' => [ 'optional' => true, 'implicit' => true ] + DisplayText::MAP ] ]; } ASN1/Maps/DistributionPoint.php000075500000002050000000000000012311 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DistributionPoint * * @author Jim Wigginton */ abstract class DistributionPoint { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'distributionPoint' => [ 'constant' => 0, 'optional' => true, 'explicit' => true ] + DistributionPointName::MAP, 'reasons' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + ReasonFlags::MAP, 'cRLIssuer' => [ 'constant' => 2, 'optional' => true, 'implicit' => true ] + GeneralNames::MAP ] ]; } ASN1/Maps/PersonalName.php000075500000002503000000000000011207 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PersonalName * * @author Jim Wigginton */ abstract class PersonalName { const MAP = [ 'type' => ASN1::TYPE_SET, 'children' => [ 'surname' => [ 'type' => ASN1::TYPE_PRINTABLE_STRING, 'constant' => 0, 'optional' => true, 'implicit' => true ], 'given-name' => [ 'type' => ASN1::TYPE_PRINTABLE_STRING, 'constant' => 1, 'optional' => true, 'implicit' => true ], 'initials' => [ 'type' => ASN1::TYPE_PRINTABLE_STRING, 'constant' => 2, 'optional' => true, 'implicit' => true ], 'generation-qualifier' => [ 'type' => ASN1::TYPE_PRINTABLE_STRING, 'constant' => 3, 'optional' => true, 'implicit' => true ] ] ]; } ASN1/Maps/RSAPublicKey.php000075500000001214000000000000011056 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RSAPublicKey * * @author Jim Wigginton */ abstract class RSAPublicKey { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'modulus' => ['type' => ASN1::TYPE_INTEGER], 'publicExponent' => ['type' => ASN1::TYPE_INTEGER] ] ]; } ASN1/Maps/EcdsaSigValue.php000075500000001174000000000000011305 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * EcdsaSigValue * * @author Jim Wigginton */ abstract class EcdsaSigValue { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'r' => ['type' => ASN1::TYPE_INTEGER], 's' => ['type' => ASN1::TYPE_INTEGER] ] ]; } ASN1/Maps/PrivateDomainName.php000075500000001244000000000000012167 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PrivateDomainName * * @author Jim Wigginton */ abstract class PrivateDomainName { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'numeric' => ['type' => ASN1::TYPE_NUMERIC_STRING], 'printable' => ['type' => ASN1::TYPE_PRINTABLE_STRING] ] ]; } ASN1/Maps/Prime_p.php000075500000000723000000000000010220 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Prime_p * * @author Jim Wigginton */ abstract class Prime_p { const MAP = ['type' => ASN1::TYPE_INTEGER]; } ASN1/Maps/AttributeType.php000075500000000757000000000000011441 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AttributeType * * @author Jim Wigginton */ abstract class AttributeType { const MAP = ['type' => ASN1::TYPE_OBJECT_IDENTIFIER]; } ASN1/Maps/BuiltInStandardAttributes.php000075500000003744000000000000013731 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * BuiltInStandardAttributes * * @author Jim Wigginton */ abstract class BuiltInStandardAttributes { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'country-name' => ['optional' => true] + CountryName::MAP, 'administration-domain-name' => ['optional' => true] + AdministrationDomainName::MAP, 'network-address' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + NetworkAddress::MAP, 'terminal-identifier' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + TerminalIdentifier::MAP, 'private-domain-name' => [ 'constant' => 2, 'optional' => true, 'explicit' => true ] + PrivateDomainName::MAP, 'organization-name' => [ 'constant' => 3, 'optional' => true, 'implicit' => true ] + OrganizationName::MAP, 'numeric-user-identifier' => [ 'constant' => 4, 'optional' => true, 'implicit' => true ] + NumericUserIdentifier::MAP, 'personal-name' => [ 'constant' => 5, 'optional' => true, 'implicit' => true ] + PersonalName::MAP, 'organizational-unit-names' => [ 'constant' => 6, 'optional' => true, 'implicit' => true ] + OrganizationalUnitNames::MAP ] ]; } ASN1/Maps/Attributes.php000075500000001065000000000000010753 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Attributes * * @author Jim Wigginton */ abstract class Attributes { const MAP = [ 'type' => ASN1::TYPE_SET, 'min' => 1, 'max' => -1, 'children' => Attribute::MAP ]; } ASN1/Maps/MaskGenAlgorithm.php000075500000000715000000000000012022 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; /** * MaskGenAglorithm * * @author Jim Wigginton */ abstract class MaskGenAlgorithm { const MAP = AlgorithmIdentifier::MAP; } ASN1/Maps/DirectoryString.php000075500000001562000000000000011762 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DirectoryString * * @author Jim Wigginton */ abstract class DirectoryString { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'teletexString' => ['type' => ASN1::TYPE_TELETEX_STRING], 'printableString' => ['type' => ASN1::TYPE_PRINTABLE_STRING], 'universalString' => ['type' => ASN1::TYPE_UNIVERSAL_STRING], 'utf8String' => ['type' => ASN1::TYPE_UTF8_STRING], 'bmpString' => ['type' => ASN1::TYPE_BMP_STRING] ] ]; } ASN1/Maps/NetworkAddress.php000075500000000757000000000000011573 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * NetworkAddress * * @author Jim Wigginton */ abstract class NetworkAddress { const MAP = ['type' => ASN1::TYPE_NUMERIC_STRING]; } ASN1/Maps/CertificationRequestInfo.php000075500000001671000000000000013600 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CertificationRequestInfo * * @author Jim Wigginton */ abstract class CertificationRequestInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => ['v1'] ], 'subject' => Name::MAP, 'subjectPKInfo' => SubjectPublicKeyInfo::MAP, 'attributes' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + Attributes::MAP, ] ]; } ASN1/Maps/RSAPrivateKey.php000075500000002577000000000000011267 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * RSAPrivateKey * * @author Jim Wigginton */ abstract class RSAPrivateKey { // version must be multi if otherPrimeInfos present const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'version' => [ 'type' => ASN1::TYPE_INTEGER, 'mapping' => ['two-prime', 'multi'] ], 'modulus' => ['type' => ASN1::TYPE_INTEGER], // n 'publicExponent' => ['type' => ASN1::TYPE_INTEGER], // e 'privateExponent' => ['type' => ASN1::TYPE_INTEGER], // d 'prime1' => ['type' => ASN1::TYPE_INTEGER], // p 'prime2' => ['type' => ASN1::TYPE_INTEGER], // q 'exponent1' => ['type' => ASN1::TYPE_INTEGER], // d mod (p-1) 'exponent2' => ['type' => ASN1::TYPE_INTEGER], // d mod (q-1) 'coefficient' => ['type' => ASN1::TYPE_INTEGER], // (inverse of q) mod p 'otherPrimeInfos' => OtherPrimeInfos::MAP + ['optional' => true] ] ]; } ASN1/Maps/PBMAC1params.php000075500000001311000000000000010726 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PBMAC1params * * from https://tools.ietf.org/html/rfc2898#appendix-A.3 * * @author Jim Wigginton */ abstract class PBMAC1params { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'keyDerivationFunc' => AlgorithmIdentifier::MAP, 'messageAuthScheme' => AlgorithmIdentifier::MAP ] ]; } ASN1/Maps/FieldElement.php000075500000000747000000000000011170 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * FieldElement * * @author Jim Wigginton */ abstract class FieldElement { const MAP = ['type' => ASN1::TYPE_OCTET_STRING]; } ASN1/Maps/IssuerAltName.php000075500000000675000000000000011347 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; /** * IssuerAltName * * @author Jim Wigginton */ abstract class IssuerAltName { const MAP = GeneralNames::MAP; } ASN1/Maps/CertPolicyId.php000075500000000754000000000000011163 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * CertPolicyId * * @author Jim Wigginton */ abstract class CertPolicyId { const MAP = ['type' => ASN1::TYPE_OBJECT_IDENTIFIER]; } ASN1/Maps/OtherPrimeInfo.php000075500000001430000000000000011513 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * OtherPrimeInfo * * @author Jim Wigginton */ abstract class OtherPrimeInfo { // version must be multi if otherPrimeInfos present const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'prime' => ['type' => ASN1::TYPE_INTEGER], // ri 'exponent' => ['type' => ASN1::TYPE_INTEGER], // di 'coefficient' => ['type' => ASN1::TYPE_INTEGER] // ti ] ]; } ASN1/Maps/PKCS9String.php000075500000001203000000000000010637 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PKCS9String * * @author Jim Wigginton */ abstract class PKCS9String { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'ia5String' => ['type' => ASN1::TYPE_IA5_STRING], 'directoryString' => DirectoryString::MAP ] ]; } ASN1/Maps/ExtKeyUsageSyntax.php000075500000001122000000000000012224 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * ExtKeyUsageSyntax * * @author Jim Wigginton */ abstract class ExtKeyUsageSyntax { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => -1, 'children' => KeyPurposeId::MAP ]; } ASN1/Maps/Extension.php000075500000002053000000000000010577 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * Extension * * A certificate using system MUST reject the certificate if it encounters * a critical extension it does not recognize; however, a non-critical * extension may be ignored if it is not recognized. * * http://tools.ietf.org/html/rfc5280#section-4.2 * * @author Jim Wigginton */ abstract class Extension { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'extnId' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'critical' => [ 'type' => ASN1::TYPE_BOOLEAN, 'optional' => true, 'default' => false ], 'extnValue' => ['type' => ASN1::TYPE_OCTET_STRING] ] ]; } ASN1/Maps/DisplayText.php000075500000001420000000000000011072 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DisplayText * * @author Jim Wigginton */ abstract class DisplayText { const MAP = [ 'type' => ASN1::TYPE_CHOICE, 'children' => [ 'ia5String' => ['type' => ASN1::TYPE_IA5_STRING], 'visibleString' => ['type' => ASN1::TYPE_VISIBLE_STRING], 'bmpString' => ['type' => ASN1::TYPE_BMP_STRING], 'utf8String' => ['type' => ASN1::TYPE_UTF8_STRING] ] ]; } ASN1/Maps/EDIPartyName.php000075500000002062000000000000011045 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * EDIPartyName * * @author Jim Wigginton */ abstract class EDIPartyName { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'nameAssigner' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + DirectoryString::MAP, // partyName is technically required but \phpseclib3\File\ASN1 doesn't currently support non-optional constants and // setting it to optional gets the job done in any event. 'partyName' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + DirectoryString::MAP ] ]; } ASN1/Maps/DigestInfo.php000075500000001301000000000000010651 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * DigestInfo * * from https://tools.ietf.org/html/rfc2898#appendix-A.3 * * @author Jim Wigginton */ abstract class DigestInfo { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'digestAlgorithm' => AlgorithmIdentifier::MAP, 'digest' => ['type' => ASN1::TYPE_OCTET_STRING] ] ]; } ASN1/Maps/NoticeReference.php000075500000001442000000000000011664 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * NoticeReference * * @author Jim Wigginton */ abstract class NoticeReference { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'organization' => DisplayText::MAP, 'noticeNumbers' => [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => 200, 'children' => ['type' => ASN1::TYPE_INTEGER] ] ] ]; } ASN1/Maps/KeyPurposeId.php000075500000000754000000000000011214 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * KeyPurposeId * * @author Jim Wigginton */ abstract class KeyPurposeId { const MAP = ['type' => ASN1::TYPE_OBJECT_IDENTIFIER]; } ASN1/Maps/IssuingDistributionPoint.php000075500000003536000000000000013665 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * IssuingDistributionPoint * * @author Jim Wigginton */ abstract class IssuingDistributionPoint { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'distributionPoint' => [ 'constant' => 0, 'optional' => true, 'explicit' => true ] + DistributionPointName::MAP, 'onlyContainsUserCerts' => [ 'type' => ASN1::TYPE_BOOLEAN, 'constant' => 1, 'optional' => true, 'default' => false, 'implicit' => true ], 'onlyContainsCACerts' => [ 'type' => ASN1::TYPE_BOOLEAN, 'constant' => 2, 'optional' => true, 'default' => false, 'implicit' => true ], 'onlySomeReasons' => [ 'constant' => 3, 'optional' => true, 'implicit' => true ] + ReasonFlags::MAP, 'indirectCRL' => [ 'type' => ASN1::TYPE_BOOLEAN, 'constant' => 4, 'optional' => true, 'default' => false, 'implicit' => true ], 'onlyContainsAttributeCerts' => [ 'type' => ASN1::TYPE_BOOLEAN, 'constant' => 5, 'optional' => true, 'default' => false, 'implicit' => true ] ] ]; } ASN1/Maps/AlgorithmIdentifier.php000075500000001347000000000000012561 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AlgorithmIdentifier * * @author Jim Wigginton */ abstract class AlgorithmIdentifier { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'algorithm' => ['type' => ASN1::TYPE_OBJECT_IDENTIFIER], 'parameters' => [ 'type' => ASN1::TYPE_ANY, 'optional' => true ] ] ]; } ASN1/Maps/BaseDistance.php000075500000000742000000000000011153 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * BaseDistance * * @author Jim Wigginton */ abstract class BaseDistance { const MAP = ['type' => ASN1::TYPE_INTEGER]; } ASN1/Maps/PublicKeyAndChallenge.php000075500000001235000000000000012741 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * PublicKeyAndChallenge * * @author Jim Wigginton */ abstract class PublicKeyAndChallenge { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'spki' => SubjectPublicKeyInfo::MAP, 'challenge' => ['type' => ASN1::TYPE_IA5_STRING] ] ]; } ASN1/Maps/AuthorityKeyIdentifier.php000075500000002123000000000000013265 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * AuthorityKeyIdentifier * * @author Jim Wigginton */ abstract class AuthorityKeyIdentifier { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'children' => [ 'keyIdentifier' => [ 'constant' => 0, 'optional' => true, 'implicit' => true ] + KeyIdentifier::MAP, 'authorityCertIssuer' => [ 'constant' => 1, 'optional' => true, 'implicit' => true ] + GeneralNames::MAP, 'authorityCertSerialNumber' => [ 'constant' => 2, 'optional' => true, 'implicit' => true ] + CertificateSerialNumber::MAP ] ]; } ASN1/Maps/BuiltInDomainDefinedAttributes.php000075500000001251000000000000014646 0ustar00 * @copyright 2016 Jim Wigginton * @license http://www.opensource.org/licenses/mit-license.html MIT License * @link http://phpseclib.sourceforge.net */ namespace phpseclib3\File\ASN1\Maps; use phpseclib3\File\ASN1; /** * BuiltInDomainDefinedAttributes * * @author Jim Wigginton */ abstract class BuiltInDomainDefinedAttributes { const MAP = [ 'type' => ASN1::TYPE_SEQUENCE, 'min' => 1, 'max' => 4, // ub-domain-defined-attributes 'children' => BuiltInDomainDefinedAttribute::MAP ]; } Exception/NoFileException.php000077500000000734000000000000012220 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_NO_FILE error occurred with UploadedFile. * * @author Florent Mata */ class NoFileException extends FileException { } Exception/IniSizeFileException.php000077500000000742000000000000013215 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_INI_SIZE error occurred with UploadedFile. * * @author Florent Mata */ class IniSizeFileException extends FileException { } Exception/CannotWriteFileException.php000077500000000750000000000000014077 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_CANT_WRITE error occurred with UploadedFile. * * @author Florent Mata */ class CannotWriteFileException extends FileException { } Exception/AccessDeniedException.php000077500000001132000000000000013347 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when the access on a file was denied. * * @author Bernhard Schussek */ class AccessDeniedException extends FileException { public function __construct(string $path) { parent::__construct(sprintf('The file %s could not be accessed', $path)); } } Exception/FileNotFoundException.php000077500000001112000000000000013367 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when a file was not found. * * @author Bernhard Schussek */ class FileNotFoundException extends FileException { public function __construct(string $path) { parent::__construct(sprintf('The file "%s" does not exist', $path)); } } Exception/UnexpectedTypeException.php000077500000001051000000000000014003 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; class UnexpectedTypeException extends FileException { public function __construct(mixed $value, string $expectedType) { parent::__construct(sprintf('Expected argument of type %s, %s given', $expectedType, get_debug_type($value))); } } Exception/FormSizeFileException.php000077500000000744000000000000013403 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_FORM_SIZE error occurred with UploadedFile. * * @author Florent Mata */ class FormSizeFileException extends FileException { } Exception/UploadException.php000077500000000715000000000000012267 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an error occurred during file upload. * * @author Bernhard Schussek */ class UploadException extends FileException { } Exception/PartialFileException.php000077500000000741000000000000013236 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_PARTIAL error occurred with UploadedFile. * * @author Florent Mata */ class PartialFileException extends FileException { } Exception/NoTmpDirFileException.php000077500000000745000000000000013342 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_NO_TMP_DIR error occurred with UploadedFile. * * @author Florent Mata */ class NoTmpDirFileException extends FileException { } Exception/ExtensionFileException.php000077500000000745000000000000013622 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an UPLOAD_ERR_EXTENSION error occurred with UploadedFile. * * @author Florent Mata */ class ExtensionFileException extends FileException { } Exception/FileException.php000077500000000722000000000000011720 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File\Exception; /** * Thrown when an error occurred in the component File. * * @author Bernhard Schussek */ class FileException extends \RuntimeException { } UploadedFile.php000077500000024564000000000000007573 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File; use Symfony\Component\HttpFoundation\File\Exception\CannotWriteFileException; use Symfony\Component\HttpFoundation\File\Exception\ExtensionFileException; use Symfony\Component\HttpFoundation\File\Exception\FileException; use Symfony\Component\HttpFoundation\File\Exception\FileNotFoundException; use Symfony\Component\HttpFoundation\File\Exception\FormSizeFileException; use Symfony\Component\HttpFoundation\File\Exception\IniSizeFileException; use Symfony\Component\HttpFoundation\File\Exception\NoFileException; use Symfony\Component\HttpFoundation\File\Exception\NoTmpDirFileException; use Symfony\Component\HttpFoundation\File\Exception\PartialFileException; use Symfony\Component\Mime\MimeTypes; /** * A file uploaded through a form. * * @author Bernhard Schussek * @author Florian Eckerstorfer * @author Fabien Potencier */ class UploadedFile extends File { private bool $test; private string $originalName; private string $mimeType; private int $error; private string $originalPath; /** * Accepts the information of the uploaded file as provided by the PHP global $_FILES. * * The file object is only created when the uploaded file is valid (i.e. when the * isValid() method returns true). Otherwise the only methods that could be called * on an UploadedFile instance are: * * * getClientOriginalName, * * getClientMimeType, * * isValid, * * getError. * * Calling any other method on an non-valid instance will cause an unpredictable result. * * @param string $path The full temporary path to the file * @param string $originalName The original file name of the uploaded file * @param string|null $mimeType The type of the file as provided by PHP; null defaults to application/octet-stream * @param int|null $error The error constant of the upload (one of PHP's UPLOAD_ERR_XXX constants); null defaults to UPLOAD_ERR_OK * @param bool $test Whether the test mode is active * Local files are used in test mode hence the code should not enforce HTTP uploads * * @throws FileException If file_uploads is disabled * @throws FileNotFoundException If the file does not exist */ public function __construct(string $path, string $originalName, ?string $mimeType = null, ?int $error = null, bool $test = false) { $this->originalName = $this->getName($originalName); $this->originalPath = strtr($originalName, '\\', '/'); $this->mimeType = $mimeType ?: 'application/octet-stream'; $this->error = $error ?: \UPLOAD_ERR_OK; $this->test = $test; parent::__construct($path, \UPLOAD_ERR_OK === $this->error); } /** * Returns the original file name. * * It is extracted from the request from which the file has been uploaded. * This should not be considered as a safe value to use for a file name on your servers. */ public function getClientOriginalName(): string { return $this->originalName; } /** * Returns the original file extension. * * It is extracted from the original file name that was uploaded. * This should not be considered as a safe value to use for a file name on your servers. */ public function getClientOriginalExtension(): string { return pathinfo($this->originalName, \PATHINFO_EXTENSION); } /** * Returns the original file full path. * * It is extracted from the request from which the file has been uploaded. * This should not be considered as a safe value to use for a file name/path on your servers. * * If this file was uploaded with the "webkitdirectory" upload directive, this will contain * the path of the file relative to the uploaded root directory. Otherwise this will be identical * to getClientOriginalName(). */ public function getClientOriginalPath(): string { return $this->originalPath; } /** * Returns the file mime type. * * The client mime type is extracted from the request from which the file * was uploaded, so it should not be considered as a safe value. * * For a trusted mime type, use getMimeType() instead (which guesses the mime * type based on the file content). * * @see getMimeType() */ public function getClientMimeType(): string { return $this->mimeType; } /** * Returns the extension based on the client mime type. * * If the mime type is unknown, returns null. * * This method uses the mime type as guessed by getClientMimeType() * to guess the file extension. As such, the extension returned * by this method cannot be trusted. * * For a trusted extension, use guessExtension() instead (which guesses * the extension based on the guessed mime type for the file). * * @see guessExtension() * @see getClientMimeType() */ public function guessClientExtension(): ?string { if (!class_exists(MimeTypes::class)) { throw new \LogicException('You cannot guess the extension as the Mime component is not installed. Try running "composer require symfony/mime".'); } return MimeTypes::getDefault()->getExtensions($this->getClientMimeType())[0] ?? null; } /** * Returns the upload error. * * If the upload was successful, the constant UPLOAD_ERR_OK is returned. * Otherwise one of the other UPLOAD_ERR_XXX constants is returned. */ public function getError(): int { return $this->error; } /** * Returns whether the file has been uploaded with HTTP and no error occurred. */ public function isValid(): bool { $isOk = \UPLOAD_ERR_OK === $this->error; return $this->test ? $isOk : $isOk && is_uploaded_file($this->getPathname()); } /** * Moves the file to a new location. * * @throws FileException if, for any reason, the file could not have been moved */ public function move(string $directory, ?string $name = null): File { if ($this->isValid()) { if ($this->test) { return parent::move($directory, $name); } $target = $this->getTargetFile($directory, $name); set_error_handler(function ($type, $msg) use (&$error) { $error = $msg; }); try { $moved = move_uploaded_file($this->getPathname(), $target); } finally { restore_error_handler(); } if (!$moved) { throw new FileException(sprintf('Could not move the file "%s" to "%s" (%s).', $this->getPathname(), $target, strip_tags($error))); } @chmod($target, 0666 & ~umask()); return $target; } switch ($this->error) { case \UPLOAD_ERR_INI_SIZE: throw new IniSizeFileException($this->getErrorMessage()); case \UPLOAD_ERR_FORM_SIZE: throw new FormSizeFileException($this->getErrorMessage()); case \UPLOAD_ERR_PARTIAL: throw new PartialFileException($this->getErrorMessage()); case \UPLOAD_ERR_NO_FILE: throw new NoFileException($this->getErrorMessage()); case \UPLOAD_ERR_CANT_WRITE: throw new CannotWriteFileException($this->getErrorMessage()); case \UPLOAD_ERR_NO_TMP_DIR: throw new NoTmpDirFileException($this->getErrorMessage()); case \UPLOAD_ERR_EXTENSION: throw new ExtensionFileException($this->getErrorMessage()); } throw new FileException($this->getErrorMessage()); } /** * Returns the maximum size of an uploaded file as configured in php.ini. * * @return int|float The maximum size of an uploaded file in bytes (returns float if size > PHP_INT_MAX) */ public static function getMaxFilesize(): int|float { $sizePostMax = self::parseFilesize(\ini_get('post_max_size')); $sizeUploadMax = self::parseFilesize(\ini_get('upload_max_filesize')); return min($sizePostMax ?: \PHP_INT_MAX, $sizeUploadMax ?: \PHP_INT_MAX); } private static function parseFilesize(string $size): int|float { if ('' === $size) { return 0; } $size = strtolower($size); $max = ltrim($size, '+'); if (str_starts_with($max, '0x')) { $max = \intval($max, 16); } elseif (str_starts_with($max, '0')) { $max = \intval($max, 8); } else { $max = (int) $max; } switch (substr($size, -1)) { case 't': $max *= 1024; // no break case 'g': $max *= 1024; // no break case 'm': $max *= 1024; // no break case 'k': $max *= 1024; } return $max; } /** * Returns an informative upload error message. */ public function getErrorMessage(): string { static $errors = [ \UPLOAD_ERR_INI_SIZE => 'The file "%s" exceeds your upload_max_filesize ini directive (limit is %d KiB).', \UPLOAD_ERR_FORM_SIZE => 'The file "%s" exceeds the upload limit defined in your form.', \UPLOAD_ERR_PARTIAL => 'The file "%s" was only partially uploaded.', \UPLOAD_ERR_NO_FILE => 'No file was uploaded.', \UPLOAD_ERR_CANT_WRITE => 'The file "%s" could not be written on disk.', \UPLOAD_ERR_NO_TMP_DIR => 'File could not be uploaded: missing temporary directory.', \UPLOAD_ERR_EXTENSION => 'File upload was stopped by a PHP extension.', ]; $errorCode = $this->error; $maxFilesize = \UPLOAD_ERR_INI_SIZE === $errorCode ? self::getMaxFilesize() / 1024 : 0; $message = $errors[$errorCode] ?? 'The file "%s" was not uploaded due to an unknown error.'; return sprintf($message, $this->getClientOriginalName(), $maxFilesize); } } Stream.php000077500000000737000000000000006465 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File; /** * A PHP stream of unknown size. * * @author Nicolas Grekas */ class Stream extends File { public function getSize(): int|false { return false; } } File.php000077500000010540000000000000006102 0ustar00 * * For the full copyright and license information, please view the LICENSE * file that was distributed with this source code. */ namespace Symfony\Component\HttpFoundation\File; use Symfony\Component\HttpFoundation\File\Exception\FileException; use Symfony\Component\HttpFoundation\File\Exception\FileNotFoundException; use Symfony\Component\Mime\MimeTypes; /** * A file in the file system. * * @author Bernhard Schussek */ class File extends \SplFileInfo { /** * Constructs a new file from the given path. * * @param string $path The path to the file * @param bool $checkPath Whether to check the path or not * * @throws FileNotFoundException If the given path is not a file */ public function __construct(string $path, bool $checkPath = true) { if ($checkPath && !is_file($path)) { throw new FileNotFoundException($path); } parent::__construct($path); } /** * Returns the extension based on the mime type. * * If the mime type is unknown, returns null. * * This method uses the mime type as guessed by getMimeType() * to guess the file extension. * * @see MimeTypes * @see getMimeType() */ public function guessExtension(): ?string { if (!class_exists(MimeTypes::class)) { throw new \LogicException('You cannot guess the extension as the Mime component is not installed. Try running "composer require symfony/mime".'); } return MimeTypes::getDefault()->getExtensions($this->getMimeType())[0] ?? null; } /** * Returns the mime type of the file. * * The mime type is guessed using a MimeTypeGuesserInterface instance, * which uses finfo_file() then the "file" system binary, * depending on which of those are available. * * @see MimeTypes */ public function getMimeType(): ?string { if (!class_exists(MimeTypes::class)) { throw new \LogicException('You cannot guess the mime type as the Mime component is not installed. Try running "composer require symfony/mime".'); } return MimeTypes::getDefault()->guessMimeType($this->getPathname()); } /** * Moves the file to a new location. * * @throws FileException if the target file could not be created */ public function move(string $directory, ?string $name = null): self { $target = $this->getTargetFile($directory, $name); set_error_handler(function ($type, $msg) use (&$error) { $error = $msg; }); try { $renamed = rename($this->getPathname(), $target); } finally { restore_error_handler(); } if (!$renamed) { throw new FileException(sprintf('Could not move the file "%s" to "%s" (%s).', $this->getPathname(), $target, strip_tags($error))); } @chmod($target, 0666 & ~umask()); return $target; } public function getContent(): string { $content = file_get_contents($this->getPathname()); if (false === $content) { throw new FileException(sprintf('Could not get the content of the file "%s".', $this->getPathname())); } return $content; } protected function getTargetFile(string $directory, ?string $name = null): self { if (!is_dir($directory)) { if (false === @mkdir($directory, 0777, true) && !is_dir($directory)) { throw new FileException(sprintf('Unable to create the "%s" directory.', $directory)); } } elseif (!is_writable($directory)) { throw new FileException(sprintf('Unable to write in the "%s" directory.', $directory)); } $target = rtrim($directory, '/\\').\DIRECTORY_SEPARATOR.(null === $name ? $this->getBasename() : $this->getName($name)); return new self($target, false); } /** * Returns locale independent base name of the given path. */ protected function getName(string $name): string { $originalName = str_replace('\\', '/', $name); $pos = strrpos($originalName, '/'); $originalName = false === $pos ? $originalName : substr($originalName, $pos + 1); return $originalName; } }