Source Code Examples for "Perl Saves the Day"
LISA2001 Tutorial
David N. Blank-Edelman
December 1, 2001

Note: portions of this source code are excerpted from Perl for System
Administration by David N. Blank-Edelman O'Reilly and Associates, 1st
Edition, ISBN 1-56592-609-9 and have the following copyright:

Copyright 2000 David N. Blank-Edelman and O'Reilly and
Associates. Permission is granted to use this material providing you
attach this copyright statement and it not be used for published
material without prior permission.

The rest is Copyright 2000 Northeastern University and David
Blank-Edelman. All Rights Reserved.

##################################
## Digest::MD5 Code Example #1  ##
##################################

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);

##################################
## Digest::MD5 Code Example #2  ##
##################################

#*
#* 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";

#######################
## Lockfile Example  ##
#######################

#*
#* show the use of a file locking hacking via procmail's lockfile
#* (note: see the Perl Cookbook for Perl methods of locking files)
#*

# this will attempt to lock, break lock after 2mins, retry for a minute
$lockprog = "/usr/local/bin/lockfile -l 120 -r 6 -s 10"; 
# the file we'll be locking
$votelog  = "/share/logo-voting/votes.log"; 

# bogus data to write to file
@choice = (1,2,3);
$comment = "hi there";

# lock the vote log
&lock($votelog); 

# write the vote date, choice & comment to vote log
open (VOTELOG,">>$votelog") or 
   die "Unable to open log for append:$!\n";
print VOTELOG (getpwuid($>))[0];
print VOTELOG "($>) "."---".join(':',@choice)."---";
print VOTELOG ($comment ? "[".$comment."]" : "[no comment]");
print VOTELOG "---".localtime(time),"\n";
close (VOTELOG);

# unlock the vote log
&unlock($votelog);

sub lock {
    my($file) = $_[0];

    my $ret = 0xffff & system ("$lockprog $file.lock");
    return 1 if ($ret == 0);

    die "Unable to lock $file file, please alert systems.\n";    
}

sub unlock {
    my($file) = $_[0];
    unlink "$file.lock" or die "Unable to remove lock file:$!\n";
}

##########################
## Fiile::Rsync Example ##
##########################

use File::Rsync

$r = File::Rsync->new( {archive => 1} );

$r->exec ({ src=>"nsmail/", dest => "polaris:newnsmail/"}) or
  die "rsync was unhappy: " . join ("\n",$r->err);

#################################
## Netgroup File Check Example ##
#################################

