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