# Source Code Examples for 
# "S12: Perl for System Administration: The Networking Power Hours, Part 2"
# LISA2002 Tutorial
# David N. Blank-Edelman
# November 3, 2002

# 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: ©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 (except where noted) is ©2002 Northeastern University and
# David N. Blank-Edelman. All Rights Reserved.

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP Syntax OID

1.3.6.1.4.1.1466.115.121.1.26 - IA5 String syntax
Submitted by j.onions@nexor.co.uk from host 128.243.9.53 (128.243.9.53) on Tue Sep 22 16:04:29 MET DST 1998 using a WWW entry form. 
OID value: 1.3.6.1.4.1.1466.115.121.1.26 
OID description:
The encoding of a value in this syntax is the string value itself. 
( 1.3.6.1.4.1.1466.115.121.1.26 DESC 'IA5 String' )
URL for further info: http://src.doc.ic.ac.uk/computing/internet/rfc/rfc2252.txt 
Superior references
"	1.3.6.1.4.1.1466 - Mark Wahl (Critical Angle) 
"	1.3.6.1.4.1 - IANA-registered Private Enterprises 
"	1.3.6.1.4 - Internet Private 
"	1.3.6.1 - OID assignments from 1.3.6.1 - Internet 
"	1.3.6 - US Department of Defense 
"	1.3 - ISO Identified Organization 
"	1 - ISO assigned OIDs 
"	Top of OID tree 

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP Bind Example
use Net::LDAP;
$c = Net::LDAP->new($server,port => $port, 
                                         version => 3) or  
die "Unable to connect to $server: $@\n";
# use no parameters to bind() for anonymous bind
$c->bind($binddn, password => $passwd) or die "Unable to bind: $@\n"; 

$c->unbind();

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP Bind w/SASL Example
use Authen::SASL;
use Net::LDAP;

$as = Authen::SASL->new('CRAM-MD5', password => 'supersecret');
$c = Net::LDAP->new($server,port => $port, 
                                         version => 3) or  
    die "Unable to connect to $server: $@\n";

$c->bind($binddn, sasl=> $as) or die "Unable to bind: $@\n"; 
...
$c->unbind();

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP Search Example

use Net::LDAP;
# bind here...
$searchobj = $c->search(base   => $basedn, 
			    	scope  => $scope, 
                        filter => $filter); 
die "Bad search:" . $searchobj->error() 
if $searchobj->code();

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--= LDAP Reference and Referral Example

use Net::LDAP::Constant qw(LDAP_REFERRAL);
use URI;
# bind and search here...
my @referrals = $searchobj->referrals
  if ($searchobj->code() == LDAP_REFERRAL);
my @references = $search obj->references;
foreach my $refrl (@referrals){
   my $uri = URI->new($refrl);
   my $dn = $uri -> dn; # ->filter, ->scope, ...
  # go forth and do something with this...
}

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP Compare Example
use Net::LDAP; 
use Net::LDAP::Constant qw(LDAP_COMPARE_TRUE);

# bind here...
my $result = $c->compare($dn,attr  =>'userPassword',value => $passwd);
die "bad pwd" if ($result->code() != LDAP_COMPARE_TRUE);
LDAP "Bare Metal" Add Example
use Net::LDAP;

# bind here...

$res = $c->add(
        dn => 'uid=jay, ou=systems, ou=people, dc=ccs, dc=hogwarts, dc=edu',
        attr => [ 'cn'   => 'Jay Sekora', 
                  'sn    => 'Sekora',
                  'mail' => 'jayguy@ccs.hogwarts.edu',
                  'title'=> ['Sysadmin','Lecturer'],
                  'uid'  => 'jayguy',
                 ]);
die "add error:" . $res->error() if $res->code();

LDAP OOP Add Example
use Net::LDAP;
use Net::LDAP::Entry

# bind here...

my $entry = Net::LDAP::Entry->new();
$entry->dn('uid=jay, ou=systems, ou=people, dc=ccs,dc=hogwarts, dc=edu');
$entry->add('cn'=> 'Jay Sekora','sn' => 'Sekora',
            'mail' => 'jayguy@ccs.hogwarts.edu',
            'title'=> ['Sysadmin','Lecturer'],
            'uid'  => 'jayguy');
$res = $c->update($entry);
die "add error:" . $res->error() if $res->code();

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP Entry Modification Example
$searchobj = $c->search(base  => $basedn, filter => "(l=Boston)",
                        scope => 'sub', attrs  => [''], typesonly => 1);