die "usage: $0 netgroup-file-name\n" if ($#ARGV < 0);

die "BIG TROUBLES: netgroup file truncated to zero length!\n" 
  if (-z $ARGV[0]);

open (NETGRP, $ARGV[0]) || die "Can't open $ARGV[0]:$!\n";

while(<NETGRP>){
    $line++;
    next if /^#/; # ignore comment lines
    next if /^$/; # ignore blank lines

    # check if universal netgroup exists
    if (/^universal\s+\(\s+,\s+,\s+nisdomain\)/){
        $founduniversal=1;
        next;
    } 

    die "netgroup line $line does not end in a \:$_\n"
        unless (/\\$/);
 
    die "netgroup line $line has a funny format:$_\n" unless 
      (/^\s*\(-,\s*[a-zA-Z0-9\-]+,\s*nisdomain\)\s+\\/ ||
       /^\s*\([a-zA-Z0-9\.\-]+\s*,\s*-\s*,\s+nisdomain\)\s+\\/ ||
       /^\s*[a-zA-Z0-9\-]+\s+\\/)
}

die "BIG TROUBLES: no universal netgroup found in file!\n" unless 
  $founduniversal;

close(NETGRP);

#################
## RCS Example ##
#################

use Rcs;

# file name currently under under RCS
$target = "file"; 
# name of new version of file which will replace current file
$outputfile = "output";

# where our RCS binaries are stored
Rcs->bindir('/usr/local/bin');  

# create a new RCS object
my $rcsobj = Rcs->new;          

# configure it with the name of our target file
$rcsobj->file($target);

# check it out of RCS (must be checked in already)
$rcsobj->co('-l');

# rename our newly created file into place 
rename($outputfile,$target) or 
  die "Unable to rename $outputfile to $target:$!\n";

# check it in
$rcsobj->ci("-u","-m"."Converted by $user on ".scalar(localtime)); 

#######################################
## Manual Filesystem Walking Example ##
#######################################

#*
#* search a filesystem "by hand" for damaged files
#*

use Cwd; # module for finding the current working directory
$|=1;    # turn off I/O buffering

sub ScanDirectory {
    my ($workdir) = shift;
    my($startdir) = &cwd; # keep track of where we began

    chdir($workdir) or die "Unable to enter dir $workdir:$!\n";
    opendir(DIR, ".") or die "Unable to open $workdir:$!\n";
    my @names = readdir(DIR);
    closedir(DIR);

    foreach my $name (@names){
	next if ($name eq ".");
	next if ($name eq "..");
	if (-d $name){ # is this a directory?
	    &ScanDirectory($name);
	    next;
	}
	unless (&CheckFile($name)){
	    print &cwd."/".$name."\n"; # print the bad filename
	}
    }

    chdir($startdir) or die "Unable to change to dir $startdir:$!\n";
}

sub CheckFile{
    my($name) = shift;

    print STDERR "Scanning ". &cwd."/".$name."\n";

    # attempt to read the directory entry for this file
    my @stat = stat($name);
    if (!$stat[4] && !$stat[5] && !$stat[6] && !$stat[7] && !$stat[8]){
	return 0;
    }

    # attempt to open this file
    unless (open(T,"$name")){
	return 0;
    }

    # read the file one byte at a time
    for (my $i=0;$i< $stat[7];$i++){
	my $r=sysread(T,$i,1);
	if ($r !=1) {
	    close(T);
	    return 0;
	}
    }
    close(T);
    return 1;
}
&ScanDirectory(".");

########################
## Mailgrovel Example ##
########################

#####
### mailgrovel 0.7 - this script will grovel around in all users .forwards
###                  and .procmailrcs to inform us of potential problems
###                  with portability
#####

use Array::PrintCols;

$homedirroot = "/na/homedirs"; # top level for all home directories

#### get the list of all of the active home directories
opendir (ROOT,$homedirroot) or die "Unable to open $homedirroot:$!\n";
for $rootdir (readdir(ROOT)){
    next if /^\./;

    opendir (DIR,"$homedirroot/$rootdir") or 
      die "Unable to open $rootdir:$!\n";
    for (readdir(DIR)){
        next if /^\./;
        push (@homedirs,"$rootdir/$_");
    }
    closedir(DIR);
}

closedir (ROOT);

### read in all of the .forwards and .procmailrcs
for $homedir (@homedirs){
    if (-f "$homedirroot/$homedir/.procmailrc"){

        # read in .entire .procmailrc
        open (F,"$homedirroot/$homedir/.procmailrc") or 
          warn "Can't open $homedir/.procmailrc:$!\n";
        $procmails{$homedir} = (join('',<F>));
        close (F);

        # user has a .procmailrc but no .forward!
        push(@noforward,$homedir)
          if (!-f "$homedirroot/$homedir/.forward");
    }

    # read in first (and only relevant) line of .forward
    if (-f "$homedirroot/$homedir/.forward"){
        open (F,"$homedirroot/$homedir/.forward") or 
          warn "Can't open $homedir/.forward:$!\n";
        chomp($forwards{$homedir} = (<F>));
        close (F);
    }
}

#### analyze the forwards
foreach $homedir (keys %forwards){
    # we only care about pipes to programs
    next if (index($forwards{$homedir},"|") == -1);
    
    # whoops, they reference /local (a deprecated filesystem)
    if (index($forwards{$homedir},"/local") != -1){
        $localproblem{$homedir}=$forwards{$homedir};
        next;
    }

    # if they are likely to have the standard procmail format, they are fine
    next if ($forwards{$homedir} =~ /\|IFS=/);

    # ig they call vacation in an ok spot, they are fine
    next if ($forwards{$homedir} =~ /\/usr\/ucb\/vacation/);

    # otherwise, better check
    $problemforw{$homedir}=$forwards{$homedir};
}

$*=1; # so we can do multi-line matches

#### analyze .procmails
foreach $homedir (keys %procmails){
    # we only care about pipes to external programs
    next if ($procmails{$homedir} !~ /^\|/);

    # extract only the lines which pipe to external programs
    $problemproc{$homedir}= join(";",
                                 grep(/^\|/,
                                      split(/\n/,$procmails{$homedir})));
}

### OK, now let's talk about what we found

print "\n==== .forward references /local ====\n";

for (sort keys %localproblem){
    $dir  = $_;
    $line = $localproblem{$_};
    write;
}
print "\n==== potential problem .forwards ====\n";

for (sort keys %problemforw){
    $dir  = $_;
    $line = $problemforw{$_};
    write;
}

print "\n==== potential problem .procmailrcs ====\n";

for (sort keys %problemproc){
    $dir  = $_;
    $line = $problemproc{$_};
    write;
}
print "\n==== users that have a .procmailrc but not a .forward  ====\n";
print_cols [sort @noforward];


format STDOUT =
@<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$dir,$line
.

#################################
## Find Long Filenames Example ##
#################################

# note: this code was modified from the code
# created by find2perl, hence the icky require

require "find.pl";

# Traverse desired filesystems

&find('.');
print "max:$max\n";

exit;

sub wanted {
    return if (! -f $_);
    if (length($_) > $maxlength){
	$max = $name;
	$maxlength = length($_);
    }
    if (length($name) > 200) { print $name,"\n";}
}

################################
## Find Bad Filenames Example ##
################################

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

###################################
## Proc::ProcessTable Example #1 ##
###################################

# example quoted from documentation for Proc::ProcessTable

use Proc::ProcessTable;

$t = new Proc::ProcessTable;
foreach $p (@{$t->table}){    
  if ($p->pctmem > 95){
    $p->kill(9);
  }             
}


###################################
## Proc::ProcessTable Example #2 ##
###################################

#*
#* look and log processes named "eggdrop" under UNIX
#* (there are other suspicious names that we could look
#* for, like anything that starts with ./
#*

use Proc::ProcessTable;

open(LOG,">>$logfile") or die "Can't open logfile for append:$!\n";

$t = new Proc::ProcessTable;
foreach $p (@{$t->table}){    
    if ($p->fname() =~ /eggdrop/i){
	print LOG time."\t".getpwuid($p->uid)."\t".$p->fname()."\n";
    }             
}
close(LOG);

##########################
## Win32::IProc Example ##
##########################

#*
#* show the list of process ids and names under NT/2000 using Win32::IProc
#*
use Win32::IProc;

$pobj=new Win32::IProc or die "Unable to create process object: $!\n";

$pobj->EnumProcesses(\@processlist) or 
  die "Unable to get process list:$!\n";

foreach $process (@processlist){
    $pid  = $process->{ProcessId};
    $name = $process->{ProcessName};
    write;
}

format STDOUT_TOP =
Process ID      Process Name
==========      ===============================
.
format STDOUT =
@<<<<<<<        @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$pid,           $name
.

##################
## Lsof Example ##
##################

#*
#* check for unauthorized IRC clients (e.g bots).
#*

$lsofexec = "/usr/local/bin/lsof";
$lsofflag = "-FL0c -iTCP:6660-7000";

# this is a hash slice being used to preload a hash table, the 
# existence of whose keys we'll check later. Usually this gets written 
# like this:
#     %approvedclients = ("ircII" => undef, "xirc" => undef, ...); 
# (but this is a cool idiom popularized by Mark-Jason Dominus)
@approvedclients{"ircII","xirc","pirc"} = (); 

open(LSOF,"$lsofexec $lsofflag|") or
  die "Unable to start $lsof:$!\n";

while(<LSOF>){
    ($pid,$command,$login) = /p(\d+)\000
                              c(.+)\000
                              L(\w+)\000/x;
    warn "$login using an unapproved client called $command (pid $pid)!\n"
      unless (exists $approvedclients{$command});
}

close(LSOF);

##########################
## Last Scanner Example ##
##########################

#*
#* 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}}){

	# case #1 & #2 from above: is this either exact or substring match?
	return if (index($_,$dn) > -1); 

	# check case #3 from above, i.e. is the stored domain data
	# a substring of the domain name we are checking?
	if (index($dn,$_) > -1){
	    $_ = $dn; # swap current & stored values
	    return;
	} 
    }
    
    # otherwise, this is a new domain, add it to the list
    push @{$userinfo{$user}}, $dn;
}

