Source Code Examples for "Perl for System Administration"
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.

#######################
## Big Buffy Excerpt ##
#######################

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


################################
## Log File Analysis Examples ##
################################

#*
#* count the total number of reboots on a Solaris 2.6 machine
#*

# template for Solaris 2.6 wtmpx, see the pack() doc 
# for more information
$template = "A32 A4 A32 l s s2 x2 l2 l x20 s A257 x"; 

# determine the size of a record
$recordsize = length(pack($template,()));

# open the file
open(WTMP,"/var/adm/wtmpx") or die "Unable to open wtmpx:$!\n";

# read through it one record at a time
while (read(WTMP,$record,$recordsize)) {
    ($ut_user,$ut_id,$ut_line,$ut_pid,$ut_type,$ut_e_termination,
     $ut_e_exit,$tv_sec,$tv_usec,$ut_session,$ut_syslen,$ut_host)=
       unpack($template,$record);

    if ($ut_line eq "system boot"){
        print "rebooted ".scalar localtime($tv_sec)."\n";
        $reboots++;
    }
}

close(WTMP);
print "Total reboots: $reboots\n";
-------
#*
#* summarize the events in the NT/2000 System event log
#*

use Win32::EventLog;

my %event=('Length',NULL,
           'RecordNumber',NULL, 
           'TimeGenerated',NULL,
           'TimeWritten',NULL, 
           'EventID',NULL, 
           'EventType',NULL,  
           'Category',NULL,
           'ClosingRecordNumber',NULL,
           'Source',NULL, 
           'Computer',NULL,
           'Strings',NULL,
           'Data',NULL,); 

# partial list of event types, i.e. Type 1 is "Error",
# 2 is "Warning", etc.
@types = ("","Error","Warning","","Information");

Win32::EventLog::Open($EventLog,'System','') or 
  die "Could not open System log:$^E\n";

$EventLog->Win32::EventLog::GetNumber($numevents);
$EventLog->Win32::EventLog::GetOldest($oldestevent); 

$EventLog->Win32::EventLog::Read((EVENTLOG_SEEK_READ |
                                  EVENTLOG_FORWARDS_READ),
                                  $numevents + $oldestevent, $event);

# loop through all of the events, recording the number of 
# Source and EventTypes
for ($i=0;$i<$numevents;$i++) {
    $EventLog->Read((EVENTLOG_SEQUENTIAL_READ | 
                     EVENTLOG_FORWARDS_READ),  
                     0, $event);
    $source{$event->{Source}}++;
    $types{$event->{EventType}}++;
}

# now print out the totals
print "-->Event Log Source Totals:\n";
for (sort keys %source) {
    print "$_: $source{$_}\n";
}
print "-"x30,"\n";
print "-->Event Log Type Totals:\n";
for (sort keys %types) {
    print "$types[$_]: $types{$_}\n";
}
print "-"x30,"\n";
print "Total number of events: $numevents\n";
-------
#*
#* summarize events in an NT/2000 System event log using an external program
#*

eldump = 'c:\bin\eldump';      # path to ElDump
# output data field separated by ~ and without full message
# text (faster)
$dumpflags = '-l system -c ~ -M'; 
      
open(ELDUMP,"$eldump $dumpflags|") or die "Unable to run $eldump:$!\n";

print STDERR "Reading system log.";

while(<ELDUMP>){    ($date,$time,$source,$type,$category,$event,$user,$computer) = 
    split('~');
    $$type{$source}++;
    print STDERR ".";
}
print STDERR "done.\n";

close(ELDUMP);

# for each type of event, print out the sources and number of 
# events per source
foreach $type (qw(Error Warning Information 
                  AuditSuccess AuditFailure)){
    print "-" x 65,"\n";
    print uc($type)."s by source:\n";
    for (sort keys %$type){
        print "$_ ($$type{$_})\n";
    }
}
print "-" x 65,"\n";
-------
#*
#* breach finder for SunOS 4.1.x - show all contacts from a particular
#* host involved in a security breach
#*

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

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" andexists $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
.
-------
#*
#* show the top transfers from a WU-FTPD xferlog file
#*