die "Bad search:" . $searchobj->error() 
if $searchobj->code();

if ($searchobj){
    @entries = $searchobj->entries;
    for (@entries){
        $res = $c->modify($_->dn(), delete => {"l" => "Boston"},
                      		      add    => {"l" => "Indiana"});
        warn "Bad modify:".$res->error() if $res->code();
    }
}

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= LDAP DSML Example
use Net::LDAP::DSML;

open(FH, ">filename") or die $!;

$dsmlobj = Net::LDAP::DSML->new (output => *FH, pretty_print => 1);

$dsmlobj->start_dsml; # not documented yet
$dsmlobj->write_entry(@entryobjs); 
$dsmlobj->end_dsml;   # not documented yet
close(FH);
LDAP Control  Example
# from Net::LDAP::Control::Sort manual page
use Net::LDAP::Control::Sort; 
use Net::LDAP::Constant qw(LDAP_CONTROL_SORTRESULT); 

$sort = Net::LDAP::Control::Sort->new(order => "cn -phone" ); 

$mesg = $ldap->search( @args, control => [ $sort ]); 

($resp) = $mesg->control( LDAP_CONTROL_SORTRESULT ); 
print "Results are sorted\n" if $resp and !$resp->result;

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= SMTP Transcript from RFC2821
S: 220 foo.com Simple Mail Transfer Service Ready
C: EHLO bar.com
S: 250-foo.com greets bar.com
S: 250-8BITMIME
S: 250-SIZE
S: 250-DSN
S: 250 HELP
C: MAIL FROM:<Smith@bar.com>
S: 250 OK
C: RCPT TO:<Jones@foo.com>
S: 250 OK
C: RCPT TO:<Green@foo.com>
S: 550 No such user here
C: RCPT TO:<Brown@foo.com>

S: 250 OK
C: DATA
S: 354 Start mail input; end with <CRLF>.<CRLF>
C: Blah blah blah...
C: ...etc. etc. etc.
C: .
S: 250 OK
C: QUIT
S: 221 foo.com Service closing transmission channel

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Raw SMTP Example
use Net::Telnet;

$c = new Net::Telnet(Telnetmode => 0, Dump_log => *STDERR);

$c->open(Host => 'mail.example.com', Port => 25);
$receive = $c->getline;
die "Didn't get hailing frequency" if ($receive !~ /^220/);

$c->print('HELO testhost.example.com');

$c->print('MAIL FROM:<dnb@example.com>');
$c->print('RCPT TO:<davidboring@clowes.com>'); 

$c->print('DATA');

$c->print('From: <dnb@example.com>');
$c->print('To: <davidboring@clowes.com>');
$c->print('Subject: test message');$c->print('');
$c->print('Just a test');

$c->print('.');

$c->print('QUIT');

Net::SMTP Example
use Net::SMTP;

$c = Net::SMTP->new('mail.example.com');

$c->mail('dnb@example.com');
$c->to('davidboring\@clowes.com');

$c->data("From: <dnb\@example.com>\n",
		   "To: <davidboring\@clowes.com>\n","\n",
	 	   "Just a test\n");

$c->quit();

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

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= POP3 Transcript from RFC1939
S: <wait for connection on TCP port 110>
C: <open connection>
S:    +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>
C:    APOP mrose c4c9334bac560ecc979e58001b3e22fb
S:    +OK mrose's maildrop has 2 messages (320 octets)
C:    STAT
S:    +OK 2 320
C:    LIST
S:    +OK 2 messages (320 octets)
S:    1 120
S:    2 200
S:    .
C:    RETR 1
S:    +OK 120 octets
S:    <the POP3 server sends message 1>
S:    .
C:    DELE 1
S:    +OK message 1 deleted
C:    RETR 2
S:    +OK 200 octets
S:    <the POP3 server sends message 2>
S:    .
C:    DELE 2
S:    +OK message 2 deleted
C:    QUIT
S:    +OK dewey POP3 server signing off (maildrop empty)
C:  <close connection>
S:  <wait for next connection>

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Net::POP3 Example
use Net::POP3;

my $np3 = Net::POP3->new('pop.example.com');
die "unable to login\n" unless
  my $numess = $np3->login("dnb","highlysecure");
