File Coverage

blib/lib/File/Listing.pm

Criterion	Covered	Total	%
statement	119	141	84.4
branch	59	102	57.8
condition	33	77	42.8
subroutine	18	21	85.7
pod	1	6	16.6
total	230	347	66.2

package File::Listing;

use strict;
use warnings;
use Carp ();
use HTTP::Date qw(str2time);
use Exporter 5.57 qw( import );

# ABSTRACT: Parse directory listing
our $VERSION = '6.16'; # VERSION

sub Version { $File::Listing::VERSION; }

our @EXPORT = qw(parse_dir);

sub parse_dir ($;$$$)
{
   my($dir, $tz, $fstype, $error) = @_;

   $fstype ||= 'unix';
   $fstype = "File::Listing::" . lc $fstype;

   my @args = $_[0];
   push(@args, $tz) if(@_ >= 2);
   push(@args, $error) if(@_ >= 4);

   $fstype->parse(@args);
}


sub line { Carp::croak("Not implemented yet"); }
sub init { } # Dummy sub


sub file_mode ($)
{
    Carp::croak("Input to file_mode() must be a 10 character string.")
        unless length($_[0]) == 10;

    # This routine was originally borrowed from Graham Barr's
    # Net::FTP package.

    local $_ = shift;
    my $mode = 0;
    my($type);

    s/^(.)// and $type = $1;

    # When the set-group-ID bit (file mode bit 02000) is set, and the group
    # execution bit (file mode bit 00020) is unset, and it is a regular file,
    # some implementations of `ls' use the letter `S', others use `l' or `L'.
    # Convert this `S'.

    s/[Ll](...)$/S$1/;

    while (/(.)/g) {
        $mode <<= 1;
        $mode |= 1 if $1 ne "-" &&
                      $1 ne "*" &&
                      $1 ne 'S' &&
                      $1 ne 'T';
    }

    $mode |= 0004000 if /^..s....../i;
    $mode |= 0002000 if /^.....s.../i;
    $mode |= 0001000 if /^........t/i;

    # De facto standard definitions. From 'stat.h' on Solaris 9.

    $type eq "p" and $mode |= 0010000 or        # fifo
    $type eq "c" and $mode |= 0020000 or        # character special
    $type eq "d" and $mode |= 0040000 or        # directory
    $type eq "b" and $mode |= 0060000 or        # block special
    $type eq "-" and $mode |= 0100000 or        # regular
    $type eq "l" and $mode |= 0120000 or        # symbolic link
    $type eq "s" and $mode |= 0140000 or        # socket
    $type eq "D" and $mode |= 0150000 or        # door
      Carp::croak("Unknown file type: $type");

    $mode;
}


sub parse
{
   my($pkg, $dir, $tz, $error) = @_;

   # First let's try to determine what kind of dir parameter we have
   # received.  We allow both listings, reference to arrays and
   # file handles to read from.

   if (ref($dir) eq 'ARRAY') {
       # Already split up
   }
   elsif (ref($dir) eq 'GLOB') {
       # A file handle
   }
   elsif (ref($dir)) {
      Carp::croak("Illegal argument to parse_dir()");
   }
   elsif ($dir =~ /^\*\w+(::\w+)+$/) {
      # This scalar looks like a file handle, so we assume it is
   }
   else {
      # A normal scalar listing
      $dir = [ split(/\n/, $dir) ];
   }

   $pkg->init();

   my @files = ();
   if (ref($dir) eq 'ARRAY') {
       for (@$dir) {
           push(@files, $pkg->line($_, $tz, $error));
       }
   }
   else {
       local($_);
       while (my $line = <$dir>) {
           chomp $line;
           push(@files, $pkg->line($line, $tz, $error));
       }
   }
   wantarray ? @files : \@files;  ## no critic (Community::Wantarray)
}



package File::Listing::unix;

use HTTP::Date qw(str2time);

our @ISA = qw(File::Listing);

# A place to remember current directory from last line parsed.
our $curdir;

sub init
{
    $curdir = '';
}


sub line
{
    shift; # package name
    local($_) = shift;
    my($tz, $error) = @_;

    s/\015//g;
    #study;

    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 )

    {
        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 ();
    }
    elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
        return ();
    }
    elsif (/not found/    || # OSF1, HPUX, and SunOS return
             # "$file not found"
             /No such file/ || # IRIX returns
             # "UX:ls: ERROR: Cannot access $file: No such file or directory"
                               # Solaris returns
             # "$file: No such file or directory"
             /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 ();
    }
    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 ();
    }
    else {
        # parse failed, check if the dosftp parse understands it
        File::Listing::dosftp->init();
        return(File::Listing::dosftp->line($_,$tz,$error));
    }

}



package File::Listing::dosftp;

use HTTP::Date qw(str2time);

our @ISA = qw(File::Listing);

# A place to remember current directory from last line parsed.
our $curdir;



sub init
{
    $curdir = '';
}


sub line
{
    shift; # package name
    local($_) = shift;
    my($tz, $error) = @_;

    s/\015//g;

    my ($date, $size_or_dir, $name, $size);

    # usual format:
    # 02-05-96  10:48AM                 1415 src.slf
    # 09-10-96  09:18AM                 sl_util
    # alternative dos format with four-digit year:
    # 02-05-2022  10:48AM                 1415 src.slf
    # 09-10-2022  09:18AM                 sl_util
    if (($date, $size_or_dir, $name) =
        /^(\d\d-\d\d-\d{2,4}\s+\d\d:\d\d\wM)      # Date and time info
         \s+                                      # Some space
         (<\w{3}>|\d+)                            # Dir or Size
         \s+                                      # Some more space
         (.+)$                                    # File name
        /x )
    {
        return if $name eq '.' || $name eq '..';
        $name = "$curdir/$name" if length $curdir;
        my $type = '?';
        if ($size_or_dir eq '') {
            $type = "d";
            $size = ""; # directories have no size in the pc listing
        }
        else {
            $type = 'f';
            $size = $size_or_dir;
        }
        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 ();
    }

}



package File::Listing::vms;
our @ISA = qw(File::Listing);

package File::Listing::netware;
our @ISA = qw(File::Listing);



package File::Listing::apache;

our @ISA = qw(File::Listing);


sub init { }


sub line {
    shift; # package name
    local($_) = shift;
    my($tz, $error) = @_; # ignored for now...

    s!]*>! !g;  # clean away various table stuff
    if (m!.*.*?(\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!.*!i) {
        my $filename = $1;
        my $filetype = ($filename =~ s|/$|| ? "d" : "f");
        return [$filename, $filetype, undef, undef, undef];
    }

    return ();
}


sub _guess_year {
    my $y = shift;

    # 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;
}


sub _monthabbrev_number {
    my $mon = shift;
    +{'Jan' => 1,
      'Feb' => 2,
      'Mar' => 3,
      'Apr' => 4,
      'May' => 5,
      'Jun' => 6,
      'Jul' => 7,
      'Aug' => 8,
      'Sep' => 9,
      'Oct' => 10,
      'Nov' => 11,
      'Dec' => 12,
     }->{$mon};
}


1;

__END__