for (sort keys %userinfo){
    if ($#{$userinfo{$_}} > $maxdomains){
	print "\n\n$_ has logged in from:\n";
	print join("\n",sort @{$userinfo{$_}});
    }
}
print "\n";

#############################
## Log Correlation Example ##
#############################

#*
#* breach finder II (adding tcp wrapper log file scanning)
#*

$template       = "A8 A8 A16 l"; # for SunOS 4.1.x
$recordsize     = length(pack($template,()));
($user,$ignore) = @ARGV;

# tcpd log file location
$tcpdlog        = "/var/log/tcpd/tcpdlog"; 
$hostlen        = 16;  # max length of hostname in wtmp file


print "-- scanning for first host contacts from $user --\n";
open(WTMP,"/var/adm/wtmp") or die "Unable to open wtmp:$!\n";
while (read(WTMP,$record,$recordsize)) {
    ($tty,$name,$host,$time)=unpack($template,$record);
    
    if ($user eq $name){
       next if (defined $ignore and $host =~ /$ignore/o);
       if (length($host) > 2 and !exists $contacts{$host}){
	   $connect = localtime($time);
	   $contacts{$host}=$time;
	   write;
       }
   }
}

print "-- scanning for other contacts from those hosts --\n";
die "Unable to seek to beginning of wtmp:$!\n"
  unless (seek(WTMP,0,0));