for (my $i=1; $i<=$numess; $i++){
    print "Message #$i, size:".$np3->list($i).", headers:\n";
    print @{$np3->top($i)};
    print "-"x25,"\n";
}	
$np3->quit();

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= IMAPv4rev1  Transcript from RFC2060
S:   * OK IMAP4rev1 Service Ready
C:   a001 login mrc secret
S:   a001 OK LOGIN completed
C:   a002 select inbox
S:   * 18 EXISTS
S:   * FLAGS (\Answered \Flagged \Deleted \Seen \Draft)
S:   * 2 RECENT
S:   * OK [UNSEEN 17] Message 17 is the first unseen message
S:   * OK [UIDVALIDITY 3857529045] UIDs valid

S:   a002 OK [READ-WRITE] SELECT completed
C:   a003 fetch 12 full
S:   * 12 FETCH (FLAGS (\Seen) INTERNALDATE "17-Jul-1996 02:44:25 -0700"
      RFC822.SIZE 4286 ENVELOPE ("Wed, 17 Jul 1996 02:23:25 -0700 (PDT)"
      "IMAP4rev1 WG mtg summary and minutes"
      (("Terry Gray" NIL "gray" "cac.washington.edu"))
      (("Terry Gray" NIL "gray" "cac.washington.edu"))
      (("Terry Gray" NIL "gray" "cac.washington.edu"))
      ((NIL NIL "imap" "cac.washington.edu"))
      ((NIL NIL "minutes" "CNRI.Reston.VA.US")
      ("John Klensin" NIL "KLENSIN" "INFOODS.MIT.EDU")) NIL NIL
      "<B27397-0100000@cac.washington.edu>")
       BODY ("TEXT" "PLAIN" ("CHARSET" "US-ASCII") NIL NIL "7BIT" 3028 92))
S:    a003 OK FETCH completed
C:    a004 fetch 12 body[header]
S:    * 12 FETCH (BODY[HEADER] {350}
S:    Date: Wed, 17 Jul 1996 02:23:25 -0700 (PDT)
S:    From: Terry Gray <gray@cac.washington.edu>
S:    Subject: IMAP4rev1 WG mtg summary and minutes
S:    To: imap@cac.washington.edu
S:    cc: minutes@CNRI.Reston.VA.US, John Klensin <KLENSIN@INFOODS.MIT.EDU>
S:    Message-Id: <B27397-0100000@cac.washington.edu>
S:    MIME-Version: 1.0
S:    Content-Type: TEXT/PLAIN; CHARSET=US-ASCII
S:
S:    )
S:    a004 OK FETCH completed
C:    a005 store 12 +flags \deleted
S:    * 12 FETCH (FLAGS (\Seen \Deleted))
S:    a005 OK +FLAGS completed
C:    a006 logout
S:    * BYE IMAP4rev1 server terminating connection
S:    a006 OK LOGOUT completed

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Mail::IMAPClient with SSL Example
use IO::Socket::SSL;
use Mail::IMAPClient;

my $s = IO::Socket::SSL->new(PeerAddr=>'imap.example.com',
			  	        PeerPort => '993',
			  	        Proto => 'tcp');
die $@ unless defined $s;

my $m = Mail::IMAPClient->new(User => 'dnb', Socket=>$s,
 				         Password => 'topsecret');
$m->State($m->Connected());
$m->login or die $@;
$m->select('INBOX');

my @spammsgs = $m->search(qw(HEADER X-Spam-Flag YES)); 
die $@ if $@;

foreach my $msg (@spammsgs){
  my $headers = $m->parse_headers($msg,"From","Subject");
  print "Moving \tFrom: ", $headers->{From}->[0],"\n",
         "\tSubject: ",$headers->{Subject}->[0],"\n\n";
  die $m->LastError unless defined $m->move('SPAM',$msg);
}
$m->close(); # expunges currently selected folder
$m->logout;

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Mail::IMAPClient Additional Example
use IO::Socket::SSL;
use Mail::IMAPClient;

my $s = IO::Socket::SSL->new(PeerAddr=>'imap.example.com',
			  	        PeerPort => '993',
			  	        Proto => 'tcp');
die $@ unless defined $s;

my $m = Mail::IMAPClient->new(User => 'dnb', Socket=>$s,
 				         Password => 'topsecret');
$m->State($m->Connected());
$m->login or die $@;
$m->select('INBOX');

