#-*-perl-*-# Copyright (C) 1990 - 1998   Lee McLoughlin## Permission to use, copy, and distribute this software and its# documentation for any purpose with or without fee is hereby granted,# provided that the above copyright notice appear in all copies and# that both that copyright notice and this permission notice appear# in supporting documentation.## Permission to modify the software is granted, but not the right to# distribute the modified code.  Modifications are to be distributed# as patches to released version.## This software is provided "as is" without express or implied warranty.## Parse "ls -lR" type listings# use lsparse'reset( dirname ) repeately## By Lee McLoughlin <lmjm@icparc.ic.ac.uk>## $Id: lsparse.pl,v 2.9 1998/05/29 19:04:19 lmjm Exp lmjm $# $Log: lsparse.pl,v $# Revision 2.9  1998/05/29 19:04:19  lmjm# Lots of changes.  See CHANGES since 2.8 file.## Revision 2.7  1994/06/10  18:28:24  lmjm# Another netware variant.# Another dosish system.# VM/CMS from Andrew Mc.## Revision 2.6  1994/04/29  20:11:06  lmjm# Overcome strange handling of $1 near a pattern match.## Revision 2.4  1994/01/26  15:43:00  lmjm# Added info-mac parser.# Cleanups to lsparse type lines.## Revision 2.3  1994/01/18  21:58:20  lmjm# Added F type.# mode handle 't' type.# Added line_lsparse.## Revision 2.2  1993/12/14  11:09:08  lmjm# Parse more unix ls listings.# Added dosftp parsing.# Added macos parsing.## Revision 2.1  1993/06/28  15:03:08  lmjm# Full 2.1 release### This has better be available via your PERLLIB environment variablerequire 'dateconv.pl';package lsparse;# The current directory is stripped off the# start of the returned pathname# $match is a pattern that matches thislocal( $match );# The filestore type being scanned$lsparse'fstype = 'unix';# Keep whatever case is on the remote system.  Otherwise lowercase it.$lsparse'vms_keep_case = '';# A name to report when errors occur$lsparse'name = 'unknown';# Wether to report subdirs when finding them in a directory# or when their details appear.  (If you report early then mirro might# recreate locally remote restricted directories.)$lsparse'report_subdir = 0;	# Report when finding details.# Name of routine to call to parse incoming listing lines$ls_line = '';# Set the directory that is being scanned and# check that the scan routing for this fstype exists# returns false if the fstype is unknown.sub lsparse'reset{	$here = $currdir = $_[0];	$now = time;	# Vms tends to give FULL pathnames reguardless of where	# you generate the dir listing from.	$vms_strip = $currdir;	$vms_strip =~ s,^/+,,;	$vms_strip =~ s,/+$,,;	$ls_line = "lsparse'line_$fstype";	return( defined( &$ls_line ) );}# See line_unix following routine for call/return details.# This calls the filestore specific parser.sub lsparse'line{	local( $fh ) = @_;	# ls_line is setup in lsparse'reset to the name of the function	local( $path, $size, $time, $type, $mode ) =		eval "&$ls_line( \$fh )";	# Zap any leading ./  (Somehow they still creep thru.)	$path =~ s:^(\./)+::;	return ($path, $size, $time, $type, $mode);}# --------------------- parse standard Unix ls output# for each file or directory line found return a tuple of# (pathname, size, time, type, mode)# pathname is a full pathname relative to the directory set by reset()# size is the size in bytes (this is always 0 for directories)# time is a Un*x time value for the file# type is "f" for a file, "d" for a directory and#         "l linkname" for a symlinksub lsparse'line_unix{	local( $fh ) = @_;	local( $non_crud, $perm_denied );	local( $d );	local( $dir );	if( eof( $fh ) ){		return( "", 0, 0, 0 );	}	while( <$fh> ){		# Store listing		print main'STORE $_;		# Stomp on carriage returns		s/\015//g;		# I'm about to look at this at lot		study;		# Try and spot crud in the line and avoid it		# You can get:		# -rw-r--r-ls: navn/internett/RCS/nsc,v: Permission denied		# ls: navn/internett/RCS/bih,v: Permission denied		# -  1 43       daemon       1350 Oct 28 14:03 sognhs		# -rwcannot access .stuff/incoming		# cannot access .stuff/.cshrc		if( m%^(.*)/bin/ls:.*Permission denied% ||		   m%^(.*)ls:.*Permission denied% ||		   m%^(.*)ls:.*No such file or directory% ||		   m%^(.*)(cannot|can not) access % ){			if( ! $non_crud ){				$non_crud = $1;			}			next;		}		# Also try and spot non ls "Permission denied" messages.  These		# are a LOT harder to handle as the key part is at the end		# of the message.  For now just zap any line containing it		# and the first line following (as it will PROBABLY have been broken).		#		if( /.:\s*Permission denied/ ){			$perm_denied = 1;			next;		}		if( $perm_denied ){			$perm_denied = "";			warn "Warning: input corrupted by 'Permission denied'",				"errors, about line $. of $lsparse'name\n";			next;		}		# Not found's are like Permission denied's.  They can start part		# way through a line but with no way of spotting where they begin		if( /not found/ ){			$not_found = 1;			next;		}		if( $not_found ){			$not_found = "";			warn "Warning: input corrupted by 'not found' errors",				" about line $. of $lsparse'name\n";			next;		}				if( $non_crud ){			$_ = $non_crud . $_;			$non_crud = "";		}				if( /^([\-FlrwxsStTdDam]{10}).*\D(\d+)\s*([A-Za-z]{3}\s+\d+\s*(\d+:\d+|\d\d\d\d))\s+(.*)\n/ ){			local( $kind, $size, $lsdate, $file ) = ($1, $2, $3, $5);						if( $file eq '.' || $file eq '..' ){				next;			}			local( $time ) = &main'lstime_to_time( $lsdate );			local( $type ) = '?';			local( $mode ) = 0;			# This should be a symlink			if( $kind =~ /^l/ && $file =~ /(.*) -> (.*)/ ){				$file = $1;				$type = "l $2";			}			elsif( $kind =~ /^[\-F]/ ){				# (hopefully) a regular file				$type = 'f';			}			elsif( $kind =~ /^d/i ){				# Don't create private dirs when not				# using recurse_hard.				if( $report_subdirs ){					next;				}				$type = 'd';					$size = 0;   # Don't believe the report size			}						$mode = &chars_to_mode( $kind );			$currdir =~ s,/+,/,g;			$file =~ s,^/$match,,;			$file = "/$currdir/$file";			$file =~ s,/+,/,g;			return( substr( $file, 1 ), $size, $time, $type, $mode );		}		# Match starts of directories.  Try not to match		# directories whose names ending in :		elsif( /^([\.\/]*.*):$/ && ! /^[dcbsp].*\s.*\s.*:$/ ){			$dir = $1;			if( $dir eq '.' ){				next;			}			elsif( $dir !~ /^\// ){				$currdir = "$here/$dir";			}			else {				$currdir = "$dir";			}			$currdir =~ s,/+,/,g;			$match = $currdir;			$match =~ s/([\+\(\)\[\]\*\?])/\\$1/g;			return( substr( $currdir, 1 ), 0, 0, 'd', 0 );		}		elsif( /^[dcbsp].*[^:]$/ || /^\s*$/ || /^[Tt]otal.*/ || /[Uu]nreadable$/ ){			;		}		elsif( /^.*[Uu]pdated.*:/ ){			# Probably some line like:			# Last Updated:  Tue Oct  8 04:30:50 EDT 1991			# skip it			next;		}		elsif( /^([\.\/]*[^\s]*)/ ){			# Just for the export.lcs.mit.edu ls listing			$match = $currdir = "$1/";			$match =~ s/[\+\(\[\*\?]/\\$1/g;		}				else {			printf( "Unmatched line: %s", $_ );		}	}	return( '', 0, 0, 0, 0 );}# Convert the mode chars at the start of an ls-l entry into a numbersub chars_to_mode{	local( $chars ) = @_;	local( @kind, $c );	# Split and remove first char	@kind = split( //, $kind );	shift( @kind );	foreach $c ( @kind ){		$mode <<= 1;		if( $c ne '-' && $c ne 'S' && $c ne 't' && $c ne 'T' ){			$mode |= 1;		}	}	# check for "special" bits	# uid bit	if( /^...s....../i ){	    $mode |= 04000;	}	# gid bit	if( /^......s.../i ){	    $mode |= 02000;	}	# sticky bit	if( /^.........t/i ){	    $mode |= 01000;	}	return $mode;}# --------------------- parse dls output# dls is a descriptive ls that some sites use.# this parses the output of dls -dtR# for each file or directory line found return a tuple of# (pathname, size, time, type, mode)# pathname is a full pathname relative to the directory set by reset()# size is the size in bytes (this is always 0 for directories)# time is a Un*x time value for the file# type is "f" for a file, "d" for a directory and#         "l linkname" for a symlinksub lsparse'line_dls{	local( $fh ) = @_;	local( $non_crud, $perm_denied );	if( eof( $fh ) ){		return( "", 0, 0, 0 );	}	while( <$fh> ){		# Store listing		print main'STORE $_;		# Stomp on carriage returns		s/\015//g;		# I'm about to look at this at lot		study;		if( /^(\S*)\s+(\-|\=|\d+)\s+((\w\w\w\s+\d+|\d+\s+\w\w\w)\s+(\d+:\d+|\d\d\d\d))\s+(.+)\n/ ){			local( $file, $size, $lsdate, $description ) =				($1, $2, $3, $6);			$file =~ s/\s+$//;			local( $time, $type, $mode );						if( $file =~ m|/$| ){				# a directory				$file =~ s,/$,,;				$time = 0;				$type = 'd';				$mode = 0555;			}			else {				# a file				$time = &main'lstime_to_time( $lsdate );				$type = 'f';				$mode = 0444;			}			# Handle wrapped long filenames			if( $filename ne '' ){				$file = $filename;			}			$filename = '';			$file =~ s/\s*$//;			$file = "$currdir/$file";			$file =~ s,/+,/,g;			return( substr( $file, 1 ), $size, $time, $type, $mode );		}		elsif( /^(.*):$/ ){			if( $1 eq '.' ){				next;			}			elsif( $1 !~ /^\// ){				$currdir = "$here/$1/";			}			else {				$currdir = "$1/";			}			$filename = '';			$currdir =~ s,/+,/,g;			$match = $currdir;			$match =~ s/([\+\(\)\[\]\*\?])/\\$1/g;			return( substr( $currdir, 1 ), 0, 0, 'd', 0 );		}		else {			# If a filename is long then it is on a line by itself			# with the details on the next line			chop( $filename = $_ );		}	}	return( '', 0, 0, 0, 0 );}# --------------------- parse netware output# For each file or directory line found return a tuple of# (pathname, size, time, type, mode)# pathname is a full pathname relative to the directory set by reset()# size is the size in bytes (this is always 0 for directories)# time is a Un*x time value for the file# type is "f" for a file, "d" for a directory and#         "l linkname" for a symlinksub lsparse'line_netware{	local( $fh ) = @_;	if( eof( $fh ) ){		return( "", 0, 0, 0 );	}	while( <$fh> ){		# Store listing		print main'STORE $_;		# Stomp on carriage returns		s/\015//g;# Unix vs NetWare:#1234567890 __________.*_____________ d+  www dd  dddd (.*)\n#drwxr-xr-x   2 jrd      other        512 Feb 29  1992 vt100#   kind     			      size lsdate       file#123456789012sw+ ____.*_______\s+(\d+)   \s+  wwwsddsdd:dd\s+ (.*)\n  #- [R----F--] jrd                197928       Sep 25 15:19    kermit.exe#d [R----F--] jrd                   512       Oct 06 09:31    source#d [RWCEAFMS] jrd                   512       Sep 04 14:38    lwp# Another netware variant#d [R----F-]  1 carl                   512 Mar 12 15:47 txt# And another..#- [-RWCE-F-] mlm                   11820 Feb  3 93 12:00  drivers.doc# And another..#-[R----F-]  1 supervis      256 Nov 15 14:21 readme.txt		if( /^([d|l|\-]\s*\[[RWCEAFMS\-]+\])\s+(\d+\s+)?\S+\s+(\d+)\s*(\w\w\w\s+\d+\s*(\d+:\d+|\d\d\d\d))\s+(.*)\n/) {			local( $kind, $size, $lsdate, $file ) =						 ( $1, $3, $4, $6);			if( $file eq '.' || $file eq '..' ){				next;			}			local( $time ) = &main'lstime_to_time( $lsdate );			local( $type ) = '?';			local( $mode ) = 0;			# This should be a symlink			if( $kind =~ /^l/ && $file =~ /(.*) -> (.*)/ ){				$file = $1;				$type = "l $2";			}			elsif( $kind =~ /^-/ ){				# (hopefully) a regular file				$type = 'f';			}						$mode = &netware_to_mode( $kind );