while (read(WTMP,$record,$recordsize)) {
    ($tty,$name,$host,$time)=unpack($template,$record);
    
    # if it is not a logout, and we're looking for this host,
    # and this is a connection from a user *other* than the 
    # compromised account, then record
    if (substr($name,1,1) ne "\0" and exists $contacts{$host} and 
 	$name ne $user){
           $connect = localtime($time);
   	   write;
    }
}
close(WTMP);

# here's the output format, may need to be adjusted based on template
format STDOUT = 
@<<<<<<<<    @<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<
$name,$host,$connect
.

print "-- scanning tcpdlog --\n";
open(TCPDLOG,$tcpdlog) or die "Unable to read $tcpdlog:$!\n";
while(<TCPDLOG>){
    next if !/connect from /; # we only care about connections
    ($connecto,$connectfrom) = /(.+):\s+connect from\s+(.+)/;
    $connectfrom =~ s/^.+@//;

    # tcpwrappers can log the entire hostname, not just the first N 
    # characters like some wtmp logs. As a result, we need to truncate 
    # the hostname at the same place as the wtmp file if we want to 
    # perform a hash lookup below
    $connectfrom = substr($connectfrom,0,$hostlen);
    print if (exists $contacts{$connectfrom} and 
              $connectfrom !~ /$ignore/o);
}

#######################
## Big Buffy Example ##
#######################

#*
#* bigbuffy - handling log files with circular buffering
#*

$buffsize = 200; # default circular buffer size (in lines)

use Getopt::Long;

# parse the options
GetOptions("buffsize=i" => \$buffsize,
           "dumpfile=s" => \$dumpfile);

# set up the signal handler and initialize a counter
&setup;