$xferlog = "/var/adm/log/xferlog";

open(XFERLOG,$xferlog) or die "Unable to open $xferlog:$!\n";

while (<XFERLOG>){
    $files{(split)[8]}++;
}

close(XFERLOG);

for (sort {$files{$b} <=> $files{$a}||$a cmp $b} keys %files){
    print "$_:$files{$_}\n";
}
-------
#*
#* 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" andexists $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);
}
-------
#*
#* correlate wu-ftpd log files with wtmp file to determine which transfers
#* happened when and from what machines
#*

# for date->UNIX time (secs from Epoch) conversion
use Time::Local; 

$xferlog = "/var/log/xferlog"; # location of transfer log
$wtmp = "/var/adm/wtmp";       # location of wtmp
$template = "A8 A8 A16 l";     # SunOS 4.1.4 template for wtmp 
$recordsize = length(pack($template,())); # size of each wtmp entry
$hostlen = 16;   # max length of the hostname in wtmp
# month name to number mapping
%month = qw{Jan 0 Feb 1 Mar 2 Apr 3 May 4 Jun 5 Jul 6 
	    Aug 7 Sep 8 Oct 9 Nov 10 Dec 11};  

&ScanXferlog;    # scan the transfer log
&ScanWtmp;       # scan the wtmp log
&ShowTransfers;  # correlate and print transfers

sub ScanXferlog {
    local($sec,$min,$hours,$mday,$mon,$year);
    my($time,$rhost,$fname,$direction);

    print STDERR "Scanning $xferlog...";
    open(XFERLOG,$xferlog) or 
      die "Unable to open $xferlog:$!\n";
    
    while (<XFERLOG>){
	# use an array slice to select the fields we want
	($mon,$mday,$time,$year,$rhost,$fname,$direction) = 
          (split)[1,2,3,4,6,8,11];

	# add the direction of transfer to the file name, 
	# i is "transferred in"
	$fname = ($direction eq 'i' ? "-> " : "<- ") . $fname;

	# convert the transfer time to UNIX epoch format
	($hours,$min,$sec) = split(':',$time);
	$unixdate = timelocal($sec,$min,$hours,$mday,$month{$mon},$year);

	# put the data into a hash of lists of lists:
	push(@{$transfers{substr($rhost,0,$hostlen)}},[$unixdate,$fname]);
    }
    close(XFERLOG);
    print STDERR "done.\n";
}

# scans the wtmp file and populates the @sessions structure 
# with ftp sessions
sub ScanWtmp {
    my($record,$tty,$name,$host,$time,%connections);

    print STDERR "Scanning $wtmp...\n";
    open(WTMP,$wtmp) or die "Unable to open $wtmp:$!\n";

    while (read(WTMP,$record,$recordsize)) {

	# don't even bother to unpack if record does not begin
        # with ftp. NOTE: this creates a wtmp format dependency 
        # as a trade-off for speed
	next if (substr($record,0,3) ne "ftp");

	($tty,$name,$host,$time)=unpack($template,$record);

        # if we find an open connection record, then 
        # create a hash of list of lists. The LoL will be used
        # as a stack below.
	if ($name and substr($name,0,1) ne "\0"){
	    push(@{$connections{$tty}},[$host,$time]);
	}
	# if we find a close connection record, we try to pair
	# it with a previous open connection record we recorded 
	# before
	else {
	    unless (exists $connections{$tty}){
		warn "found lone logout on $tty:" . 
		  scalar localtime($time)."\n";
		next;
	    }
	    # we'll use the previous open connect and this
	    # close connect to record this as a single session. 
	    # To do that we create a list of lists where each 
	    # list is (hostname, login, logout) 
	    push(@sessions,[@{shift @{$connections{$tty}}},$time]);

	    # if no more connections on the stack for that
            # tty, remove from hash
	    delete $connections{$tty} unless (@{$connections{$tty}});
	}	
    }
    close(WTMP);
    print STDERR "done.\n";
}

