"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/File/Listing.pm" (5 Apr 2016, 10630 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package File::Listing;
    2 
    3 sub Version { $VERSION; }
    4 $VERSION = "6.04";
    5 
    6 require Exporter;
    7 @ISA = qw(Exporter);
    8 @EXPORT = qw(parse_dir);
    9 
   10 use strict;
   11 
   12 use Carp ();
   13 use HTTP::Date qw(str2time);
   14 
   15 
   16 
   17 sub parse_dir ($;$$$)
   18 {
   19    my($dir, $tz, $fstype, $error) = @_;
   20 
   21    $fstype ||= 'unix';
   22    $fstype = "File::Listing::" . lc $fstype;
   23 
   24    my @args = $_[0];
   25    push(@args, $tz) if(@_ >= 2);
   26    push(@args, $error) if(@_ >= 4);
   27 
   28    $fstype->parse(@args);
   29 }
   30 
   31 
   32 sub line { Carp::croak("Not implemented yet"); }
   33 sub init { } # Dummy sub
   34 
   35 
   36 sub file_mode ($)
   37 {
   38     Carp::croak("Input to file_mode() must be a 10 character string.")
   39         unless length($_[0]) == 10;
   40 
   41     # This routine was originally borrowed from Graham Barr's
   42     # Net::FTP package.
   43 
   44     local $_ = shift;
   45     my $mode = 0;
   46     my($type);
   47 
   48     s/^(.)// and $type = $1;
   49 
   50     # When the set-group-ID bit (file mode bit 02000) is set, and the group
   51     # execution bit (file mode bit 00020) is unset, and it is a regular file,
   52     # some implementations of `ls' use the letter `S', others use `l' or `L'.
   53     # Convert this `S'.
   54 
   55     s/[Ll](...)$/S$1/;
   56 
   57     while (/(.)/g) {
   58     $mode <<= 1;
   59     $mode |= 1 if $1 ne "-" &&
   60               $1 ne 'S' &&
   61               $1 ne 'T';
   62     }
   63 
   64     $mode |= 0004000 if /^..s....../i;
   65     $mode |= 0002000 if /^.....s.../i;
   66     $mode |= 0001000 if /^........t/i;
   67 
   68     # De facto standard definitions. From 'stat.h' on Solaris 9.
   69 
   70     $type eq "p" and $mode |= 0010000 or        # fifo
   71     $type eq "c" and $mode |= 0020000 or        # character special
   72     $type eq "d" and $mode |= 0040000 or        # directory
   73     $type eq "b" and $mode |= 0060000 or        # block special
   74     $type eq "-" and $mode |= 0100000 or        # regular
   75     $type eq "l" and $mode |= 0120000 or        # symbolic link
   76     $type eq "s" and $mode |= 0140000 or        # socket
   77     $type eq "D" and $mode |= 0150000 or        # door
   78       Carp::croak("Unknown file type: $type");
   79 
   80     $mode;
   81 }
   82 
   83 
   84 sub parse
   85 {
   86    my($pkg, $dir, $tz, $error) = @_;
   87 
   88    # First let's try to determine what kind of dir parameter we have
   89    # received.  We allow both listings, reference to arrays and
   90    # file handles to read from.
   91 
   92    if (ref($dir) eq 'ARRAY') {
   93        # Already splitted up
   94    }
   95    elsif (ref($dir) eq 'GLOB') {
   96        # A file handle
   97    }
   98    elsif (ref($dir)) {
   99       Carp::croak("Illegal argument to parse_dir()");
  100    }
  101    elsif ($dir =~ /^\*\w+(::\w+)+$/) {
  102       # This scalar looks like a file handle, so we assume it is
  103    }
  104    else {
  105       # A normal scalar listing
  106       $dir = [ split(/\n/, $dir) ];
  107    }
  108 
  109    $pkg->init();
  110 
  111    my @files = ();
  112    if (ref($dir) eq 'ARRAY') {
  113        for (@$dir) {
  114        push(@files, $pkg->line($_, $tz, $error));
  115        }
  116    }
  117    else {
  118        local($_);
  119        while (<$dir>) {
  120        chomp;
  121        push(@files, $pkg->line($_, $tz, $error));
  122        }
  123    }
  124    wantarray ? @files : \@files;
  125 }
  126 
  127 
  128 
  129 package File::Listing::unix;
  130 
  131 use HTTP::Date qw(str2time);
  132 
  133 # A place to remember current directory from last line parsed.
  134 use vars qw($curdir @ISA);
  135 
  136 @ISA = qw(File::Listing);
  137 
  138 
  139 
  140 sub init
  141 {
  142     $curdir = '';
  143 }
  144 
  145 
  146 sub line
  147 {
  148     shift; # package name
  149     local($_) = shift;
  150     my($tz, $error) = @_;
  151 
  152     s/\015//g;
  153     #study;
  154 
  155     my ($kind, $size, $date, $name);
  156     if (($kind, $size, $date, $name) =
  157     /^([\-FlrwxsStTdD]{10})                   # Type and permission bits
  158      .*                                       # Graps
  159      \D(\d+)                                  # File size
  160      \s+                                      # Some space
  161      (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2})  # Date
  162      \s+                                      # Some more space
  163      (.*)$                                    # File name
  164     /x )
  165 
  166     {
  167     return if $name eq '.' || $name eq '..';
  168     $name = "$curdir/$name" if length $curdir;
  169     my $type = '?';
  170     if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
  171         $name = $1;
  172         $type = "l $2";
  173     }
  174     elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
  175         $type = 'f';
  176     }
  177     elsif ($kind =~ /^[dD]/) {
  178         $type = 'd';
  179         $size = undef;  # Don't believe the reported size
  180     }
  181     return [$name, $type, $size, str2time($date, $tz), 
  182               File::Listing::file_mode($kind)];
  183 
  184     }
  185     elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
  186     my $dir = $1;
  187     return () if $dir eq '.';
  188     $curdir = $dir;
  189     return ();
  190     }
  191     elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
  192     return ();
  193     }
  194     elsif (/not found/    || # OSF1, HPUX, and SunOS return
  195              # "$file not found"
  196              /No such file/ || # IRIX returns
  197              # "UX:ls: ERROR: Cannot access $file: No such file or directory"
  198                                # Solaris returns
  199              # "$file: No such file or directory"
  200              /cannot find/     # Windows NT returns
  201              # "The system cannot find the path specified."
  202              ) {
  203     return () unless defined $error;
  204     &$error($_) if ref($error) eq 'CODE';
  205     warn "Error: $_\n" if $error eq 'warn';
  206     return ();
  207     }
  208     elsif ($_ eq '') {       # AIX, and Linux return nothing
  209     return () unless defined $error;
  210     &$error("No such file or directory") if ref($error) eq 'CODE';
  211     warn "Warning: No such file or directory\n" if $error eq 'warn';
  212     return ();
  213     }
  214     else {
  215         # parse failed, check if the dosftp parse understands it
  216         File::Listing::dosftp->init();
  217         return(File::Listing::dosftp->line($_,$tz,$error));
  218     }
  219 
  220 }
  221 
  222 
  223 
  224 package File::Listing::dosftp;
  225 
  226 use HTTP::Date qw(str2time);
  227 
  228 # A place to remember current directory from last line parsed.
  229 use vars qw($curdir @ISA);
  230 
  231 @ISA = qw(File::Listing);
  232 
  233 
  234 
  235 sub init
  236 {
  237     $curdir = '';
  238 }
  239 
  240 
  241 sub line
  242 {
  243     shift; # package name
  244     local($_) = shift;
  245     my($tz, $error) = @_;
  246 
  247     s/\015//g;
  248 
  249     my ($date, $size_or_dir, $name, $size);
  250 
  251     # 02-05-96  10:48AM                 1415 src.slf
  252     # 09-10-96  09:18AM       <DIR>          sl_util
  253     if (($date, $size_or_dir, $name) =
  254         /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM)         # Date and time info
  255          \s+                                      # Some space
  256          (<\w{3}>|\d+)                            # Dir or Size
  257          \s+                                      # Some more space
  258          (.+)$                                    # File name
  259         /x )
  260     {
  261     return if $name eq '.' || $name eq '..';
  262     $name = "$curdir/$name" if length $curdir;
  263     my $type = '?';
  264     if ($size_or_dir eq '<DIR>') {
  265         $type = "d";
  266             $size = ""; # directories have no size in the pc listing
  267         }
  268         else {
  269         $type = 'f';
  270             $size = $size_or_dir;
  271     }
  272     return [$name, $type, $size, str2time($date, $tz), undef];
  273     }
  274     else {
  275     return () unless defined $error;
  276     &$error($_) if ref($error) eq 'CODE';
  277     warn "Can't parse: $_\n" if $error eq 'warn';
  278     return ();
  279     }
  280 
  281 }
  282 
  283 
  284 
  285 package File::Listing::vms;
  286 @File::Listing::vms::ISA = qw(File::Listing);
  287 
  288 package File::Listing::netware;
  289 @File::Listing::netware::ISA = qw(File::Listing);
  290 
  291 
  292 
  293 package File::Listing::apache;
  294 
  295 use vars qw(@ISA);
  296 
  297 @ISA = qw(File::Listing);
  298 
  299 
  300 sub init { }
  301 
  302 
  303 sub line {
  304     shift; # package name
  305     local($_) = shift;
  306     my($tz, $error) = @_; # ignored for now...
  307 
  308     s!</?t[rd][^>]*>! !g;  # clean away various table stuff
  309     if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
  310     my($filename, $filesize) = ($1, $7);
  311     my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
  312     if ($m =~ /^\d+$/) {
  313         ($d,$y) = ($y,$d) # iso date
  314     }
  315     else {
  316         $m = _monthabbrev_number($m);
  317     }
  318 
  319     $filesize = 0 if $filesize eq '-';
  320     if ($filesize =~ s/k$//i) {
  321         $filesize *= 1024;
  322     }
  323     elsif ($filesize =~ s/M$//) {
  324         $filesize *= 1024*1024;
  325     }
  326     elsif ($filesize =~ s/G$//) {
  327         $filesize *= 1024*1024*1024;
  328     }
  329     $filesize = int $filesize;
  330 
  331     require Time::Local;
  332     my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900);
  333     my $filetype = ($filename =~ s|/$|| ? "d" : "f");
  334     return [$filename, $filetype, $filesize, $filetime, undef];
  335     }
  336 
  337     return ();
  338 }
  339 
  340 
  341 sub _guess_year {
  342     my $y = shift;
  343     if ($y >= 90) {
  344     $y = 1900+$y;
  345     }
  346     elsif ($y < 100) {
  347     $y = 2000+$y;
  348     }
  349     $y;
  350 }
  351 
  352 
  353 sub _monthabbrev_number {
  354     my $mon = shift;
  355     +{'Jan' => 1,
  356       'Feb' => 2,
  357       'Mar' => 3,
  358       'Apr' => 4,
  359       'May' => 5,
  360       'Jun' => 6,
  361       'Jul' => 7,
  362       'Aug' => 8,
  363       'Sep' => 9,
  364       'Oct' => 10,
  365       'Nov' => 11,
  366       'Dec' => 12,
  367      }->{$mon};
  368 }
  369 
  370 
  371 1;
  372 
  373 __END__
  374 
  375 =head1 NAME
  376 
  377 File::Listing - parse directory listing
  378 
  379 =head1 SYNOPSIS
  380 
  381  use File::Listing qw(parse_dir);
  382  $ENV{LANG} = "C";  # dates in non-English locales not supported
  383  for (parse_dir(`ls -l`)) {
  384      ($name, $type, $size, $mtime, $mode) = @$_;
  385      next if $type ne 'f'; # plain file
  386      #...
  387  }
  388 
  389  # directory listing can also be read from a file
  390  open(LISTING, "zcat ls-lR.gz|");
  391  $dir = parse_dir(\*LISTING, '+0000');
  392 
  393 =head1 DESCRIPTION
  394 
  395 This module exports a single function called parse_dir(), which can be
  396 used to parse directory listings.
  397 
  398 The first parameter to parse_dir() is the directory listing to parse.
  399 It can be a scalar, a reference to an array of directory lines or a
  400 glob representing a filehandle to read the directory listing from.
  401 
  402 The second parameter is the time zone to use when parsing time stamps
  403 in the listing. If this value is undefined, then the local time zone is
  404 assumed.
  405 
  406 The third parameter is the type of listing to assume.  Currently
  407 supported formats are 'unix', 'apache' and 'dosftp'.  The default
  408 value is 'unix'.  Ideally, the listing type should be determined
  409 automatically.
  410 
  411 The fourth parameter specifies how unparseable lines should be treated.
  412 Values can be 'ignore', 'warn' or a code reference.  Warn means that
  413 the perl warn() function will be called.  If a code reference is
  414 passed, then this routine will be called and the return value from it
  415 will be incorporated in the listing.  The default is 'ignore'.
  416 
  417 Only the first parameter is mandatory.
  418 
  419 The return value from parse_dir() is a list of directory entries.  In
  420 a scalar context the return value is a reference to the list.  The
  421 directory entries are represented by an array consisting of [
  422 $filename, $filetype, $filesize, $filetime, $filemode ].  The
  423 $filetype value is one of the letters 'f', 'd', 'l' or '?'.  The
  424 $filetime value is the seconds since Jan 1, 1970.  The
  425 $filemode is a bitmask like the mode returned by stat().
  426 
  427 =head1 COPYRIGHT
  428 
  429 Copyright 1996-2010, Gisle Aas
  430 
  431 Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
  432 Net::FTP's parse_dir (Graham Barr).
  433 
  434 This library is free software; you can redistribute it and/or
  435 modify it under the same terms as Perl itself.