#!/usr/bin/perl # # DHCP Reporting, Revision 2.1 # # Copyright (C) 1997-2002 John G. Drummond (omar@omar.org) # http://www.omar.org/opensource/ # # Feel free to email me with comments, criticisms, or questions. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # This program uses Stephen Brenner's cgi-lib.pl, included at the end # of the file for compactness. See the copyright statement preceding # the cgi-lib.pl code. # ################################################################# ###--------------------------OPTIONS--------------------------### # Change to your dhcp file and dhcpd.conf: # (Currently set to ISC DHCP defaults) my $dhcpfile = "/var/lib/dhcp3/dhcpd.leases"; my $dhcpdconf = "/etc/dhcp3/dhcpd.conf"; # change to the relative (web) path to the cgi directory where # reportdhcp.pl is located (usually /cgi-bin): my $CGI = "/cgi-bin"; # change to reflect your system name my $sysname = "Library"; ###----------------------End of Options-----------------------### ################################################################# # MAIN PROGRAM # ReadParse(*values); #contained in cgi-lib.pl, at the bottom. print "Content-type: text/html\n\n"; print "\n\n"; print "reportdhcp.pl - DHCP Reporting\n"; &ParseConfig(); &ParseLeaseFile(); #perform the requested action... if ($values{"sort"} eq "ipsort") {&sortip;} elsif ($values{"sort"} eq "namesort") {&sortname;} elsif ($values{"sort"} eq "agesort") {&sortdate;} elsif ($values{"dostats"} || $ARGV[0] eq "test") {&stats;} elsif ($values{"findip"}) {&findip;} elsif ($values{"findmac"}) {&findmac;} elsif ($values{"findname"}) {&findname;} else {&dohtml;} #default action, even if input is bogus print ""; exit 0; # END MAIN PROGRAM # # Sorts entries by the client-hostname field sub sortname { my %names; $counter=0; foreach $ip (@ips) { $name = $lease{$ip}{"client-hostname"}; $names{$name.$counter}=$ip; #counter keeps identical names from clobbering $counter++; } my @sorted = sort(keys(%names)); print "

$sysname

\n"; print "

Entries in dhcpd.leases sorted by name

\n"; &PrintEntries(\@sorted, \%names); } # Sorts entries by lease start date sub sortdate { my %ages; foreach $ip (@ips) { $age = $lease{$ip}{"starts"}; @age1 = split(/ /, $age); @date = split (/\//, $age1[1]); @hour = split (/:/, $age1[2]); $age = $date[0].$date[1].$date[2].$hour[0].$hour[1].$hour[2]; $ages{$age}=$ip; } @sorted = sort(keys(%ages)); print "

$sysname

\n"; print "

Entries in dhcpd.leases sorted by age

\n"; &PrintEntries(\@sorted, \%ages); } #Sorts entries by IP address (Actually, they're already sorted. Sorta. ;) ) sub sortip { print "

$sysname

\n"; print "

Entries in dhcpd.leases sorted by IP address

\n"; &PrintEntries(\@ips) } #Finds entry for a given IP address. sub findip { $ip = $values{"findip"}; chomp($ip); print "

$sysname

\n"; print ""; print ""; print ""; print "
IPMACNameStartsEnds
$ip".$lease{$ip}{"hardware"}; print " ".$lease{$ip}{"client-hostname"}.""; &parsedate($lease{$ip}{"starts"}); print ""; &parsedate($lease{$ip}{"ends"}); print "
"; print "
Back
"; } #Finds entry for a given MAC address (hardware id in leases file) sub findmac { $mac = $values{"findmac"}; print "

$sysname

\n"; print ""; print ""; foreach $ip (@ips) { if ($lease{$ip}{"hardware"} =~ /$mac/) { print ""; print ""; } } print "
IPMACNameStartsEnds
$ip".$lease{$ip}{"hardware"}; print " ".$lease{$ip}{"client-hostname"}."".$lease{$ip}{"starts"}.""; print $lease{$ip}{"ends"}."
Back
"; } #Finds an entry based on a given name (client-hostname in leases file) sub findname { $name = $values{"findname"}; print "

$sysname