# iterate over the session log, pairing sessions
# with transfers
sub ShowTransfers {
    local($session);

    foreach $session (@sessions){

	# print session times
	print scalar localtime($$session[1]) . "-" .
	      scalar localtime($$session[2]) . 
	      " $$session[0]\n";

	# find all files transferred in this connection triad 
	# and print them
	print &FindFiles(@{$session}),"\n";
    }
}

# returns all of the files transferred for a given connect session triad
sub FindFiles{
    my($rhost,$login,$logout) = @_;
    my($transfer,@found);

    # easy case, no transfers in this login
    unless (exists $transfers{$rhost}){
	return "\t(no transfers in xferlog)\n";
    }

    # easy case, first transfer we have on record is 
    # after this login
    if ($transfers{$rhost}->[0]->[0] > $logout){
	return "\t(no transfers in xferlog)\n";
    }

    # find any files transferred in this session
    foreach $transfer (@{$transfers{$rhost}}){

        # if transfer happened before login 
	next if ($$transfer[0] < $login);  

        # if transfer happened after logout
	last if ($$transfer[0] > $logout); 

        # if we've already used this entry
	next unless (defined $$transfer[1]);  

	push(@found,"\t".$$transfer[1]."\n");
	undef $$transfer[1];
    }
    ($#found > -1 ? @found : "\t(no transfers in xferlog)\n")
}
-------
#*
#* show all deliveries in a sendmail mail log
#*

use SyslogScan::DeliveryIterator;

# a list of mail syslog files
$maillogs = ["/var/log/mail/maillog"]; 

$iterator = new SyslogScan::DeliveryIterator(syslogList => $maillogs);
while ($delivery = $iterator -> next()){
    print $delivery->{Sender}." -> ".
      join(",",@{$delivery->{ReceiverList}}),"\n";
}
-------
#*
#* summarize all deliveries in a sendmail mail log
#*

use SyslogScan::DeliveryIterator;
use SyslogScan::Summary;
use SyslogScan::ByGroup;
use SyslogScan::Usage;

# the location of our maillog
$maillogs = ["/var/log/mail/maillog"]; 

# get an iterator for this file
$iterator = new SyslogScan::DeliveryIterator(
                                syslogList => $maillogs);

# feed this iterator to ::Summary, receive a summary object
$summary = new SyslogScan::Summary($iterator);

# feed this summary object to ::ByGroup and receive a 
# stats-by-group object
$bygroup = new SyslogScan::ByGroup($summary);

# print the contents of this object
foreach $group (sort keys %$bygroup){
    ($bmesg,$bbytes)=@{$bygroup->{$group}->
			 {groupUsage}->getBroadcastVolume()};
    ($smesg,$sbytes)=@{$bygroup->{$group}->
			 {groupUsage}->getSendVolume()};
    ($rmesg,$rbytes)=@{$bygroup->{$group}->
			 {groupUsage}->getReceiveVolume()};
    ($rmesg,$rbytes)=@{$bygroup->{$group}->
			 {groupUsage}->getReceiveVolume()};
    write;
}

format STDOUT_TOP =
Name                         Bmesg  BByytes  Smesg  SBytes   Rmesg  Rbytes
---------------------------  -----  -------- ------ -------- ------ -------
.
format STDOUT =
@<<<<<<<<<<<<<<<<<  @>>>>> @>>>>>>> @>>>>> @>>>>>>> @>>>>> @>>>>>>>
$group,$bmesg,$bbytes,$smesg,$sbytes,$rmesg,$rbytes
.

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

#########################
## XML::Parser Example ##
#########################

#*
#* parsing our queue file using XML::Parser
#*

use XML::Parser;
use Data::Dumper; # used for debugging output, not needed for XML parse
$p = new XML::Parser(ErrorContext => 3, 
		     Style        => 'Stream',
		     Pkg          => 'Account::Parse');

# handle multiple account records in a single XML queue file
open(FILE,$addqueue) or die "Unable to open $addqueue:$!\n";

# this clever read idiom courtesy of Jeff Pinyan
read(FILE, $queuecontents, -s FILE);
$p->parse("<queue>".$queuecontents."</queue>");

package Account::Parse;

sub StartTag {
    undef %record if ($_[1] eq "account");
}

sub Text {
    my $ce = $_[0]->current_element();
    $record{$ce}=$_ unless ($ce eq "account");
}

sub EndTag {
    print Data::Dumper->Dump([\%record],["account"]) 
      if ($_[1] eq "account");    
    # here's where we'd actually do something, instead of just
    # printing the record
}

#################################
## XML::Simple Parsing Example ##
#################################

#*
#* reading and printing out a queue file using XML::Simple
#*

use XML::Simple;
use Data::Dumper;  # just needed to show contents of our data structures

$queuefile = "addqueue.xml";
open(FILE,$queuefile) or die "Unable to open $queuefile:$!\n";
read (FILE, $queuecontents, -s FILE);

$queue = XMLin("<queue>".$queuecontents."</queue>");

print Data::Dumper->Dump([$queue],["queue"]);

#################################
## XML::Simple Writing Example ##
#################################

#*
#* writing XML using XML::Simple
#*

use XML::Simple;

# rootname sets the root element's name, we could also use xmldecl to
# add an XML declaration
print XMLout($queue, rootname =>"queue"); 

#################
## DBI Example ##
#################

#*
#* documenting a MySQL server using DBI
#*

use DBI;

print "Enter user for connect: ";
chomp($user = <STDIN>);
print "Enter passwd for $user: ";
chomp($pw = <STDIN>);

$start= "mysql"; # connect initially to this database

# connect to the start MySQL database
$dbh = DBI->connect("DBI:mysql:$start",$user,$pw);
die "Unable to connect: ".$DBI::errstr."\n" unless (defined $dbh);

# find the databases on the server 
$sth=$dbh->prepare(q{SHOW DATABASES}) or
  die "Unable to prepare show databases: ". $dbh->errstr."\n";
$sth->execute or
  die "Unable to exec show databases: ". $dbh->errstr."\n";
while ($aref = $sth->fetchrow_arrayref) {
    push(@dbs,$aref->[0]);
} 
$sth->finish;

# find the tables in each database
foreach $db (@dbs) {
    print "---$db---\n";
    
    $sth=$dbh->prepare(qq{SHOW TABLES FROM $db}) or
      die "Unable to prepare show tables: ". $dbh->errstr."\n";
    $sth->execute or
      die "Unable to exec show tables: ". $dbh->errstr."\n";

    @tables=();
    while ($aref = $sth->fetchrow_arrayref) {
	push(@tables,$aref->[0]);
    } 

    $sth->finish;
    
   # find the column info for each table
   foreach $table (@tables) {
       print "\t$table\n";

       $sth=$dbh->prepare(qq{SHOW COLUMNS FROM $table FROM $db}) or
	 die "Unable to prepare show columns: ". $dbh->errstr."\n";
       $sth->execute or
	 die "Unable to exec show columns: ". $dbh->errstr."\n";
       
       while ($aref = $sth->fetchrow_arrayref) {
	   print "\t\t",$aref->[0]," [",$aref->[1],"]\n";
       } 

       $sth->finish;
   }
}
$dbh->disconnect;

##################
## ODBC Example ##
##################

#*
#* documenting an MS-SQL server using ODBC
#*

use Win32::ODBC;

print "Enter user for connect: ";
chomp($user = <STDIN>);
print "Enter passwd for $user: ";
chomp($pw = <STDIN>);

$dsn="sysadm"; # name of the DSN we will be using

# find the available DSNs, creating $dsn if it doesn't exist already
die "Unable to query available DSN's".Win32::ODBC::Error()."\n" 
  unless (%dsnavail = Win32::ODBC::DataSources());
if (!defined $dsnavail{$dsn}) {
    die "unable to create DSN:".Win32::ODBC::Error()."\n"
      unless (Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, 
				  "SQL Server", 
				  ("DSN=$dsn", 
				   "DESCRIPTION=DSN for PerlSysAdm", 
				   "SERVER=mssql.happy.edu",
				   "DATABASE=master",
				   "NETWORK=DBMSSOCN", # TCP/IP Socket Lib
				  )));
}

