diff options
Diffstat (limited to 'gnu/usr.bin/perl/lib/File')
| -rw-r--r-- | gnu/usr.bin/perl/lib/File/Compare.pm | 143 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/lib/File/DosGlob.pm | 250 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/lib/File/stat.pm | 113 |
3 files changed, 506 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/lib/File/Compare.pm b/gnu/usr.bin/perl/lib/File/Compare.pm new file mode 100644 index 00000000000..2f9c45c4c60 --- /dev/null +++ b/gnu/usr.bin/perl/lib/File/Compare.pm @@ -0,0 +1,143 @@ +package File::Compare; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); + +require Exporter; +use Carp; + +$VERSION = '1.1001'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp); + +$Too_Big = 1024 * 1024 * 2; + +sub VERSION { + # Version of File::Compare + return $File::Compare::VERSION; +} + +sub compare { + croak("Usage: compare( file1, file2 [, buffersize]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + my $closefrom=0; + my $closeto=0; + my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf); + local(*FROM, *TO); + local($\) = ''; + + 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; + binmode FROM; + $closefrom = 1; + $fromsize = -s FROM; + } + + 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; + $closeto = 1; + } + + if ($closefrom && $closeto) { + # If both are opened files we know they differ if their size differ + goto fail_inner if $fromsize != -s TO; + } + + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for compare: $size\n") unless ($size > 0); + } else { + $size = $fromsize; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $fbuf = ''; + $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) and $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) { + $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +*cmp = \&compare; + +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. + +=head1 RETURN + +File::Compare::compare return 0 if the files are equal, 1 if the +files are unequal, or -1 if an error was encountered. + +=head1 AUTHOR + +File::Compare was written by Nick Ing-Simmons. +Its original documentation was written by Chip Salzenberg. + +=cut + diff --git a/gnu/usr.bin/perl/lib/File/DosGlob.pm b/gnu/usr.bin/perl/lib/File/DosGlob.pm new file mode 100644 index 00000000000..4597c715640 --- /dev/null +++ b/gnu/usr.bin/perl/lib/File/DosGlob.pm @@ -0,0 +1,250 @@ +#!perl -w + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +unless (caller) { + $| = 1; + while (@ARGV) { + # + # We have to do this one by one for compatibility reasons. + # If an arg doesn't match anything, we are supposed to return + # the original arg. I know, it stinks, eh? + # + my $arg = shift; + my @m = doglob(1,$arg); + print (@m ? join("\0", sort @m) : $arg); + print "\0" if @ARGV; + } +} + +sub doglob { + my $cond = shift; + my @retval = (); + #print "doglob: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = '.'; + my $sepchr = '/'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"$/) { + $_ = $1; + if ($cond eq 'd') { push(@retval, $_) if -d $_ } + else { push(@retval, $_) if -e $_ } + next OUTER; + } + if (m|^(.*)([\\/])([^\\/]*)$|) { + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), 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]:$/; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + unless (/[*?]/) { + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + $head .= $_; + if ($cond eq 'd') { push(@retval,$head) if -d $head } + else { push(@retval,$head) if -e $head } + next OUTER; + } + opendir(D, $head) or next OUTER; + my @leaves = readdir D; + closedir D; + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + + # escape regex metachars but not glob chars + s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex + s/\*/.*/g; + s/\?/.?/g; + + #print "regex: '$_', head: '$head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }'; + warn($@), next OUTER if $@; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$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($_,'\\.') != -1) { + push(@matched, "$head$e"), next INNER if &$matchsub("$e."); + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# this can be used to override CORE::glob in a specific +# package by saying C<use File::DosGlob 'glob';> in that +# namespace. +# + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my $pat = shift; + my $cxix = shift; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + $entries{$cxix} = [doglob(1,$pat)]; + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +sub import { + my $pkg = shift; + my $callpkg = caller(0); + my $sym = shift; + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} + if defined($sym) and $sym eq 'glob'; +} + +1; + +__END__ + +=head1 NAME + +File::DosGlob - DOS like globbing and then some + +perlglob.bat - a more capable perlglob.exe replacement + +=head1 SYNOPSIS + + require 5.004; + + # override CORE::glob in current package + use File::DosGlob 'glob'; + + @perlfiles = glob "..\\pe?l/*.p?"; + print <..\\pe?l/*.p?>; + + # from the command line (overrides only in main::) + > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" + + > perlglob ../pe*/*p? + +=head1 DESCRIPTION + +A module that implements DOS-like globbing with a few enhancements. +This file is also a portable replacement for perlglob.exe. 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. + +When invoked as a program, it will print null-separated filenames +to standard output. + +While one may replace perlglob.exe with this, usage by overriding +CORE::glob via importation should be much more efficient, because +it avoids launching a separate process, and is therefore strongly +recommended. Note that it is currently possible to override +builtins like glob() only on a per-package basis, not "globally". +Thus, every namespace that wants to override glob() must explicitly +request the override. See L<perlsub>. + +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 optimizium too. + +=head1 AUTHOR + +Gurusamy Sarathy <gsar@umich.edu> + +=head1 HISTORY + +=over 4 + +=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 + +=cut + diff --git a/gnu/usr.bin/perl/lib/File/stat.pm b/gnu/usr.bin/perl/lib/File/stat.pm new file mode 100644 index 00000000000..f5d17f7da44 --- /dev/null +++ b/gnu/usr.bin/perl/lib/File/stat.pm @@ -0,0 +1,113 @@ +package File::stat; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(stat lstat); + @EXPORT_OK = qw( $st_dev $st_ino $st_mode + $st_nlink $st_uid $st_gid + $st_rdev $st_size + $st_atime $st_mtime $st_ctime + $st_blksize $st_blocks + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'File::stat' => [ + map { $_ => '$' } qw{ + dev ino mode nlink uid gid rdev size + atime mtime ctime blksize blocks + } +]; + +sub populate (@) { + return unless @_; + my $stob = new(); + @$stob = ( + $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, + $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) + = @_; + return $stob; +} + +sub lstat ($) { populate(CORE::lstat(shift)) } + +sub stat ($) { + my $arg = shift; + my $st = populate(CORE::stat $arg); + return $st if $st; + no strict 'refs'; + require Symbol; + return populate(CORE::stat \*{Symbol::qualify($arg)}); +} + +1; +__END__ + +=head1 NAME + +File::stat - by-name interface to Perl's built-in stat() functions + +=head1 SYNOPSIS + + use File::stat; + $st = stat($file) or die "No $file: $!"; + if ( ($st->mode & 0111) && $st->nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + + use File::stat qw(:FIELDS); + stat($file) or die "No $file: $!"; + if ( ($st_mode & 0111) && $st_nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + +=head1 DESCRIPTION + +This module's default exports override the core stat() +and lstat() functions, replacing them with versions that return +"File::stat" objects. This object has methods that +return the similarly named structure field name from the +stat(2) function; namely, +dev, +ino, +mode, +nlink, +uid, +gid, +rdev, +size, +atime, +mtime, +ctime, +blksize, +and +blocks. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your stat() and lstat() functions.) Access these fields as +variables named with a preceding C<st_> in front their method names. +Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import +the fields. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 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 |