diff options
author | Norbert Preining <norbert@preining.info> | 2021-04-02 03:20:54 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2021-04-02 03:20:54 +0000 |
commit | 3f173002d4a4a84e7d1fa5a74755fdd00d08a9c2 (patch) | |
tree | 5ed380344702de1f9ab53b68b6c3bcd6b8458087 /systems/texlive/tlnet/tlpkg/tlperl/site/lib/File | |
parent | f78ba658b3ecd56053fe0837a4404d0c6c16a707 (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.pm | 463 |
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 |