\n"; print ""; print ""; foreach $ip (@ips) { if ($lease{$ip}{"client-hostname"} =~ /$name/) { print ""; print ""; } } print "
IPMACNameStartsEnds
$ip".$lease{$ip}{"hardware"}; print " ".$lease{$ip}{"client-hostname"}."".$lease{$ip}{"starts"}.""; print $lease{$ip}{"ends"}."
Back
"; } #Prints general statistics table sub stats { print "

$sysname

\n"; print "

General Statistics

\n"; print ""; print "\n"; print "\n"; print "\n"; print "\n"; print ""; print "\n"; foreach $net (@networks) { my $count=0; my $abcount=0; my $expcount=0; my $wtf=0; foreach $entry (@ips) { if (&isinrange ($range{$net}, $entry) eq "true") { if (!$lease{$entry}{"hardware"}) { $abcount++; } elsif ($lease{$entry}{"binding"} eq "free") { $expcount++; } elsif ($lease{$entry}{"binding"} eq "active") { $count++; } else { $wtf++; #Used for debugging only } } } print ""; print "\n"; } print "
Total Leases in file:$entries
Abandoned Leases:"; my $abcount = 0; my $expcount = 0; my $ip=""; foreach $ip (@ips) { if (!$lease{$ip}{"hardware"}) { $abcount++; } elsif ($lease{$ip}{"binding"} eq "free") { $expcount++; } } print "$abcount
Expired Leases:"; print "$expcount
Usage by Network
NetworkNetmaskActiveAbandonedExpired
$net$nets{$net}$count$abcount$expcount
\nBack\n"; } #Parses lease file date into a more easily readable format sub parsedate { @date = split(/ /, $_[0]); %months = ("01", "January", "02", "February", "03", "March", "04", "April", "05", "May", "06", "June", "07", "July", "08", "August", "09", "September", "10", "October", "11", "November", "12", "December"); %days = ("0", "Sunday", "1", "Monday", "2", "Tuesday", "3", "Wednesday", "4", "Thursday", "5", "Friday", "6", "Saturday"); $date[0] = $days{$date[0]}. ", "; @day = split (/\//, $date[1]); $date[1] = $months{$day[1]} . " $day[2], $day[0] "; print @date, " GMT"; } #Checks to see if a given address is in a given range, by octet. #Probably inefficient as hell. sub isinrange ($$) { my ($rangestr, $ip) = @_; local @success; @ranges = split (/:/, $rangestr); local @ip = split (/\./, $ip); foreach $range (@ranges) { local @bounds = split(/-/, $range); @lower=split(/\./, $bounds[0]); @upper=split(/\./, $bounds[1]); for ($i=0; $i<4; $i++) { if (($ip[$i] >= $lower[$i]) && ($ip[$i] <= $upper[$i])) { $success[$i] = 1; } else { $success[$i] = 0; } } local $test = $success[0]+$success[1]+$success[2]+$success[3]; if ($test == 4) { return "true"; #success! } } return "false"; #failure! } #Reads and munges the dhcpd.conf file sub ParseConfig { unless(open (IN, $dhcpdconf)) { &CgiDie("Error: unable to open file $dhcpdconf: $!"); #CgiDie from cgi-lib.pl. exit -1; } my @info = ; close (IN) or &CgiDie ("Couldn't close $dhcpdconf: $!"); my $line; my @parts; my $i = 0; my $dlt; #not doing anything with dlt yet! our %range; while ($line=$info[$i]) { # parse the dhcpd.conf file if ($line =~ m/^#/) { # ignore commented lines $i++; next; } if ($line =~ m/default-lease-time/) { #found default lease time @parts= split(/\s/, $line); $dlt = $parts[1]; } if ($line =~ m/subnet/) { my @parts = split (/\s/, $line); my $j = 0; foreach $part(@parts) { if ($part eq "subnet") { $netwk = $parts[$j+1]; $mask = $parts[$j+3]; $nets{$netwk} = $mask; #save net and mask pairs in a hash } $j++; } } if ($line =~ m/range/) { # get address range my @parts = split (/\s/, $line); $j = 0; foreach $part(@parts) { if ($part eq "range") { # Potential list of ranges... chop ($parts[$j+2]); $range{$netwk} .= $parts[$j+1] . "-" . $parts[$j+2] . ":"; } $j++; } } $i++; } our @networks = sort(keys(%nets)); } #Prints out sorted tables for other routines sub PrintEntries { my ($sortref, $dataref) = @_; # have to pass as a referece my @sorted = @$sortref; # dereference for my sanity if ($dataref) { our %data = %$dataref; # " " } print "