# and away we go! (with just a simple 
# read line-store line loop)
while (<>){
    # insert line into data structure 
    # note, we do this first, even if we've caught a signal. 
    # Better to dump an extra line than lose a line of data if 
    # something goes wrong in the dumping process

    $buffer[$whatline] = $_;

    # where should the next line go? 
    ($what_line %= $buff_size)++;

    # if we receive a signal, dump the current buffer
    if ($dumpnow) {
	&dodump();
    }
}

sub setup {
    die "USAGE: $0 [--buffsize=<lines>] --dumpfile=<filename>"
      unless (length($dumpfile));

    $SIG{'USR1'} = \&dumpnow; # set a signal handler for dump

    $whatline = 1; # start line in circular buffer
}

# simple signal handler that just sets an exception flag, 
# see perlipc(1)
sub dumpnow {
    $dumpnow = 1;
}

# dump the circular buffer out to a file, appending to file if
# it exists
sub dodump{
    my($line);     # counter for line dump
    my($exists);   # flag, does the output file exist already?
    my(@firststat,@secondstat); # to hold output of lstats

    $dumpnow = 0;  # reset the flag and signal handler
    $SIG{'USR1'} = \&dumpnow;

    if (-e $dumpfile and (! -f $dumpfile or -l $dumpfile)) {
	warn "ALERT: dumpfile exists and is not a plain file,skipping dump.\n";
	return undef;
    }

    # we have to take special precautions when we're doing an 
    # append. The next set of "if" statements perform a set of 
    # security checks while opening the file for append
    if (-e $dumpfile) {
	$exists = 1;
	unless(@firststat = lstat $dumpfile){
	    warn "Unable to lstat $dumpfile,skipping dump.\n";
	    return undef;
	}
	if ($firststat[3] != 1) {
	    warn "$dumpfile is a hard link, skipping dump.\n";
	    return undef;
	}
    }

    unless (open(DUMPFILE,">>$dumpfile")){
	warn "Unable to open $dumpfile for append,skipping dump.\n";
	return undef;
    }
    if ($exists) {
	unless (@secondstat = lstat DUMPFILE){
	    warn "Unable to lstat opened $dumpfile,skipping dump.\n";
	    return undef;
	}

	if ($firststat[0] != $secondstat[0] or # check dev num
	    $firststat[1] != $secondstat[1] or # check inode
	    $firststat[7] != $secondstat[7])   # check sizes
	  {
	      warn "SECURITY PROBLEM: lstats don't match,skipping dump.\n";
	      return undef;
	  }
    }

    $line = $whatline;
    print DUMPFILE "-".scalar(localtime).("-"x50)."\n";
    do {
        # in case buffer was not full
	last unless (defined $buffer[$line]);
	print DUMPFILE $buffer[$line];
	$line = ($line == $buffsize) ? 1 : $line+1;
    } while ($line != $whatline);

    close(DUMPFILE);

    # zorch the active buffer to avoid leftovers 
    # in future dumps
    $whatline = 1;
    $buffer = ();
    
    return 1;
}

##################################
## Mail Sendings Basics Example ##
##################################

#*
#* sending mail using Mail::Mailer
#*

use Mail::Mailer;

$from="me\@example.com";
$to="you\@example.com";
$subject="Hi there";
$body="message body\n";

$type="smtp";
$server="mail.example.com";

my $mailer = Mail::Mailer->new($type, Server => $server) or
  die "Unable to create new mailer object:$!\n";

$mailer->open({From => $from, 
               To => $to, 
               Subject => $subject}) or 
  die "Unable to populate mailer object:$!\n";

print $mailer $body;
$mailer->close;

##############################
## Delay Subroutine Example ##
##############################

#*
#* subroutine for performing exponential backoff (uses a closure)
#*

$max  = 24*60*60; # maximum amount of delay in seconds (1 day)
$unit = 60;       # increase delay by measures of this unit (1 min)

