Script submission?
[email protected] (John Halleck)
| Newsgroups | perl.scripts |
|---|---|
| Message-ID | <[email protected]> |
Assuming this is the right address...
I'd like to submit this script to your script collection.
(Assuming there is any interest.)
The following script is more or less the unix ls -R
but with ASCII art of the structure it walks.
It identifies symbolic links that don't point anywhere,
and labels relative links with both the relative form
and the absolute form.
For hard linked files second occurances will be
labeled with the name given and the name the first
occurance gave. (First occurances will only be
labeled as being a hard link.)
It has options to show sizes, protections, etc.
In the output symbolic links are show as
name => pointsto
or
name => pointsto (absoluteformofpointsto)
Hard links are shown by
name = alternatename
Typical output is:
treedir /home/nahaj/demo/
/home/nahaj/demo/
|
|-- X11 => /usr/openwin/include/X11
|-- alloca.h
|
|-- inet/
| |
| |-- led.h
|
|-- iso646.h
|
|-- kerberos/
| |
| |-- osconf.h
|
|-- testdir
| |-- elftypes.h
| |-- exec.h
| |-- exechdr.h
| |-- feature_tests.h
| |
| |-- fs/
| | |
| | |-- hsfs_isospec.h
| | |-- hsfs_spec.h
| | |-- pc_label.h
| | |-- ufs_mount.h
| |
| |-- scsi/
| | |
| | |-- adapters/
| | | |
| | | |-- glmvar.h
| | |
| | |-- impl/
| | |
| | |-- pkt_wrapper.h
| |
| |-- signal.h
| |-- socvar.h
| |-- stat.h
| |-- sunddi.h
|
|-- syslimits.h
===========================================================
The script is:
#!/usr/local/bin/perl -w
# Copyright 1998 by John Halleck
# All rights reserved
require 5.0;
$progversion = "Tree Directory 1.55 21sep1998" if !defined $progversion;
sub init { # Any global initialization.
# print "DEBUG: Global initialization called\n";
return;
}
sub fini { # Any global termination code.
# print "DEBUG: Global termination called\n";
return;
}
sub arginit { # Any per argument initialization
my $argument = shift;
# print "DEBUG: Argument initialization called with $given\n";
return;
}
sub argfini { # Any per argument termination code
my $argument = shift;
# print "DEBUG: Argument termination called\n";
return;
}
sub displayfile { # 0 to make this file invisible
my $fullname = shift;
my $inode = shift;
# print "DEBUG: displayfile called with $fullname (inode: $inode)\n";
return 1;
}
sub wantdir { # Return 0 to force cull of tree here.
my $fullname = shift;
my $inode = shift;
# print "DEBUG: wantdir called with $fullname (inode: $inode)\n";
return 1;
}
sub enterdirectory {
my $indent = shift;
my $dirname = shift;
# print "$indent + DEBUG: directory initialization called with $fullname\n";
return;
}
sub exitdirectory {
my $indent = shift;
my $dirname = shift;
# print "$indent + DEBUG: directory finalization called with $fullname\n";
return;
}
$needspace = 0;
sub processfile {
my $indent = shift;
my $fullname = shift;
$needspace = 0;
# print "$indent + DEBUG: processfile called with $fullname\n";
return;
}
sub processdir {
my $indent = shift;
my $fullname = shift;
$needspace = 0;
# print "$indent + DEBUG: processfile called with $fullname\n";
return;
}
sub processuseropt { # No options specific to this package.
my $opt = shift;
# print "DEBUG: Process user options called with $opt\n";
return 0; # return 1 if you processed the option.
}
sub printuseropt { # Ditto
# print "DEBUG: printuseroption called\n";
return;
}
sub defaultfile { # what to do if the user specified nothing.
# print "DEBUG: Default file called...\n";
if (defined $workingdir) { return $workingdir }
return '';
}
sub mungename {
my $given = shift;
# print "DEBUG: Mungename called with $given\n";
return $given;
}
### Expansion of: require '/home/nahaj/src/unixperl/treewalk.routines';
### <<<<<<<<<<< Start text taken from /home/nahaj/src/unixperl/treewalk.routines
# -------------------------------------------------------------------
#
# Copyright 1998 by John Halleck
# All rights reserved
# $version = "1.00 - John Halleck, 19 Mar 1998";
# ...
# $version = "1.59 - John Halleck, 6 Apr 1998";
# $version = "1.60 - John Halleck, 25 Aug 1998";
# $version = "1.61 - John Halleck, 21 Sep 1998";
# $version = "1.62 - John Halleck, 22 Sep 1998";
# $version = "1.63 - John Halleck, 6 Oct 1998";
# $version = "1.64 - John Halleck, 21 Oct 1998";
# Fixed permissions code.
$version = "1.65 - John Halleck, 12 Mar 1999";
# &subroutine; => &subroutine();
require 5.0; # Not a prayer with perl 4
# Set default options
$wanthelp = 0; # Want help message
$wantdots = 0; # Go through dot files and directories.
$wantfull = 0; # Print fully expanded names.
$wantbig = 0; # Special readability for big directories.
$wantsize = 0; # want file sizes.
$wantperms = 0; # want file permissions.
$wantdirs = 0; # want only directories.
$wantnogrf = 0; # want no graphics.
$maxdepth = 0; # depth limit for tree walk.
# Housekeeping
$nodirmessage = undef; # An alternate message programs can set.
$fail = 0;
%inodenames = ();
$needspace = 0; # do we need extra space for readability?
%exceptions = (); # Files and directories not to process.
$workingdir = ''; # We'll need to know where we are if the
# user gives a relative reference on the
# command line.
if (defined $ENV{'PWD'}) {
$workingdir = $ENV{'PWD'};
} elsif (defined $ENV{'HOME'}) {
$workingdir = $ENV{'HOME'};
}
if ($workingdir !~ m:/$:) { $workingdir .= '/' }
# ---------------------------------------------------------------------------
# This routine is shared by several different programs...
sub dumpperm {
my $perm = shift; $perm = 0 if !defined $perm;
my $result = '';
if ($perm & 04) { $result .= 'r' } else { $result .= '-'}
if ($perm & 02) { $result .= 'w' } else { $result .= '-'}
if ($perm & 01) { $result .= 'x' } else { $result .= '-'}
return $result;
}
sub dumpperms {
my $perms = shift; $perms = 0 if !defined $perms;
if ($perms eq '') { return '?????????' }
my $result = &dumpperm ($perms >> 6)
. &dumpperm ($perms >> 3)
. &dumpperm ($perms);
if ($perms & 04000) {
substr($result,2,1) = substr($result,2,1) eq 'x' ? 's' : 'S';
}
if ($perms & 02000) {
substr($result,5,1) = substr($result,5,1) eq 'x' ? 's' : 'S';
}
if ($perms & 01000) {
substr($result,8,1) = substr($result,8,1) eq 'x' ? 't' : 'T';
}
return $result;
}
sub treewalk { # Walk the tree processing as we go.
my $indent = shift;
my $indentraw = shift;
my $depth = shift;
my $fullname = shift;
# print "DEBUG: treewalk called $fullname, $depth\n";
my $softlink = -l $fullname; $softlink = 0 if !defined $softlink;
my $inode = (stat $fullname) [1]; $inode = '' if !defined $inode;
my $isdir = !$softlink && -d _;
my $hardlink = 0;
if (!$softlink && !$isdir && defined ((stat _) [3])) {
# Yeah... we know that there can be hard links to directories...
# But if we have one there is not much we can really tell without
# taking the entire directory appart.
$hardlink = (stat _) [3] > 1;
}
my $exists = -e _;
my $linkname = '';
my $linktype = '';
my $actlink = '';
if ($softlink) {
$linktype = '=>';
$linkname = readlink $fullname; $linkname = '' if !defined $linkname;
$actlink = &makepathabs ($linkname, $fullname);
} elsif ($hardlink) {
$linktype = '==';
if (defined $inode && $inode ne '' && defined $inodenames{$inode}) { # Hard link we know.
$linkname = $inodenames{$inode};
}
}
if ($isdir && $fullname !~ m/\/$/) { $fullname .= '/' }
my $shortname = $fullname;
if ($depth > 0) { ($shortname) = $fullname =~ m:/([^/]+/?)$: }
# --- output name -----
# Handle spacing for readability.
if ($isdir && $depth > 0) { $needspace = 1 }
print $indentraw, '|' if $needspace && !$wantnogrf;
print "\n" if $needspace;
$needspace = 0;
# put out a reasonable name.
print $indentraw if !$wantnogrf;
print '|-- ' if $depth > 0 && !$wantnogrf;
if ($wantperms) {
my $perms = (stat _) [2];
print &dumpperms ($perms), ' ' if defined $perms;
}
print &mungename($shortname, $fullname);
print ' (', $fullname, ')' if $wantfull
|| ($isdir && $wantnogrf)
|| ($wantbig && $needspace)
;
if ($linktype ne '') {
print " $linktype ", $linkname;
print " ($actlink)"
if $actlink ne ''
&& $actlink ne $fullname
&& $actlink ne $shortname
&& $actlink ne $linkname;
print " [??? *** Does not exist\a]" if $softlink && !-e $actlink;
} elsif ($exists && !$softlink && $wantsize) {
print " [", -s _, " bytes]";
}
print "\n";
$inodenames {$inode} = $fullname if !$softlink
&& defined $inode
&& !defined $inodenames{$inode};
# --- Handle early bailouts ----
if (!$exists) { return }
elsif (!$isdir) { # Handle per file processing.
&processfile ($depth, $indent . '+ ', $fullname);
return
}
# --- must be a directory.
$needspace = 1; # we need extra space for readability after directories.
my $markindent = $indent . '|';
if ($linkname ne '')
{ print $markindent, " *** Not processed, link to $linkname\n" }
elsif ($maxdepth != 0 && $depth >= $maxdepth)
{ print $markindent, " *** Not processed, max depth reached\n" }
elsif (defined $exceptions{$inode})
{ print $markindent, " *** Processing suppressed by option\n" }
elsif (!&wantdir($fullname, $inode)) {
if (!defined $nodirmessage) { print $markindent, " *** Not processesing directory\n"}
else { print $markindent, $nodirmessage, "\n" }
} else {
# Discover what's in the directory.
my $thedirectory = $fullname;
&processdir ($markindent, $fullname);
if (!opendir (DIR, $thedirectory))
{ print $markindent, " *** Not checked ($!)\a \n"; }
else {
# Get the contents of the directory.
my $next; my @directorycontents = ();
while (defined ($next = readdir DIR)) {
if ($next eq '' || $next eq '.' || $next eq '..') { next }
if (!$wantdots && $next =~ m/^\./) { next }
$fullname = $thedirectory . $next;
$isdir = -d $fullname;
if (!$isdir && $wantdirs) { next }
if (!$isdir && defined $exceptions{$inode}) { next }
if (!&displayfile ($fullname, $inode)) { next }
push @directorycontents, $fullname;
}
if (!closedir (DIR))
{ print "$markindent *** Couldn't close $thedirectory ($!) ***\a\n"}
else { # Ok, let's dump out the contents of this directory.
@directorycontents = sort @directorycontents if @directorycontents > 0;
&enterdirectory ($markindent . '+ ', $thedirectory);
my $newindent = $indent . '| ';
$needspace = 1;
if (@directorycontents == 0) {
print $markindent, "\n" if !$wantnogrf;
} else {
while (@directorycontents > 0) {
$thename = shift @directorycontents;
if (@directorycontents == 0) { $newindent = $indent . ' ' }
&treewalk ($newindent, $indent, $depth + 1, $thename);
}
}
$needspace = 1; # We need extra space for readability after directories.
&exitdirectory ($markindent, $thedirectory); # cleanup.
}
}
}
}
# --- Extract directory parts.
sub bustname { # file is assumed to have been made absolute.
my $given = shift;
if ($given eq '' || $given eq '/') { return ('/', '') }
if ($given !~ m:^/:) { return ('/', $given) } # Probably should be an error
if ($given =~ m:^/([^/]+)$:) { return ('/', $1) }
if ($given =~ m:^(/.+/)([^/]+/?)$:) { return ($1, $2) }
return ('',$given);
}
# --- Needed support.
# Routines to handle absolute and relative paths.
### Expansion of: require '/home/nahaj/src/unixperl/path.pl';
### <<<<<<<<<<< Start text taken from /home/nahaj/src/unixperl/path.pl
#!/usr/local/bin/perl -w
# Copyright 1998 by John Halleck
# All rights reserved
# Handle conversion from/to relative paths. (Complying with RFC2396)
require 5.0; # Not a prayer with perl 4.
# ------------------
sub makepathabs { # this is a direct coding of RFC 2396 5.2.6
my $given = shift;
my $base = shift;
if (!defined $base) { return $given } # This is an error, but what to do?
if (!defined $given) { return '' }
if ($given =~ m;^/;) { return $given }
# RFC 2396 5.2.6a
my $result = $base;
if ($result =~ m;^(.*/)[^/]+$;) { $result = $1 }
# RFC 2396 5.2.6b
$result .= $given;
# Just to make search patterns easier.
my $startingslash = $result =~ m:^/: ;
if (!$startingslash) { $result = '/' . $result }
# RFC 2396 5.2.6c Remove /.'s
$result =~ s:/\./:/:g;
# RFC 2396 5.2.6d Remove trailing /.
$result =~ s:/\.$:/: ;
# RFC 2396 5.2.6e Remove /<SEGMENT>/../'s
while ($result =~ m;^(.*?)/[^/]*/\.\./(.*)$;) { $result = "$1/$2" }
# RFC 2396 5.2.6f Remove trailing /<SEGMENT>/..
if ($result =~ m;^(.*/)([^/]*)/\.\.$; && $2 ne '..') { $result = $1}
# RFC 2396 5.2.6g
if ($result eq '/..') { $result = '' } # Some implementations MAY...
else {
while ($result =~ m;^(.*)/\.\.(/.*)$;) { $result = $1 . $2 } # Some implementations MAY...
}
# Undo the leading / we put on to simplify pattern matches.
if (!$startingslash && $result =~ m;^/;) { $result =~ s;^/;; }
return $result;
}
# -----------------
sub makepathrel {
my $given = shift;
my $base = shift;
if (!defined $given) { return '' }
if ($given !~ m;^/(.*)$;) { return $given } # not given an abs.
$given = $1;
if (!defined $base) { return $given } # This is an error, but what to do?
if ($base !~ m;^/(.*)$;) { return $given } # really an error.
$base = $1;
# Were we handed the same thing?
if ($base eq $given) {
if ($given =~ m:/$:) { return './' }
else { return '.' }
}
# We don't really care about non directory part of the base if they are unequal
if ($base =~ m:^(.*/)[^/]+$:) { $base = $1 }
# a/b/c/d/ a/b/g/h => c/d/ g/h
my ($testbase, $restbase, $testgiven, $restgiven);
my $didone = 0;
while (1) {
# print "DEBUG: Making relative $given, $base\n";
if ($base !~ m:^([^/]*)/(.*)$:) { last }
$testbase = $1; $restbase = $2;
if ($given !~ m:^([^/]*)/(.*)$:) { last }
$testgiven = $1; $restgiven = $2;
if ($testbase eq $testgiven) {
$base = $restbase;
$given = $restgiven;
$didone = 1;
} else {
last
}
}
# What if nothing in common? Then just give it as abs.
if (!$didone) { return '/' . $given }
# a/b/c d => ../../d
while ($base =~ m:^[^/]*/(.*)$:) {
$base = $1;
$given = '../' . $given;
}
if ($given eq '' || $given eq '/') { return './' }
# print "DEBUG: Making relative returning $given\n";
return $given;
}
1;
### >>>>>>>>>>> End text taken from /home/nahaj/src/unixperl/path.pl
# --- Setup.
sub treewalkstart {
my $given = shift; # Assume fully qualified.
$inodenames = (); $needspace = 0;
my $realname = $given;
$realname = &makepathabs ($realname, $workingdir);
my ($directory, $filename) = &bustname ($realname);
my $needdirectory = $directory ne '' && !-d $realname;
# If what we are given in not a directory,
# the walk will not notice that we have entered
# the parent directory.
if ($needdirectory) { &enterdirectory ('', $directory) }
&treewalk ('','',0, $realname); # Go for it.
if ($needdirectory) { &exitdirectory ('', $directory) }
}
# ---------------------- Ok, use the utility developed above.
# Process arguments and get files.
my @files = (); $fail = 0;
while (defined ($given = shift @ARGV)) {
if ($given !~ m/^\-(.*)$/) { # Argument.
push @files, $given; # must be file to process.
} else { # Otherwise it is an option.
my $option = $1;
if ($option eq 'a') { $wantdots = 1 }
elsif ($option eq 'b') { $wantbig = 1 }
elsif ($option eq 'd') { $wantdirs = 1 }
elsif ($option eq 'e') {
$anexception = shift @ARGV; $anexception = '' if !defined $anexception;
if ($anexception eq '' || !-e $anexception) {
warn "*** Bad file given for exception option (\"$anexception\")\n";
} else {
$inode = (stat _)[1];
$exceptions{$inode} = $anexception;
}
}
elsif ($option eq 'f') { $wantfull = 1 }
elsif ($option eq 'p') { $wantperms = 1 }
elsif ($option eq 's') { $wantsize = 1 }
elsif ($option eq 'n') { $wantnogrf = 1 ; $wantbig = 1; }
elsif ($option eq 'm') {
$maxdepth = shift @ARGV; $maxdepth = '' if !defined $maxdepth;
if ($maxdepth !~ m/^\d+$/) {
warn "*** Bad depth given for m option ($maxdepth)\n";
}
}
elsif ($option eq 'V') {
if (defined $progversion) {
warn "Program: $progversion\nFrame ";
}
warn "Version: $version\n";
}
elsif ($option eq 'h') { $wanthelp = 1 }
elsif (&processuseropt($option)) {}
else {
warn "Unknown option \"$option\"\n";
$fail++;
}
}
}
if ($fail > 0) {
exit 1;
}
# ---- We've got a list of what the user wants.
# If nothing given on command line, check if program has defaults.
if (@files == 0) {
my $userwants = &defaultfile();
if (defined $userwants) { @files = ($userwants) }
}
if ($wanthelp || @files == 0) { # User confused?
warn "treedir [-a] [-h] directories\n";
warn " -V print program version\n";
warn " -a show dot files and directories\n";
warn " -b extra readability for BIG directories\n";
warn " -d do ONLY directories and don't list files\n";
warn " -e xxx Don't process given directory or file\n";
warn " -f Always print full expanded file names\n";
warn " -h Produce this help message\n";
warn " -p list file permissions.\n";
warn " -s print file sizes\n";
warn " -m # limit depth of processing to #\n";
warn " -n suppress graphics\n";
&printuseropt();
}
&init();
# Let the user do their program wide startup.
# Do the files stated.
foreach $given (@files) {
my $realname = &makepathabs ($given, $workingdir);
# Undo any relative references the user gave.
&arginit($realname);
# Let the user do any needed setup.
&treewalkstart($realname);
# Go for it.
&argfini($realname);
# and any needed cleanup.
}
&fini();
1;
### >>>>>>>>>>> End text taken from /home/nahaj/src/unixperl/treewalk.routines
exit 0;