# connect to the master database
$dbh = new Win32::ODBC("DSN=$dsn;UID=$user;PWD=$pw;");
die "Unable to connect to DSN $dsn:".Win32::ODBC::Error()."\n" 
  unless (defined $dbh);

# find the databases on the server
if (defined $dbh->Sql(q{SELECT name from sysdatabases})){
    die "Unable to query databases:".Win32::ODBC::Error()."\n";
}

while ($dbh->FetchRow()){
    push(@dbs, $dbh->Data("name"));
}
$dbh->DropCursor();

# find the user tables in each database
foreach $db (@dbs) {
    if (defined $dbh->Sql("use $db")){
	die "Unable to change to database $db:" . Win32::ODBC::Error() . "\n";
    }
    print "---$db---\n";
    @tables=();
    if (defined $dbh->Sql(q{SELECT name from sysobjects 
                            WHERE type="U"})){
	die "Unable to query tables in $db:" . Win32::ODBC::Error() . "\n";
    }
    while ($dbh->FetchRow()) {
	push(@tables,$dbh->Data("name"));
    } 
    $dbh->DropCursor();

    # find the column info for each table
    foreach $table (@tables) {
  	    print "\t$table\n";
  	    if (defined $dbh->Sql(" {call sp_columns (\'$table\')} ")){
	        die "Unable to query columns in 
                  $table:".Win32::ODBC::Error() . "\n";
	    }
	    while ($dbh->FetchRow()) {
	        @cols=();
	        @cols=$dbh->Data("COLUMN_NAME","TYPE_NAME","PRECISION");
	        print "\t\t",$cols[0]," [",$cols[1],"(",$cols[2],")]\n";
	    } 
	    $dbh->DropCursor();
	}
}
$dbh->Close();

