git.maemo.org Git - dh-make-perl/blob - dev/arm/libwww-perl/libwww-perl-5.813/debian/libwww-perl/usr/share/perl5/File/Listing.pm

   1 package File::Listing;
   2
   3 sub Version { $VERSION; }
   4 $VERSION = "5.810";
   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);
 118 no strict qw(vars);
 119
 120 @ISA = qw(File::Listing);
 121
 122
 123
 124 sub init
 125 {
 126     $curdir = '';
 127 }
 128
 129
 130 sub line
 131 {
 132     shift; # package name
 133     local($_) = shift;
 134     my($tz, $error) = @_;
 135
 136     s/\015//g;
 137     #study;
 138
 139     my ($kind, $size, $date, $name);
 140     if (($kind, $size, $date, $name) =
 141         /^([\-FlrwxsStTdD]{10})                   # Type and permission bits
 142          .*                                       # Graps
 143          \D(\d+)                                  # File size
 144          \s+                                      # Some space
 145          (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4}))  # Date
 146          \s+                                      # Some more space
 147          (.*)$                                    # File name
 148         /x )
 149
 150     {
 151         return if $name eq '.' || $name eq '..';
 152         $name = "$curdir/$name" if length $curdir;
 153         my $type = '?';
 154         if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
 155             $name = $1;
 156             $type = "l $2";
 157         }
 158         elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
 159             $type = 'f';
 160         }
 161         elsif ($kind =~ /^[dD]/) {
 162             $type = 'd';
 163             $size = undef;  # Don't believe the reported size
 164         }
 165         return [$name, $type, $size, str2time($date, $tz),
 166               File::Listing::file_mode($kind)];
 167
 168     }
 169     elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
 170         my $dir = $1;
 171         return () if $dir eq '.';
 172         $curdir = $dir;
 173         return ();
 174     }
 175     elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
 176         return ();
 177     }
 178     elsif (/not found/    || # OSF1, HPUX, and SunOS return
 179              # "$file not found"
 180              /No such file/ || # IRIX returns
 181              # "UX:ls: ERROR: Cannot access $file: No such file or directory"
 182                                # Solaris returns
 183              # "$file: No such file or directory"
 184              /cannot find/     # Windows NT returns
 185              # "The system cannot find the path specified."
 186              ) {
 187         return () unless defined $error;
 188         &$error($_) if ref($error) eq 'CODE';
 189         warn "Error: $_\n" if $error eq 'warn';
 190         return ();
 191     }
 192     elsif ($_ eq '') {       # AIX, and Linux return nothing
 193         return () unless defined $error;
 194         &$error("No such file or directory") if ref($error) eq 'CODE';
 195         warn "Warning: No such file or directory\n" if $error eq 'warn';
 196         return ();
 197     }
 198     else {
 199         # parse failed, check if the dosftp parse understands it
 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);
 213 no strict qw(vars);
 214
 215 @ISA = qw(File::Listing);
 216
 217
 218
 219 sub init
 220 {
 221     $curdir = '';
 222 }
 223
 224
 225 sub line
 226 {
 227     shift; # package name
 228     local($_) = shift;
 229     my($tz, $error) = @_;
 230
 231     s/\015//g;
 232
 233     my ($kind, $size, $date, $name);
 234
 235     # 02-05-96  10:48AM                 1415 src.slf
 236     # 09-10-96  09:18AM       <DIR>          sl_util
 237     if (($date,$size_or_dir,$name) =
 238         /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM)         # Date and time info
 239          \s+                                      # Some space
 240          (<\w{3}>|\d+)                            # Dir or Size
 241          \s+                                      # Some more space
 242          (.+)$                                    # File name
 243         /x )
 244     {
 245         return if $name eq '.' || $name eq '..';
 246         $name = "$curdir/$name" if length $curdir;
 247         my $type = '?';
 248         if ($size_or_dir eq '<DIR>') {
 249             $type = "d";
 250             $size = ""; # directories have no size in the pc listing
 251         }
 252         else {
 253             $type = 'f';
 254             $size = $size_or_dir;
 255         }
 256         return [$name, $type, $size, str2time($date, $tz),
 257               File::Listing::file_mode($kind)];
 258
 259     }
 260     else {
 261         return () unless defined $error;
 262         &$error($_) if ref($error) eq 'CODE';
 263         warn "Can't parse: $_\n" if $error eq 'warn';
 264         return ();
 265     }
 266
 267 }
 268
 269
 270
 271 package File::Listing::vms;
 272 @File::Listing::vms::ISA = qw(File::Listing);
 273
 274 package File::Listing::netware;
 275 @File::Listing::netware::ISA = qw(File::Listing);
 276
 277
 278
 279 package File::Listing::apache;
 280
 281 @ISA = qw(File::Listing);
 282
 283
 284 sub init { }
 285
 286
 287 sub line {
 288     shift; # package name
 289     local($_) = shift;
 290     my($tz, $error) = @_; # ignored for now...
 291
 292     if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kM]?|-))!i) {
 293         my($filename, $filesize) = ($1, $7);
 294         my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
 295
 296         $filesize = 0 if $filesize eq '-';
 297         if ($filesize =~ s/k$//i) {
 298             $filesize *= 1024;
 299         }
 300         elsif ($filesize =~ s/M$//) {
 301             $filesize *= 1024*1024;
 302         }
 303         elsif ($filesize =~ s/G$//) {
 304             $filesize *= 1024*1024*1024;
 305         }
 306         $filesize = int $filesize;
 307
 308         require Time::Local;
 309         my $filetime = Time::Local::timelocal(0,$M,$H,$d,_monthabbrev_number($m)-1,_guess_year($y)-1900);
 310         my $filetype = ($filename =~ s|/$|| ? "d" : "f");
 311         return [$filename, $filetype, $filesize, $filetime, undef];
 312     }
 313
 314     return ();
 315 }
 316
 317
 318 sub _guess_year {
 319     my $y = shift;
 320     if ($y >= 90) {
 321         $y = 1900+$y;
 322     }
 323     elsif ($y < 100) {
 324         $y = 2000+$y;
 325     }
 326     $y;
 327 }
 328
 329
 330 sub _monthabbrev_number {
 331     my $mon = shift;
 332     +{'Jan' => 1,
 333       'Feb' => 2,
 334       'Mar' => 3,
 335       'Apr' => 4,
 336       'May' => 5,
 337       'Jun' => 6,
 338       'Jul' => 7,
 339       'Aug' => 8,
 340       'Sep' => 9,
 341       'Oct' => 10,
 342       'Nov' => 11,
 343       'Dec' => 12,
 344      }->{$mon};
 345 }
 346
 347
 348 1;
 349
 350 __END__
 351
 352 =head1 NAME
 353
 354 File::Listing - parse directory listing
 355
 356 =head1 SYNOPSIS
 357
 358  use File::Listing qw(parse_dir);
 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. Currently it only understand Unix
 373 C<'ls -l'> and C<'ls -lR'> format.  It should eventually be able to
 374 most things you might get back from a ftp server file listing (LIST
 375 command), i.e. VMS listings, NT listings, DOS listings,...
 376
 377 The first parameter to parse_dir() is the directory listing to parse.
 378 It can be a scalar, a reference to an array of directory lines or a
 379 glob representing a filehandle to read the directory listing from.
 380
 381 The second parameter is the time zone to use when parsing time stamps
 382 in the listing. If this value is undefined, then the local time zone is
 383 assumed.
 384
 385 The third parameter is the type of listing to assume.  The values will
 386 be strings like 'unix', 'vms', 'dos'.  Currently only 'unix' is
 387 implemented and this is also the default value.  Ideally, the listing
 388 type should be determined automatically.
 389
 390 The fourth parameter specifies how unparseable lines should be treated.
 391 Values can be 'ignore', 'warn' or a code reference.  Warn means that
 392 the perl warn() function will be called.  If a code reference is
 393 passed, then this routine will be called and the return value from it
 394 will be incorporated in the listing.  The default is 'ignore'.
 395
 396 Only the first parameter is mandatory.
 397
 398 The return value from parse_dir() is a list of directory entries.  In
 399 a scalar context the return value is a reference to the list.  The
 400 directory entries are represented by an array consisting of [
 401 $filename, $filetype, $filesize, $filetime, $filemode ].  The
 402 $filetype value is one of the letters 'f', 'd', 'l' or '?'.  The
 403 $filetime value is the seconds since Jan 1, 1970.  The
 404 $filemode is a bitmask like the mode returned by stat().
 405
 406 =head1 CREDITS
 407
 408 Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
 409 Net::FTP's parse_dir (Graham Barr).