my @digests = $m->search(qw(SUBJECT digest));

foreach my $msg (@digests) {

  my $struct = $m->get_bodystructure($msg);
  next unless defined $struct;

  print "Message #$msg (Content-type: ",$struct->bodytype,"/",
    $struct->bodysubtype,
		                          ") contains these parts:\n\t",
		                            join("\n\t",$struct->parts) ,"\n\n";
}

$m->logout;

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=  Mail::Audit Example
use Mail::Audit;
use Astro::MoonPhase;
my $ma = Mail::Audit->new(emergency=>'file');

if ($ma->from =~ "wierdewolf" and (localtime)[2] == 0 and phase() == 1)){
		  $ma->resend('exorcist@example.com');
}
$ma->accept;

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Distilling Email Example

# parse netapp autosupport mail and show it to us nicely

use Text::Wrap;

while (<>){
    last if (index($_,"===== MESSAGES =====") > -1);
}    

while($_ = <>){
    next if /\[statd\]/;
    next if (index($_,"last message repeated") > -1); 
    next if (index($_,"../common/ndmpd/comm.c") > -1);

    if (/uid\s(\d+).*exceeded on volume (.*)/){
         $user = ((exists $users{$1}) ? 
                          $users{$1} : $users{$1}=getpwuid($1));
         $volume = $2;
         
         $quotabloat{$user} = $volume 
           if (!exists $quotabloat{$user});
         next;
    }              

    if (/tree quota exceeded on volume (.*)/){
         $treebloat{$1}++ if (! exists $treebloat{$1});
         next;
    }              
    
    push (@unknown,$_);
   
}
        
close(<LOG>);

print "\n==== Quota exceeded ====\n";
print wrap("","",join (" ",sort keys %quotabloat)),"\n";
print "\n==== Tree quota exceeded ====\n";
print wrap("","",join (" ",keys %treebloat)),"\n";
print "\n==== Unknown messages ====\n";
print @unknown;

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Round-trip Mail Testing Example
use IO::Socket::SSL;
use Mail::IMAPClient;
use Mail::Mailer;
use Date::Parse;

# pick your flavor: mail,sendmail,smtp,qmail
$mm = new Mail::Mailer "smtp",Server=>'localhost';

$mm->open({From     => '<dnb@example.com>',
                  To        =>'<dnb@example.com>',
                  Subject => 'MAILTEST: '.time});

print $mm "test msg\n";

$mm->close();

sleep 30;

my $s = IO::Socket::SSL->new(PeerAddr => 'imap.example.com',
   		 	           PeerPort => '993',
			           Proto => 'tcp');
die $@ unless defined ($s);

my $m = Mail::IMAPClient->new(User   => 'dnb', Password => $ARGV[0],
			            Socket=>$s);
$m->State($m->Connected());
$m->login  or die $@;

$m->select('INBOX');

my @mailtests = $m->search(qw(SUBJECT MAILTEST));
my $headers = $m->parse_headers($mailtests[0],"Date","Subject");
my ($senttime) = $headers->{Subject}->[0] =~ /(\d+)/;
my $rectime     = str2time($headers->{Date}->[0]);

$m->delete_message($mailtests[0]);
$m->close;
$m->logout;

print "Roundtrip delay: ",$rectime - $senttime," seconds\n";

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 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? 
    $whatline = ++$whatline % $buffsize;

    # 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 = 0; # 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 {
       # print only valid lines in case buffer was not full
       print DUMPFILE $buffer[$line] if defined $buffer[$line];
       $line = ++$line % $buffsize;
    } until $line == $whatline;

    close(DUMPFILE);

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

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

#=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Net::Server Example
# from the docs

package MyPackage;

use strict;
use vars qw(@ISA);
use Net::Server::PreFork; # any personality will do

@ISA = qw(Net::Server::PreFork);

MyPackage->run();
exit;

# over-ridden subs below
sub process_request {
  my $self = shift;
  eval {
    local $SIG{ALRM} = sub { die "Timed Out!\n" };
    my $timeout = 30; # give the user 30 seconds to type a line

    my $previous_alarm = alarm($timeout);
    while( <STDIN> ){
       s/\r?\n$//;
       print "You said \"$_\"\r\n";
       alarm($timeout);
     }
     alarm($previous_alarm);

    };

  if( $@=~/timed out/i ){
    print STDOUT "Timed Out.\r\n";
    return;
  }

}