die "Unable to delete DSN:".Win32::ODBC::Error()."\n"
    unless (Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN,
                                "SQL Server","DSN=$dsn"));

###################
### Example Spam ##
###################


Received: from isiteinc.com (www.isiteinc.com [206.136.243.2])
   by mailhost.example.com (8.8.6/8.8.6) with ESMTP id NAA14955
   for <webadmin@example.com>; Fri, 7 Aug 1998 13:55:41 -0400 (EDT)
From: responses@example.com
Received: from extreme (host-209-214-9-150.mia.bellsouth.net 
  [209.214.9.150])
  by isiteinc.com (8.8.3/8.8.3) with SMTP id KAA19050 for
    webadmin@example.com; Fri, 7 Aug 1998 10:48:09 -0700 (EDT)
Date: Fri, 7 Aug 1998 10:48:09 -0700 (EDT)
Received: from login_0246.whynot.net mx.whynot.net[206.212.231.88]) 
    by whynot.net (8.8.5/8.7.3) with SMTP id XAA06927 for 
    <webadmin@example.com>; Fri, 7 August 1998 13:48:11 -0700 (EDT)
To: <webadmin@example.com>
Subject: ***ADVERTISE VACATION RENTALS - $25/year*** - http://www.example.com
Reply-To: sample@whynot.net
X-PMFLAGS: 10322341.10
X-UIDL: 10293287_192832.222
Comments: Authenticated Sender is <user122@whynot.net>
Message-Id: <77126959_36550609>


We are proud to announce the all new http://www.example.com website
brought to you by Extreme Technologies, Inc.