Back to main

\n"; ## offer filter button print '
'; print "Filter: "; if ($values{"filteractive"}) { print " Active Leases Only\n"; } else { print " Active Leases Only\n"; } print "\n"; print '
'; ## Calculate current GMT my ($sec, $min, $hr, $mond, $mon, $year, $weekd, $yeard, $dls) = gmtime(time); $year += 1900; $mon++; if ($mon < 10) { $mon = "0" . $mon; } my $curgmt = "$weekd $year/$mon/$mond $hr:$min:$sec"; print "Current time is: "; &parsedate($curgmt); print "
\n"; print "\n\n"; print "\n"; foreach $entry (@sorted) { if ($dataref) { $ip = $data{$entry}; } else { $ip = $entry; } unless ($values{"filteractive"} && $lease{$ip}{"binding"} eq "free") { print "'; print "\n\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; } } print "
\ \;IPMACNameStatusStartsEnds
\n"; print '
'; print "\n"; print '
$ip".$lease{$ip}{"hardware"}." ".$lease{$ip}{"client-hostname"}."".$lease{$ip}{"binding"}.""; &parsedate($lease{$ip}{"starts"}); print ""; &parsedate($lease{$ip}{"ends"}); print "
\n

Back to main

\n"; print "\n"; } # Reads and munges the leases file generated by dhcpd sub ParseLeaseFile { our %lease; unless(open (IN, $dhcpfile)) { print "\nError: unable to open file $dhcpfile: $! \n"; exit -1; } my @leases = ; my $data = ""; foreach $line (@leases) { unless ($line =~ m/^#/) { # ignore commented lines $data .= $line; } } my @data = split (/lease /, $data); #split each lease into an array entry foreach (@data) { #create hash of hashes keyed on ip from the array my @temp = split(/{/, $_); chop($temp[0]); # 0 is IP chop($temp[1]); # 1 is the rest... chop($temp[1]); $temp[1] =~ tr/\t//d; @t = split(/;\n/, $temp[1]); #split each lease on newline my $i=0; while ($t[$i]) { my $string = $t[$i]; $string =~ tr/\n//d; $string =~ s/^\s*//; # remove any leading spaces @words = split(/\s+/, $string); #hashes keyed on first word if ($words[0]) { $key = shift(@words); $lease{$temp[0]}{$key}="@words"; $lease{$temp[0]}{"hardware"}=~ s/ethernet//; $lease{$temp[0]}{"binding"}=~ s/state //; } $i++; } } my @temp = sort(keys(%lease)); my $prev = ""; # checks for duplicates @ips=grep($_ ne $prev && (($prev) = $_), @temp); $entries = @ips; } #Prints the base page sub dohtml { print << "HTMLDONE";

DHCP Reporting!

v. 2.1 by John G. Drummond

$sysname

General Stats
DHCP lease file entries, sorted by IP
DHCP lease file entries, sorted by Age
DHCP lease file entries, sorted by Name

