Example code from Perl for System Administration by David N. Blank-Edelman
O'Reilly and Associates, 1st Edition, ISBN 1-56592-609-9

Chapter Ten
===========

#*
#* a program for storing and checking file information
#*

use Getopt::Std;

# we use this for prettier output later in &printchanged()
@statnames = qw(dev ino mode nlink uid gid rdev 
                size mtime ctime blksize blocks);

getopt('p:c:');

die "Usage: $0 [-p <filename>|-c <filename>]\n"
  unless ($opt_p or $opt_c);

if ($opt_p){
    die "Unable to stat file $opt_p:$!\n" unless (-e $opt_p);
    print $opt_p,"|",join('|',(lstat($opt_p))[0..7,9..12]),"\n";
    exit;
}

if ($opt_c){
    open(CFILE,$opt_c) or die "Unable to open check file $opt_c:$!\n";
    while(<CFILE>){
        chomp;
        @savedstats = split('\|');
        die "Wrong number of fields in line beginning with $savedstats[0]\n"
          unless ($#savedstats == 12);
        @currentstats = (lstat($savedstats[0]))[0..7,9..12];
        
        # print the changed fields only if something has changed
        &printchanged(\@savedstats,\@currentstats)
          if ("@savedstats[1..13]" ne "@currentstats");
    }
    close(CFILE);
}

# iterates through attributes lists and prints any changes between
# the two
sub printchanged{
    my($saved,$current)= @_;
    
    # print the name of the file after popping it off of the array read
    # from the check file
    print shift @{$saved},":\n";

    for (my $i=0; $i < $#{$saved};$i++){
	if ($saved->[$i] ne $current->[$i]){
	    print "\t".$statnames[$i]." is now ".$current->[$i];
	    print " (should be ".$saved->[$i].")\n";
	}     
    }
}
-------
#*
#* print the MD5 fingerprint for the /etc/passwd file
#*

use Digest::MD5 qw(md5);

$md5 = new Digest::MD5;

open(PASSWD,"/etc/passwd") or die "Unable to open passwd:$!\n";

# these two lines called also be rolled into one:
#   print Digest::MD5->new->addfile(PASSWD)->hexdigest,"\n";
$md5->addfile(PASSWD);
print $md5->hexdigest."\n";

close(PASSWD);

-------
#*
#* our previous file checking code with MD5 functionality added
#*

use Getopt::Std;
use Digest::MD5 qw(md5);

@statnames = 
 qw(dev ino mode nlink uid gid rdev size mtime ctime blksize blocks md5);

getopt('p:c:');

die "Usage: $0 [-p <filename>|-c <filename>]\n"
  unless ($opt_p or $opt_c);

if ($opt_p){
    die "Unable to stat file $opt_p:$!\n" unless (-e $opt_p);

    open(F,$opt_p) or die "Unable to open $opt_p:$!\n";
    $digest = Digest::MD5->new->addfile(F)->hexdigest;
    close(F);

    print $opt_p,"|",join('|',(lstat($opt_p))[0..7,9..12]),"|$digest","\n";
    exit;
}

if ($opt_c){
    open(CFILE,$opt_c) or die "Unable to open check file $opt_c:$!\n";

    while (<CFILE>){
        chomp;
        @savedstats = split('\|');
        die "Wrong number of fields in \'$savedstats[0]\' line.\n"
          unless ($#savedstats == 13);

        @currentstats = (lstat($savedstats[0]))[0..7,9..12];

        open(F,$savedstats[0]) or die "Unable to open $opt_c:$!\n";
        push(@currentstats,Digest::MD5->new->addfile(F)->hexdigest);
        close(F);

        &printchanged(\@savedstats,\@currentstats)
          if ("@savedstats[1..13]" ne "@currentstats");
    }
    close(CFILE);
}

sub printchanged {
    my($saved,$current)= @_;
    
    print shift @{$saved},":\n";

    for (my $i=0; $i <= $#{$saved};$i++){
	if ($saved->[$i] ne $current->[$i]){
	    print " ".$statnames[$i]." is now ".$current->[$i];
	    print " (".$saved->[$i].")\n";
	}
    }
}
-------
#*
#* transfer and print a DNS zone 
#*

use Net::DNS;

# takes two command-line arguments: the first is the name server 
# to query, the 
# second is the domain to query from that name server
$server = new Net::DNS::Resolver;
$server->nameservers($ARGV[0]); 

print STDERR "Transfer in progress...";
@zone = $server->axfr($ARGV[1]);
die $server->errorstring unless (defined @zone);
print STDERR "done.\n";

for $record (@zone){
    $record->print;
}
-------
#*
#* show the MD5 fingerprint for a DNS zone
#*

use Net::DNS;
use FreezeThaw qw{freeze};
use Digest::MD5 qw(md5);

$server = new Net::DNS::Resolver;
$server->nameservers($ARGV[0]);

print STDERR "Transfer in progress...";
@zone = $server->axfr($ARGV[1]);
die $server->errorstring unless (defined @zone);
print STDERR "done.\n";

$zone = join('',sort map(freeze($_),@zone));

print "MD5 fingerprint for this zone transfer is: ";
print Digest::MD5->new->add($zone)->hexdigest,"\n";
-------
#*
#* look for suspect directory names in a filesystem
#*

require "find.pl";

# Traverse desired filesystems

&find('.');

sub wanted {
    
    (-d $_) and                            # is a directory and is not . or ..
      $_ ne "." and $_ ne ".." and         
	(/[^-.a-zA-Z0-9+,:;_~$#()]/ or     # or contains a "bad" character
	 /^\.{3,}/ or                      # or starts with at least 3 dots
	 /^-/) and                         # or begins with a dash
	   print "'".&nice($name)."'\n";
}

# print a "nice" version of the directory name, i.e. with control chars 
# explicated. This subroutine barely modified from &unctrl() in Perl's
# stock dumpvar.pl
sub nice {
    my($name) = $_[0];
    $name =~ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;

    $name;
}
-------
#*
#* lastcheck - look for logins from more than N domains
#*

sub usage {
    print <<"EOU"
lastcheck - check the output of the last command on a machine
            to determine if any user has logged in from > N domains
            (inspired by an idea from Daniel Rinehart)

   USAGE:  lastcheck [args], where args can be any of:
    -i:           for IP #'s, treat class C subnets as the same "domain"
    -h:           this help message
    -f <domain>   count only foreign domains, specify home domain
    -l <command>: use <command> instead of default /usr/ucb/last
                  note: no output format checking is done!
    -m <#>:       max number of unique domains allowed, default 3
    -u <user>:    perform check for only this username
EOU
    exit;
}

use Getopt::Std;       # standard option processor
getopts('ihf:l:m:u:'); # parse user input

&usage if (defined $opt_h);

# number of unique domains before we complain
$maxdomains = (defined $opt_m) ? $opt_m : 3;  

$lastex = (defined $opt_l) ? $opt_l : "/usr/ucb/last";

open(LAST,"$lastex|") || die "Can't run the program $lastex:$!\n";
while (<LAST>){

    # ignore special users
    next if /^reboot\s|^shutdown\s|^ftp\s/; 

    # if we've used -u to specify a specific user, skip all entries
    # that don't pertain to this user (whose name is stored in $opt_u 
    # by getopts for us).           
    next if (defined $opt_u && !/^$opt_u\s/); 

    # ignore X console logins
    next if /:0\s+:0/;
    
    # find the user's name, tty, and remote hostname
    ($user, $tty,$host) = split;
    
    # ignore if the log had a bad user name after parsing
    next if (length($user) < 2);

    # ignore if no domain name info in name
    next if $host !~ /\./; 

    # find the domain name of this host (see explanation below)
    $dn = &domain($host);

    # ignore if you get a bogus domain name
    next if (length ($dn) < 2); 

    # ignore this input line if it is in the home domain as specified 
    # by the -f switch
    next if (defined $opt_f && ($dn =~ /^$opt_f/));
     
    # if we've never seen this user before, simply create a list with 
    # the user's domain and store this in the hash of lists.
    unless (exists $userinfo{$user}){ 
	$userinfo{$user} = [$dn];
    }
    # otherwise, this can be a bit hairy, see the explanation below
    else {
	&AddToInfo($user,$dn); 
   }
}
close(LAST);

# take a FQDN and attempt to return FQD
sub domain{
    # look for IP addresses
    if ($_[0] =~ /^\d+\.\d+\.\d+\.\d+$/) {
	
	# if the user did not use -i, simply return the IP address as is
	unless (defined $opt_i){ 
	    return $_[0]; 
	}
	# otherwise, return everything but the last octet
	else {
	    $_[0] =~ /(.*)\.\d+$/;
	    return $1;
	}
    }

    # if we are not dealing with an IP address
    else {
	# downcase the info to make later processing simpler and quicker
	$_[0] = lc($_[0]);
	
	# then return everything after first dot
	$_[0] =~ /^[^.]+\.(.*)/; 
	return $1;
    }
}

sub AddToInfo{
    my($user, $dn) = @_;

    for (@{$userinfo{$user}}){