Our exciting new travel resource contains some of the most visually
appealing vacation listings available on the WWW.  Within our site you
will find information on properties for rent, properties for sale,
international properties, bed & breakfast and Inns presented in a
highly efficient, and easily navigable fashion.  Our listings come
complete with color photos, animated graphics, concise descriptions,
and information on how to contact the renter/seller directly.  Plus,
we change our site graphics every month!

######################
## Example Analysis ##
######################

login_0246.whynot.net   mx.whynot.net           206.212.231.88   L
extreme                 host-209-214-9-150.mia  209.214.9.150    DB
isiteinc.com            www.isiteinc.com        206.136.243.2    OB

WHOIS info for 206.212.231.88:

WHOIS info for 209.214.9.150:
BellSouth.net Inc. (NETBLK-BELLSNET-BLK4)
   1100 Ashwood Parkway
   Atlanta, GA 30338

   Netname: BELLSNET-BLK4
   Netblock: 209.214.0.0 - 209.215.255.255
   Maintainer: BELL

   Coordinator:…

WHOIS info for 206.136.243.2:
Brainsell Incorporated (NET-ISITEINC)
   4105-R Laguna St.
   Coral Gables, FL 33146
   US

   Netname: ISITEINC
   Netnumber: 206.136.243.0

   Coordinator:...

################################
## Spam Analysis Example Code ##
################################

#*
#* examine a piece of spam/UCE and tell us information about it
#*

use Mail::Header;
use Socket; 
use BerkeleyDB;
use Net::Telnet;

$header = new Mail::Header \*STDIN;

$header ->unfold('Received');
@received = $header->get('Received');

$rbldomain  = ".rbl.maps.vix.com";
$orbsdomain = ".relays.orbs.org";
$duldomain  = ".dul.maps.vix.com";
$blacklist  = "/etc/mail/blacklist.db";
$whoishost  = "whois.geektools.com";

&loadblist;

for (reverse @received){
    chomp;

    parseline($_);
    if (!defined $ehelo and !defined $validname and !defined $validip){
       print "$_\n";
    }
    else {
     $flags  = (&checkaddr($validip,$rbldomain)  ? "R" : ""); # in RBL?
     $flags .= (&checkaddr($validip,$orbsdomain) ? "O" : ""); # in ORBS?
     $flags .= (&checkaddr($validip,$duldomain)  ? "D" : ""); # in DUL?
     $flags .= (&checkblist($_)              ? "B" : ""); # in our list?
     $flags .= (&checkrev($validip,$validname) ? "L" : ""); # rev-lookup?
      push(@iplist,$validip);
	
      write;
    }
}

for (@iplist){
    print "\nWHOIS info for $_:\n";
    print &getwhois($_);
}

format STDOUT =
@<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<< @<<<<
$ehelo,$validname,$validip,$flags
.