Find the entry for this IP address:
Find the entry for this MAC address:
Find the entry for this Client Name:
HTMLDONE } BEGIN { #Stephen Brenner's cgi-lib.pl is included below for compactness, #in its entirety for completeness. Copyright statement follows: #------- Begin cgi-lib.pl --------- # Perl Routines to Manipulate CGI input # cgi-lib@pobox.com # $Id: cgi-lib.pl,v 2.18 1999/02/23 08:16:43 brenner Exp $ # # Copyright (c) 1993-1999 Steven E. Brenner # Unpublished work. # Permission granted to use and modify this library so long as the # copyright above is maintained, modifications are documented, and # credit is given for any use of the library. # # Thanks are due to many people for reporting bugs and suggestions # For more information, see: # http://cgi-lib.stanford.edu/cgi-lib/ $cgi_lib'version = sprintf("%d.%02d", q$Revision: 2.18 $ =~ /(\d+)\.(\d+)/); # Parameters affecting cgi-lib behavior # User-configurable parameters affecting file upload. $cgi_lib'maxdata = 131072; # maximum bytes to accept via POST - 2^17 $cgi_lib'writefiles = 0; # directory to which to write files, or # 0 if files should not be written $cgi_lib'filepre = "cgi-lib"; # Prefix of file names, in directory above # Do not change the following parameters unless you have special reasons $cgi_lib'bufsize = 8192; # default buffer size when reading multipart $cgi_lib'maxbound = 100; # maximum boundary length to be encounterd $cgi_lib'headerout = 0; # indicates whether the header has been printed # ReadParse # Reads in GET or POST data, converts it to unescaped text, and puts # key/value pairs in %in, using "\0" to separate multiple selections # Returns >0 if there was input, 0 if there was no input # undef indicates some failure. # Now that cgi scripts can be put in the normal file space, it is useful # to combine both the form and the script in one place. If no parameters # are given (i.e., ReadParse returns FALSE), then a form could be output. # If a reference to a hash is given, then the data will be stored in that # hash, but the data from $in and @in will become inaccessable. # If a variable-glob (e.g., *cgi_input) is the first parameter to ReadParse, # information is stored there, rather than in $in, @in, and %in. # Second, third, and fourth parameters fill associative arrays analagous to # %in with data relevant to file uploads. # If no method is given, the script will process both command-line arguments # of the form: name=value and any text that is in $ENV{'QUERY_STRING'} # This is intended to aid debugging and may be changed in future releases sub ReadParse { # Disable warnings as this code deliberately uses local and environment # variables which are preset to undef (i.e., not explicitly initialized) local ($perlwarn); $perlwarn = $^W; $^W = 0; local (*in) = shift if @_; # CGI input local (*incfn, # Client's filename (may not be provided) *inct, # Client's content-type (may not be provided) *insfn) = @_; # Server's filename (for spooled files) local ($len, $type, $meth, $errflag, $cmdflag, $got, $name); binmode(STDIN); # we need these for DOS-based systems binmode(STDOUT); # and they shouldn't hurt anything else binmode(STDERR); # Get several useful env variables $type = $ENV{'CONTENT_TYPE'}; $len = $ENV{'CONTENT_LENGTH'}; $meth = $ENV{'REQUEST_METHOD'}; if ($len > $cgi_lib'maxdata) { #' &CgiDie("cgi-lib.pl: Request to receive too much data: $len bytes\n"); } if (!defined $meth || $meth eq '' || $meth eq 'GET' || $meth eq 'HEAD' || $type eq 'application/x-www-form-urlencoded') { local ($key, $val, $i); # Read in text if (!defined $meth || $meth eq '') { $in = $ENV{'QUERY_STRING'}; $cmdflag = 1; # also use command-line options } elsif($meth eq 'GET' || $meth eq 'HEAD') { $in = $ENV{'QUERY_STRING'}; } elsif ($meth eq 'POST') { if (($got = read(STDIN, $in, $len) != $len)) {$errflag="Short Read: wanted $len, got $got\n";}; } else { &CgiDie("cgi-lib.pl: Unknown request method: $meth\n"); } @in = split(/[&;]/,$in); push(@in, @ARGV) if $cmdflag; # add command-line parameters foreach $i (0 .. $#in) { # Convert plus to space $in[$i] =~ s/\+/ /g; # Split into key and value. ($key, $val) = split(/=/,$in[$i],2); # splits on the first =. # Convert %XX from hex numbers to alphanumeric $key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge; $val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge; # Associate key and value $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator $in{$key} .= $val; } } elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) { # for efficiency, compile multipart code only if needed $errflag = !(eval <<'END_MULTIPART'); local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype, $blen); local ($bpos, $lpos, $left, $amt, $fn, $ser); local ($bufsize, $maxbound, $writefiles) = ($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles); # The following lines exist solely to eliminate spurious warning messages $buf = ''; ($boundary) = $type =~ /boundary="([^"]+)"/; #"; # find boundary ($boundary) = $type =~ /boundary=(\S+)/ unless $boundary; &CgiDie ("Boundary not provided: probably a bug in your server") unless $boundary; $boundary = "--" . $boundary; $blen = length ($boundary); if ($ENV{'REQUEST_METHOD'} ne 'POST') { &CgiDie("Invalid request method for multipart/form-data: $meth\n"); } if ($writefiles) { local($me); stat ($writefiles); $writefiles = "/tmp" unless -d _ && -w _; # ($me) = $0 =~ m#([^/]*)$#; $writefiles .= "/$cgi_lib'filepre"; } # read in the data and split into parts: # put headers in @in and data in %in # General algorithm: # There are two dividers: the border and the '\r\n\r\n' between # header and body. Iterate between searching for these # Retain a buffer of size(bufsize+maxbound); the latter part is # to ensure that dividers don't get lost by wrapping between two bufs # Look for a divider in the current batch. If not found, then # save all of bufsize, move the maxbound extra buffer to the front of # the buffer, and read in a new bufsize bytes. If a divider is found, # save everything up to the divider. Then empty the buffer of everything # up to the end of the divider. Refill buffer to bufsize+maxbound # Note slightly odd organization. Code before BODY: really goes with # code following HEAD:, but is put first to 'pre-fill' buffers. BODY: # is placed before HEAD: because we first need to discard any 'preface,' # which would be analagous to a body without a preceeding head. $left = $len; PART: # find each part of the multi-part while reading data while (1) { die $@ if $errflag; $amt = ($left > $bufsize+$maxbound-length($buf) ? $bufsize+$maxbound-length($buf): $left); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; $in{$name} .= "\0" if defined $in{$name}; $in{$name} .= $fn if $fn; $name=~/([-\w]+)/; # This allows $insfn{$name} to be untainted if (defined $1) { $insfn{$1} .= "\0" if defined $insfn{$1}; $insfn{$1} .= $fn if $fn; } BODY: while (($bpos = index($buf, $boundary)) == -1) { if ($left == 0 && $buf eq '') { foreach $value (values %insfn) { unlink(split("\0",$value)); } &CgiDie("cgi-lib.pl: reached end of input while seeking boundary " . "of multipart. Format of CGI input is wrong.\n"); } die $@ if $errflag; if ($name) { # if no $name, then it's the prologue -- discard if ($fn) { print FILE substr($buf, 0, $bufsize); } else { $in{$name} .= substr($buf, 0, $bufsize); } } $buf = substr($buf, $bufsize); $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; } if (defined $name) { # if no $name, then it's the prologue -- discard if ($fn) { print FILE substr($buf, 0, $bpos-2); } else { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n } close (FILE); last PART if substr($buf, $bpos + $blen, 2) eq "--"; substr($buf, 0, $bpos+$blen+2) = ''; $amt = ($left > $bufsize+$maxbound-length($buf) ? $bufsize+$maxbound-length($buf) : $left); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; undef $head; undef $fn; HEAD: while (($lpos = index($buf, "\r\n\r\n")) == -1) { if ($left == 0 && $buf eq '') { foreach $value (values %insfn) { unlink(split("\0",$value)); } &CgiDie("cgi-lib: reached end of input while seeking end of " . "headers. Format of CGI input is wrong.\n$buf"); } die $@ if $errflag; $head .= substr($buf, 0, $bufsize); $buf = substr($buf, $bufsize); $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; } $head .= substr($buf, 0, $lpos+2); push (@in, $head); @heads = split("\r\n", $head); ($cd) = grep (/^\s*Content-Disposition:/i, @heads); ($ct) = grep (/^\s*Content-Type:/i, @heads); ($name) = $cd =~ /\bname="([^"]+)"/i; #"; ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name; ($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname; $incfn{$name} .= (defined $in{$name} ? "\0" : "") . (defined $fname ? $fname : ""); ($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i; #"; ($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype; $inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype; if ($writefiles && defined $fname) { $ser++; $fn = $writefiles . ".$$.$ser"; open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n"); binmode (FILE); # write files accurately } substr($buf, 0, $lpos+4) = ''; undef $fname; undef $ctype; } 1; END_MULTIPART if ($errflag) { local ($errmsg, $value); $errmsg = $@ || $errflag; foreach $value (values %insfn) { unlink(split("\0",$value)); } &CgiDie($errmsg); } else { # everything's ok. } } else { &CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n"); } # no-ops to avoid warnings $insfn = $insfn; $incfn = $incfn; $inct = $inct; $^W = $perlwarn; return ($errflag ? undef : scalar(@in)); } # PrintHeader # Returns the magic line which tells WWW that we're an HTML document sub PrintHeader { return "Content-type: text/html\n\n"; } # HtmlTop # Returns the of a document and the beginning of the body # with the title and a body

header as specified by the parameter sub HtmlTop { local ($title) = @_; return < $title

$title

END_OF_TEXT } # HtmlBot # Returns the , codes for the bottom of every HTML page sub HtmlBot { return "\n\n"; } # SplitParam # Splits a multi-valued parameter into a list of the constituent parameters sub SplitParam { local ($param) = @_; local (@params) = split ("\0", $param); return (wantarray ? @params : $params[0]); } # MethGet # Return true if this cgi call was using the GET request, false otherwise sub MethGet { return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET"); } # MethPost # Return true if this cgi call was using the POST request, false otherwise sub MethPost { return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST"); } # MyBaseUrl # Returns the base URL to the script (i.e., no extra path or query string) sub MyBaseUrl { local ($ret, $perlwarn); $perlwarn = $^W; $^W = 0; $ret = 'http://' . $ENV{'SERVER_NAME'} . ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') . $ENV{'SCRIPT_NAME'}; $^W = $perlwarn; return $ret; } # MyFullUrl # Returns the full URL to the script (i.e., with extra path or query string) sub MyFullUrl { local ($ret, $perlwarn); $perlwarn = $^W; $^W = 0; $ret = 'http://' . $ENV{'SERVER_NAME'} . ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') . $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} . (length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : ''); $^W = $perlwarn; return $ret; } # MyURL # Returns the base URL to the script (i.e., no extra path or query string) # This is obsolete and will be removed in later versions sub MyURL { return &MyBaseUrl; } # CgiError # Prints out an error message which which containes appropriate headers, # markup, etcetera. # Parameters: # If no parameters, gives a generic error message # Otherwise, the first parameter will be the title and the rest will # be given as different paragraphs of the body sub CgiError { local (@msg) = @_; local ($i,$name); if (!@msg) { $name = &MyFullUrl; @msg = ("Error: script $name encountered fatal error\n"); }; if (!$cgi_lib'headerout) { #') print &PrintHeader; print "\n\n$msg[0]\n\n\n"; } print "

$msg[0]

\n"; foreach $i (1 .. $#msg) { print "

$msg[$i]

\n"; } $cgi_lib'headerout++; } # CgiDie # Identical to CgiError, but also quits with the passed error message. sub CgiDie { local (@msg) = @_; &CgiError (@msg); die @msg; } # PrintVariables # Nicely formats variables. Three calling options: # A non-null associative array - prints the items in that array # A type-glob - prints the items in the associated assoc array # nothing - defaults to use %in # Typical use: &PrintVariables() sub PrintVariables { local (*in) = @_ if @_ == 1; local (%in) = @_ if @_ > 1; local ($out, $key, $output); $output = "\n
\n"; foreach $key (sort keys(%in)) { foreach (split("\0", $in{$key})) { ($out = $_) =~ s/\n/
\n/g; $output .= "
$key\n
:$out:
\n"; } } $output .= "
\n"; return $output; } # PrintEnv # Nicely formats all environment variables and returns HTML string sub PrintEnv { &PrintVariables(*ENV); } # The following lines exist only to avoid warning messages $cgi_lib'writefiles = $cgi_lib'writefiles; $cgi_lib'bufsize = $cgi_lib'bufsize ; $cgi_lib'maxbound = $cgi_lib'maxbound; $cgi_lib'version = $cgi_lib'version; $cgi_lib'filepre = $cgi_lib'filepre; 1; #return true #------ End cgi-lib.pl -------# } # End of BEGIN statement # End reportdhcp.pl