# provide a closure with the time we last sent a message and 
# the last power of 2 we used to compute the delay interval. 
# The subroutine we create will return a reference to an 
# anonymous array with this information
sub time_closure {
    my($stored_sent,$stored_power)=(0,-1);
    return sub {
       (($stored_sent,$stored_power) = @_) if @_;
       [$stored_sent,$stored_power];
    }
};

$last_data=&time_closure; # create our closure

# return true first time called and then once after an 
# exponential delay
sub expbackoff {
    my($last_sent,$last_power) = @{&$last_data};

    # reply true if this is the first time we've been asked, or if the
    # current delay has elapsed since we last asked. If we return true, 
    # we stash away the time of our last affirmative reply and increase 
    # the power of 2 used to compute the delay.
    if (!$last_sent or
	($last_sent + 
         (($unit * 2**$last_power >= $max) ? 
             $max : $unit * 2**$last_power) <= time())){
         	       &$last_data(time(),++$last_power);
              return 1;
    }
    else {
	return 0;
    }
}

##########################
## HTTP::Daemon Example ##
##########################

use HTTP::Daemon;

my $d = HTTP::Daemon->new(LocalAddr=> 'host.edu:8080');
while (my $c = $d->accept){
    $c->send_file_response("status.html");
    $c->close;
    undef $c;
}

################################
## NetServer::Generic Example ##
################################


use NetServer::Generic;

my $callback = sub { print STDOUT "Current uptime: " . `/usr/ucb/uptime`;};

my ($server) = NetServer::Generic->new;
$server->port(79); # this is the finger port

$server->callback($callback);
$server->mode("select");

$server->run;

#####################
## Fakelpd Example ##
#####################

# fakelpd - for those times when a particular LPD client is annoying 
# 
# camps out on the printer port waiting for LPD jobs. Responds in the
# affirmative to everything sent by the client, allowing us to eat the
# job so the client will shut up and go away. Loops forever until
# control-c'd
#
# NOTES: 
#        1) be sure to kill the existing lpd before running this and restart it
#           when you are done.
#        2) this script must be run as root to bind to priv'd printer port
#
#     --- dNb 02/28/00

use IO::Socket;

# set up our side of the socket
$server = IO::Socket::INET->new(LocalPort => "printer",
                                  Proto => "tcp",
                                  Type => SOCK_STREAM,
                                  Listen => 5,
                                  Reuse => 1)
  or die "Unable to build our socket half: $!\n";

$SIG{INT}=\&dienicely; # close the socket on control-c

# start listening on it for connects
while(($connectsock,$connectaddr) = $server->accept){

    # first, get the print spool name
    ($spool) =  $connectsock->getline =~ /.(\w+)\012/;
    print STDERR "---- receiving job for $spool ----\n";
    $connectsock->print("\000"); # send confirmation to client

    # get either a data or a control file info (RFC1197 doesn't specify order)
    # we'll do this again because jobs are made up of both a control and a
    # data file
    ($xfsize,$xfname) = $connectsock->getline =~ /.(\d+)\s(\S+)\012/;
    $xfsize++; # size is always one byte bigger than the number we get told
    $type = index($xfname,"cfA") == 0 ? "control" : "data";
    print STDERR "receiving: $type file: $xfname, size: $xfsize\n";
    $connectsock->print("\000");


    # eat the file. Note: we read this X bytes at a time instead of doing
    # something like "->read($xfile,xfsize+1)" to avoid having to fill $xfile
    # with the contents of a 30GB print job
    $recvd = 0;
    while (defined $connectsock->recv($xfile,4096)){
        $recvd += length($xfile);
        print STDERR "\r$recvd/$xfsize";
        last if ($recvd == $xfsize); 
    }
    $connectsock->print("\000");
    print STDERR "\n";
        
    # now get the other kind of file
    ($xfsize,$xfname) = $connectsock->getline =~ /.(\d+)\s(\S+)\012/;
    $xfsize++; # size is always one byte bigger than the number we get told
    $type = index($xfname,"cfA") == 0 ? "control" : "data";
    print STDERR "receiving: $type file: $xfname, size: $xfsize\n";
    $connectsock->print("\000");
    $recvd = 0;
    while (defined $connectsock->recv($xfile,4096)){
        $recvd += length($xfile);
        print STDERR "\r$recvd/$xfsize";
        last if ($recvd == $xfsize); 
    }
    $connectsock->print("\000");
    print STDERR "\n";
    
    print STDERR "----  job completed ----\n";
    close ($connectsock);
}