# take apart a HELO line
sub parseline {
    my $line = $_;

    # "normal" -- from HELO (REAL [IP])
    if (/from\s+(\w\S+)\s*\((\S+)\s*\[(\d+\.\d+\.\d+\.\d+)/){
	($ehelo,$validname,$validip) = ($1,$2, $3);
    }
    # can't reverse resolve -- from HELO ([IP])
    elsif (/from\s+(\w\S+)\s+\(\[(\d+\.\d+\.\d+\.\d+)\]/){
	($ehelo,$validname,$validip) = ($1,undef, $2);
    }	
    # exim -- from [IP] (helo=[HELO IP])
   elsif (/from\s+\[(\d+\.\d+\.\d+\.\d+)\]\s+\(helo=\[(\d+\.\d+\.\d+\.\d+)\]/){
	($validip,$ehelo,$validname) = ($1,$2, undef);
    }	
    # Sun Internet Mail Server -- from [IP] by HELO
    elsif (/from\s+\[(\d+\.\d+\.\d+\.\d+)\]\s+by\s+(\S+)/){
	($validip,$ehelo,$validname) = ($1,$2, undef);
    }	
    # Microsoft SMTPSVC -- from HELO - (IP)
    elsif (/from\s+(\S+)\s+-\s+(\d+\.\d+\.\d+\.\d+)\s+/){
	($ehelo,$validname,$validip) = ($1,$2, $3);
    }
    else { # punt!
	$ehelo = $validname = $validip = undef;
    }

    return [$ehelo,$validname,$validip];
}

# load local black list into compiled regular expressions
sub loadblist{
    tie %blist, 'BerkeleyDB::Hash', -Filename  => $blacklist
      or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

    while(my($key,$value) = each %blist){
        # the blacklist can also say "OK", "RELAY", and etc. 
        next if ($value ne "REJECT"); 
        push(@blisttests,[qr/\Q$key/,$key]);
    }    
}

# check local blacklist
sub checkblist{
    my($line) = shift;

    foreach my $test (@blisttests){
        my($re,$key) = @{$test};
        return $key if ($line =~ /$re/);
    }
    return undef;
}

## see if forward lookup of address matches
sub checkaddr{
    my($ip,$domain) = @_;

    return undef unless (defined $ip);

    my $lookupip = join('.',reverse split(/\./,$ip));
    
    if (gethostbyname($lookupip.$domain)){
        return $ip;
    }
    else {
        return undef;
    }
}

## check to see if reverse lookup of IP address matches
sub checkrev{
    my($ip,$name) = @_;

    return 0 unless ($ip and $name);

    my $namelook = gethostbyaddr(inet_aton($ip),AF_INET);
    my $iplook   = gethostbyname($name);

    $iplook = inet_ntoa($iplook) if $iplook;
    
    # may be recorded with different capitilization
    if ($iplook eq $ip and lc $namelook eq lc $name){
        return 0;
    }
    else {
        return 1;
    }
}

#*
#* retrieve WHOIS information about a particular IP address
#*
sub getwhois{
    my($ip) = shift;
    my($info);

    $cn = new Net::Telnet(Host => $whoishost,
                          Port => 'whois',
                          Errmode => "return",
                          Timeout => 30)
      or die "Unable to set up $whoishost connection:$!\n";

    unless ($cn->print($ip."\n")){
        $cn->close;
        die "Unable to send $ip to $whoishost: ".$cn->errmsg."\n";
    }

    while ($ret = $cn->get){
        $info .=$ret;
    };

    $cn->close;

    return $info;
}

######################
## Net::DNS 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;
    }
}

#####################################
## LDAP entry modification example ##
#####################################

use Net::LDAP;

$server   = $ARGV[0];
$port     = getservbyname("ldap","tcp") || "389";
$basedn   = "dc=ccs,dc=hogwarts,dc=edu";
$scope    = "sub";
$rootdn   = "cn=Manager, ou=Systems, dc=ccs, dc=hogwarts, dc=edu";
$pw       = "secret";

$c = new Net::LDAP($server,port => $port) or
  die "Unable to init for $server: $@\n";
$c->bind(dn => $rootdn, password => $pw) or die "Error in bind: $@\n";

$searchobj = $c->search(base  => $basedn, filter => "(l=Boston)",
                        scope => $scope,  attrs  => [''], 
                        typesonly => 1);
die "Error in search: ".$searchobj->error()."\n" if ($searchobj->code());

if ($searchobj){
    @entries = $searchobj->entries;
    for (@entries){
        $res=$c->modify($_->dn(), # dn() yields the DN of that entry
                        delete => {"l" => "Boston"},
                        add    => {"l" => "Indiana"});
        die "unable to modify, errorcode #".$res->code() if $res->code();
    }
}

$c->unbind();

##############################
### ADSI in action examples ##
##############################

#*
#* display the list of users in a domain using ADSI
#*

use Win32::OLE 'in';

$AdsPath = "WinNT://DomainName/PDCName,computer";

$c = Win32::OLE->GetObject($ADsPath) or die "Unable to get $ADsPath\n";

foreach $adsobj (in $c){
    print $adsobj->{Name},"\n" if ($adsobj->{Class} eq "User");
}
-------
#*
#* create a local user and set her/his Full Name using ADSI (LDAP namespace)
#*

use Win32::OLE;

$AdsPath = "LDAP://ldapserver,CN=Users,dc=example,dc=com";

$c = Win32::OLE->GetObject($ADsPath) or die "Unable to get $ADsPath\n";

# create and return a User object
$u=$c->Create("user","cn=".$commonname);
$u->{samAccountName} = $username;
# we have to create the user in the dir before we modify it
$u->SetInfo();

# space between "Full" and "Name" required with LDAP: namespace, sigh
$u->{'Full Name'} = $fullname; 
$u->SetInfo();
-------
#*
#* show printer queue status using ADSI
#*

use Win32::OLE 'in';

# this table comes from this section in the ADSI 2.5 SDK:
# 'Active Directory Service Interfaces 2.5->ADSI Reference->
# ADSI Interfaces->Dynamic Object Interfaces->IADsPrintQueueOperations->
# IADsPrintQueueOperations Property Methods' (phew)

%status = 
  (0x00000001 => 'PAUSED',            0x00000002 => 'PENDING_DELETION',
   0x00000003 => 'ERROR' ,            0x00000004 => 'PAPER_JAM',
   0x00000005 => 'PAPER_OUT',         0x00000006 => 'MANUAL_FEED',
   0x00000007 => 'PAPER_PROBLEM',     0x00000008 => 'OFFLINE',
   0x00000100 => 'IO_ACTIVE',         0x00000200 => 'BUSY',
   0x00000400 => 'PRINTING',          0x00000800 => 'OUTPUT_BIN_FULL',
   0x00001000 => 'NOT_AVAILABLE',     0x00002000 => 'WAITING',
   0x00004000 => 'PROCESSING',        0x00008000 => 'INITIALIZING',
   0x00010000 => 'WARMING_UP',        0x00020000 => 'TONER_LOW',
   0x00040000 => 'NO_TONER',          0x00080000 => 'PAGE_PUNT',
   0x00100000 => 'USER_INTERVENTION', 0x00200000 => 'OUT_OF_MEMORY',
   0x00400000 => 'DOOR_OPEN',         0x00800000 => 'SERVER_UNKNOWN',
   0x01000000 => 'POWER_SAVE');

$ADsPath = "WinNT://PrintServerName/PrintQueueName";

$p = Win32::OLE->GetObject($ADsPath) or die "Unable to get $ADsPath\n";

print "The printer status for " . $c->{Name} . " is " .
   ((exists $p->{status}) ? $status{$c->{status}} : "NOT ACTIVE") . "\n";
-------
#*
#* show the jobs in a particular print queue using ADSI
#*

use Win32::OLE 'in';

# this table comes from this section in the ADSI 2.5 SDK:
# 'Active Directory Service Interfaces 2.5->ADSI Reference->
# ADSI Interfaces->Dynamic Object Interfaces->IADsPrintJobOperations->
# IADsPrintJobOperations Property Methods' (double phew)

%status = (0x00000001 => 'PAUSED',  0x00000002 => 'ERROR',
           0x00000004 => 'DELETING',0x00000010 => 'PRINTING',
           0x00000020 => 'OFFLINE', 0x00000040 => 'PAPEROUT',
           0x00000080 => 'PRINTED', 0x00000100 => 'DELETED');

$ADsPath = "WinNT://PrintServerName/PrintQueueName";

$p = Win32::OLE->GetObject($ADsPath) or die "Unable to get $ADsPath\n";

$jobs = $p->PrintJobs();
foreach $job (in $jobs){
    print $job->{User} . "\t" . $job->{Description} . "\t" . 
      $status{$job->{status}} . "\n";
}

#######################
## Example MIB Entry ##
#######################

sysUpTime OBJECT-TYPE
              SYNTAX  TimeTicks
              ACCESS  read-only
              STATUS  mandatory
              DESCRIPTION
                      "The time (in hundredths of a second) since the
                      network management portion of the system was last
                      re-initialized."
              ::= { system 3 }