summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2021-04-02 03:20:54 +0000
committerNorbert Preining <norbert@preining.info>2021-04-02 03:20:54 +0000
commit3f173002d4a4a84e7d1fa5a74755fdd00d08a9c2 (patch)
tree5ed380344702de1f9ab53b68b6c3bcd6b8458087 /systems/texlive/tlnet/tlpkg/tlperl/site/lib/File
parentf78ba658b3ecd56053fe0837a4404d0c6c16a707 (diff)
CTAN sync 202104020320
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/File')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm463
1 files changed, 322 insertions, 141 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm
index c8d72a7185..b94c5b3910 100644
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm
@@ -1,18 +1,17 @@
package File::Listing;
-sub Version { $VERSION; }
-$VERSION = "6.04";
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(parse_dir);
-
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 ($;$$$)
{
@@ -55,10 +54,11 @@ sub file_mode ($)
s/[Ll](...)$/S$1/;
while (/(.)/g) {
- $mode <<= 1;
- $mode |= 1 if $1 ne "-" &&
- $1 ne 'S' &&
- $1 ne 'T';
+ $mode <<= 1;
+ $mode |= 1 if $1 ne "-" &&
+ $1 ne "*" &&
+ $1 ne 'S' &&
+ $1 ne 'T';
}
$mode |= 0004000 if /^..s....../i;
@@ -90,7 +90,7 @@ sub parse
# file handles to read from.
if (ref($dir) eq 'ARRAY') {
- # Already splitted up
+ # Already split up
}
elsif (ref($dir) eq 'GLOB') {
# A file handle
@@ -111,17 +111,17 @@ sub parse
my @files = ();
if (ref($dir) eq 'ARRAY') {
for (@$dir) {
- push(@files, $pkg->line($_, $tz, $error));
+ push(@files, $pkg->line($_, $tz, $error));
}
}
else {
local($_);
- while (<$dir>) {
- chomp;
- push(@files, $pkg->line($_, $tz, $error));
+ while (my $line = <$dir>) {
+ chomp $line;
+ push(@files, $pkg->line($line, $tz, $error));
}
}
- wantarray ? @files : \@files;
+ wantarray ? @files : \@files; ## no critic (Freenode::Wantarray)
}
@@ -130,12 +130,10 @@ package File::Listing::unix;
use HTTP::Date qw(str2time);
-# A place to remember current directory from last line parsed.
-use vars qw($curdir @ISA);
-
-@ISA = qw(File::Listing);
-
+our @ISA = qw(File::Listing);
+# A place to remember current directory from last line parsed.
+our $curdir;
sub init
{
@@ -154,42 +152,42 @@ sub line
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 )
+ /^([\-\*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),
+ 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 ();
+ my $dir = $1;
+ return () if $dir eq '.';
+ $curdir = $dir;
+ return ();
}
elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
- return ();
+ return ();
}
elsif (/not found/ || # OSF1, HPUX, and SunOS return
# "$file not found"
@@ -200,16 +198,16 @@ sub line
/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 ();
+ 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 ();
+ 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
@@ -225,10 +223,10 @@ package File::Listing::dosftp;
use HTTP::Date qw(str2time);
-# A place to remember current directory from last line parsed.
-use vars qw($curdir @ISA);
+our @ISA = qw(File::Listing);
-@ISA = qw(File::Listing);
+# A place to remember current directory from last line parsed.
+our $curdir;
@@ -258,24 +256,24 @@ sub line
(.+)$ # File name
/x )
{
- return if $name eq '.' || $name eq '..';
- $name = "$curdir/$name" if length $curdir;
- my $type = '?';
- if ($size_or_dir eq '<DIR>') {
- $type = "d";
+ return if $name eq '.' || $name eq '..';
+ $name = "$curdir/$name" if length $curdir;
+ my $type = '?';
+ if ($size_or_dir eq '<DIR>') {
+ $type = "d";
$size = ""; # directories have no size in the pc listing
}
else {
- $type = 'f';
+ $type = 'f';
$size = $size_or_dir;
- }
- return [$name, $type, $size, str2time($date, $tz), undef];
+ }
+ 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 ();
+ return () unless defined $error;
+ &$error($_) if ref($error) eq 'CODE';
+ warn "Can't parse: $_\n" if $error eq 'warn';
+ return ();
}
}
@@ -283,18 +281,16 @@ sub line
package File::Listing::vms;
-@File::Listing::vms::ISA = qw(File::Listing);
+our @ISA = qw(File::Listing);
package File::Listing::netware;
-@File::Listing::netware::ISA = qw(File::Listing);
+our @ISA = qw(File::Listing);
package File::Listing::apache;
-use vars qw(@ISA);
-
-@ISA = qw(File::Listing);
+our @ISA = qw(File::Listing);
sub init { }
@@ -306,32 +302,41 @@ sub line {
my($tz, $error) = @_; # ignored for now...
s!</?t[rd][^>]*>! !g; # clean away various table stuff
- if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
- my($filename, $filesize) = ($1, $7);
- my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
- if ($m =~ /^\d+$/) {
- ($d,$y) = ($y,$d) # iso date
- }
- else {
- $m = _monthabbrev_number($m);
- }
-
- $filesize = 0 if $filesize eq '-';
- if ($filesize =~ s/k$//i) {
- $filesize *= 1024;
- }
- elsif ($filesize =~ s/M$//) {
- $filesize *= 1024*1024;
- }
- elsif ($filesize =~ s/G$//) {
- $filesize *= 1024*1024*1024;
- }
- $filesize = int $filesize;
-
- require Time::Local;
- my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900);
- my $filetype = ($filename =~ s|/$|| ? "d" : "f");
- return [$filename, $filetype, $filesize, $filetime, undef];
+ if (m!<A\s+HREF=\"([^?\"]+)\">.*</A>.*?(\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!<A\s+HREF=\"([^?/\"]+/?)\">.*</A>!i) {
+ my $filename = $1;
+ my $filetype = ($filename =~ s|/$|| ? "d" : "f");
+ return [$filename, $filetype, undef, undef, undef];
}
return ();
@@ -340,11 +345,23 @@ sub line {
sub _guess_year {
my $y = shift;
- if ($y >= 90) {
- $y = 1900+$y;
+
+ # 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 = 2000+$y;
}
$y;
}
@@ -372,64 +389,228 @@ sub _monthabbrev_number {
__END__
+=pod
+
+=encoding UTF-8
+
=head1 NAME
-File::Listing - parse directory listing
+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
- for (parse_dir(`ls -l`)) {
- ($name, $type, $size, $mtime, $mode) = @$_;
+ 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(LISTING, "zcat ls-lR.gz|");
- $dir = parse_dir(\*LISTING, '+0000');
+ open my $listing, "zcat ls-lR.gz|";
+ $dir = parse_dir($listing, '+0000');
=head1 DESCRIPTION
-This module exports a single function called parse_dir(), which can be
+This module exports a single function called C<parse_dir>, which can be
used to parse directory listings.
-The first parameter to parse_dir() is the directory listing to parse.
+=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 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 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 is the type of listing to assume. Currently
-supported formats are 'unix', 'apache' and 'dosftp'. The default
-value is 'unix'. Ideally, the listing type should be determined
-automatically.
+The 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 specifies how unparseable lines should be treated.
-Values can be 'ignore', 'warn' or a code reference. Warn means that
-the perl warn() function will be called. If a code reference is
-passed, then this routine will be called and the return value from it
-will be incorporated in the listing. The default is 'ignore'.
+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.
-The return value from parse_dir() is a list of directory entries. In
-a scalar context the return value is a reference to the list. The
-directory entries are represented by an array consisting of [
-$filename, $filetype, $filesize, $filetime, $filemode ]. The
-$filetype value is one of the letters 'f', 'd', 'l' or '?'. The
-$filetime value is the seconds since Jan 1, 1970. The
-$filemode is a bitmask like the mode returned by stat().
+ # 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<f> file, C<d> directory, C<l> 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<stat>.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<File::Listing::Ftpcopy>
+
+Provides the same interface but uses XS and the parser implementation from C<ftpcopy>.
+
+=back
+
+=head1 AUTHOR
+
+Original author: Gisle Aas
+
+Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
+
+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
+=head1 COPYRIGHT AND LICENSE
-Copyright 1996-2010, Gisle Aas
+This software is copyright (c) 1996-2020 by Gisle Aas.
-Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
-Net::FTP's parse_dir (Graham Barr).
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+=cut