# close the socket on the way out
sub dienicely{
    close ($connectsock);
    close($server);
    exit;
}

###########################
## Printshepherd Example ##
###########################

use File::Tail;

$lpcexec = "/usr/etc/lpc";

$file = File::Tail->new(name=>"/var/spool/$ARGV[0]/hpserv.log",
                        maxinterval=>5,
                        interval=>1,
                        adjustafter=>3);
while (defined ($line=$file->read)){
    if (index($line,"Finished Job") != -1){
        print "$line";
        system("$lpcexec restart $ARGV[0] > /dev/null");
        system("$lpcexec stat $ARGV[0]");
    }
}

#############################
## DNS Consistency Example ##
#############################

#*
#* checking DNS server response integrity using Net::DNS
#*

use Net::DNS;

@servers = qw(nameserver1 nameserver2 nameserver3); # name of the name servers
foreach $server (@servers) {
    &lookupaddress($hostname,$server);              # populates %results
}
%inv = reverse %results;        # invert the result hash
if (scalar(keys %inv) > 1) {   # see how many elements it has
    print "There is a discrepency between DNS servers:\n";
    use Data::Dumper;
    print Data::Dumper->Dump([\%results],["results"]),"\n";
}

# only slightly modified from example in the Net::DNS manpage
sub lookupaddress{
    my($hostname,$server) = @_;

    $res = new Net::DNS::Resolver;

    $res->nameservers($server);

    $packet = $res->query($hostname);

    if (!$packet) {
	warn "Unable to lookup data for $hostname from $server!\n";
	return;
    }
    # stores the last RR we receive
    foreach $rr ($packet->answer) {
	$results{$server}=$rr->address;
    }
}

#####################################
## Clog and Ping Example Version 1 ##
#####################################

#*
#* using external program to watch for SYN packets and ping back
#*

$clogex   = "/usr/local/bin/clog";      # location/switches for clog
$fpingex  = "/usr/local/bin/fping -r1"; # location/switches for fping

$localnet = "192.168.1";                # local network prefix

open CLOG, "$clogex|" or die "Unable to run clog:$!\n";
while(<CLOG>){
    ($date,$orighost,$origport,$desthost,$destport) = split(/\|/);
    next if ($orighost =~ /^$localnet/);
    next if (exists $cache{$orighost});
    print `$fpingex $orighost`;
    $cache{$orighost}=1;
}

#####################################
## Clog and Ping Example Version 2 ##
#####################################

#*
#* network sniff for SYN packets and ping back (all in Perl)
#*

use Net::PcapUtils;

use NetPacket::Ethernet;
use NetPacket::IP;

use Net::Ping;

# local network 
$localnet = "192.168.1";
# filter string that looks for SYN-only packets not originating from 
# local network
$prog = "tcp[13] = 2 and src net not $localnet"; 

$| = 1; # unbuffer STDIO

# construct the ping object we'll use later
$p = new Net::Ping("icmp");

# and away we go
die "Unable to perform capture:".Net::Pcap::geterr($descript)."\n"
  if (Net::PcapUtils::open_live(\&grab_ip_and_ping, FILTER => $prog));

# find the source IP address of a packet, and ping it (once per run)
sub grab_ip_and_ping{
    my ($arg,$hdr,$pkt) = @_ ;

    # get the source IP adrress
    $src_ip = NetPacket::IP->decode(
			    NetPacket::Ethernet::strip($pkt))->{src_ip};

    print "$src_ip is ".(($p->ping($src_ip)) ? "alive" : "unreachable")."\n" 
      unless $cache{$src_ip}++;
}