It needs a *lot* of work yet, and is really just a small start. Bit I
think everything it does, it does moderately well.
You're on your own for documentation, but you should be able to figure
it out. `pm' by itself will give you a little help.
To set the default host & password, see $host, $user, and $password
after "package main" towards the bottom. (It was easier to just
concatenate the needed files; it's really two--the main script and the
TEK::PM package.) The @exempt array is a list of users who are
permitted to be logged in more than once, or at least using multiple
channels (think multilink PPP). As you can guess, we don't have many
of those, or we'd have done something more sophisticated.
We run `pm multiboot' from cron every 5 minutes; right now it just
prints out who should go & cron mails the output. We don't have many
attempts, and I like to look at them by hand to decide whether or not
to boot them.
About the only oddity of the script is that you need Net::Telnet and
Term::Readline (tested with Term::Readline::Gnu) installed.
*PLEASE* *PLEASE* *PLEASE* *PLEASE* *PLEASE* *PLEASE* *PLEASE* *PLEASE*
If you use this, try it, or even just look at the code, please offer
any feedback you might have to todd@tekinteractive.com. Patches, bug
reports, or feature requests are welcome. Some time when I don't have
anything else to do, I'll turn it into a CPAN-like module and make
periodic releases. Until then, I'll probably just offer them to the
list unless someone complains.
Without further noise,
Todd
----------cut here-----------
#!/usr/bin/perl
# Copyright 1998 TEK Interactive Group, Inc.
# All rights reserved.
#
# You may fold, spindle, mutilate, destroy, or even use
# this code under the terms of the GNU General Public
# License.
#
# Contact todd@tekinteractive.com with patches, suggestions,
# bug reports, or just to say hi.
package TEK::PM;
use strict;
use Net::Telnet;
use Socket;
use vars qw($CTRLC_DEBUG $CTRLC_SNOOP
$PAPFLAG $CHAPFLAG $LCPFLAG $IPCPFLAG $IPXFLAG $UNFLAG
$CRCFLAG $REJECT $CCPFLAG );
######################################################################
BEGIN
{
$TEK::PM::CTRLC_DEBUG = 0;
$TEK::PM::CTRLC_SNOOP = 0;
# Flags for determining sequences to be decoded
$TEK::PM::PAPFLAG = "PAP_";
$TEK::PM::CHAPFLAG = "CHAP_";
$TEK::PM::LCPFLAG = "LCP";
$TEK::PM::IPCPFLAG = "IPCP";
$TEK::PM::IPXFLAG = "IPXCP";
$TEK::PM::UNFLAG = "UNKNOWN";
$TEK::PM::CRCFLAG = "Ptrace";
$TEK::PM::REJECT = "LCP_CODE_REJECT";
$TEK::PM::CCPFLAG = "CCP_";
# LCP Options Array
@TEK::PM::lcpoption = (
"01::Maximum-Receive-Unit",
"02::Async-Control-Character-Map",
"03::Authentication-Protocol",
"04::Quality-Protocol",
"05::Magic-Number",
"06::RESERVED",
"07::Protocol-Field-Compression",
"08::Address-and-Control-Field-Compression",
"09::FCS-Alternatives",
"0A::Self-Describing-Pad",
"0B::Numbered-Mode",
"0C::Multi-Link-Procedure",
"0D::Callback",
"0E::Connect-Time",
"0F::Compound-Frames",
"10::Nominal-Data-Encapsulation",
"11::Multilink-MRRU",
"12::Multilink-Short-Sequence-Number-Header",
"13::Multilink-Endpoint-Discriminator",
"14::Proprietary",
"15::DCE-Identifier",
"16::Multi-Link-Plus-Procedure",
"17::Link-Discriminator-for-BACP" );
# IPCP Options Array
@TEK::PM::ipcpoption = (
"01::IP-Addresses (deprecated)",
"02::IP-Compression-Protocol",
"03::IP-Address",
"81::Primary DNS Server Address",
"82::Primary NBNS Server Address",
"83::Secondary DNS Server Address",
"84::Secondary NBNS Server Address",);
# CCP Options Array (RFC 1962)
@TEK::PM::ccpoption = (
"00::Compression type=Organization Unique Identifier (OUI)",
"01::Compression type=Predictor type 1",
"02::Compression type=Predictor type 2",
"03::Compression type=Puddle Jumper",
"04::Compression type=unassigned",
"05::Compression type=unassigned",
"06::Compression type=unassigned",
"07::Compression type=unassigned",
"08::Compression type=unassigned",
"09::Compression type=unassigned",
"0A::Compression type=unassigned",
"0B::Compression type=unassigned",
"0C::Compression type=unassigned",
"0D::Compression type=unassigned",
"0E::Compression type=unassigned",
"10::Compression type=Hewlett-Packard PPC",
"11::Compression type=Stac Electronics LZS",
"12::Compression type=Microsoft PPC",
"13::Compression type=Gandalf FZA",
"14::Compression type=V.42bis compression",
"15::Compression type=BSD LZW Compress",
"FF::Compression type=Reserved" );
# IPXCP Options Array
@TEK::PM::ipxoption = ("01::IPX-Network-Number",
"02::IPX-Node-Number",
"03::IPX-Compression-Protocol",
"04::IPX-Routing-Protocol",
"05::IPX-Router-Name",
"06::IPX-Configuration-Complete", );
# Assigned PPP DLL Protocol Numbers Array
# See RFC1700
@TEK::PM::protolist = (
"0001::Padding Protocol",
"0021::Internet Protocol version 4",
"0023::OSI Network Layer",
"0025::Xerox NS IDP",
"0027::DECnet Phase IV",
"0029::Appletalk",
"002B::Novell IPX",
"002D::Van Jacobson Compressed TCP/IP",
"002F::Van Jacobson Uncompressed TCP/IP",
"0031::Bridging PDU",
"0033::Stream Protocol (ST-II)",
"0035::Banyan Vines",
"0037::reserved (until 1993)",
"0039::AppleTalk EDDP",
"003B::AppleTalk SmartBuffered",
"003D::Multi-Link",
"003F::NETBIOS Framing",
"0041::Cisco Systems",
"0043::Ascom Timeplex",
"0045::Fujitsu Link Backup and Load Balancing (LBLB)",
"0047::DCA Remote Lan",
"0049::Serial Data Transport Protocol (PPP-SDTP)",
"004B::SNA over 802.2",
"004D::SNA",
"004F::IP6 Header Compression",
"0051::KNX Bridging Data",
"0053::Encryption",
"0055::Individual Link Encryption",
"0057::Internet Protocol version 6",
"006F::Stampede Bridging",
"0071::BAP Bandwidth Allocation Protocol",
"0073::MP+ Protocol",
"007D::reserved (Control Escape)",
"007F::reserved (compression inefficient)",
"00C1::NTCITS IPI",
"00CF::reserved (PPP NLPID)",
"00FB::single link compression in multilink",
"00FD::compressed datagram",
"00FF::reserved (compression inefficient)",
"0201::802.1d Hello Packets",
"0203::IBM Source Routing BPDU",
"0205::DEC LANBridge100 Spanning Tree",
"0207::Cisco Discovery Protocol",
"0209::Netcs Twin Routing",
"0231::Luxcom",
"0233::Sigma Network Systems",
"0235::Apple Client Server Protocol",
"4001::Cray Communications Control Protocol",
"4003::CDPD Mobile Network Registration Protocol",
"4021::Stacker LZS",
"8021::Internet Protocol Control Protocol",
"8023::OSI Network Layer Control Protocol",
"8025::Xerox NS IDP Control Protocol",
"8027::DECnet Phase IV Control Protocol",
"8029::Appletalk Control Protocol",
"802B::Novell IPX Control Protocol",
"802D::reserved",
"802F::reserved",
"8031::Bridging NCP",
"8033::Stream Protocol Control Protocol",
"8035::Banyan Vines Control Protocol",
"8037::reserved till 1993",
"8039::reserved",
"803B::reserved",
"803D::Multi-Link Control Protocol",
"803F::NETBIOS Framing Control Protocol",
"8041::Cisco Systems Control Protocol",
"8043::Ascom Timeplex",
"8045::Fujitsu LBLB Control Protocol",
"8047::DCA Remote Lan Network Control Protocol (RLNCP)",
"8049::Serial Data Control Protocol (PPP-SDCP)",
"804B::SNA over 802.2 Control Protocol",
"804D::SNA Control Protocol",
"804F::IP6 Header Compression Control Protocol",
"8051::KNX Bridging Control Protocol",
"8053::Encryption Control Protocol",
"8055::Individual Link Encryption Control Protocol",
"8057::IPv6 Control Protocol",
"806F::Stampede Bridging Control Protocol",
"8073::MP+ Control Protocol",
"8071::BACP Bandwidth Allocation Control Protocol",
"807d::Not Used - reserved",
"80C1::NTCITS IPI Control Protocol",
"80CF::Not Used - reserved",
"80FB::single link compression in multilink control",
"80FD::Compression Control Protocol",
"80FF::NotUsed - reserved",
"8207::Cisco Discovery Protocol Control",
"8209::Netcs Twin Routing",
"8235::Apple Client Server Protocol Control",
"C021::Link Control Protocol",
"C023::Password Authentication Protocol",
"C025::Link Quality Report",
"C027::Shiva Password Authentication Protocol",
"C029::CallBack Control Protocol (CBCP)",
"C081::Container Control Protocol",
"C223::Challenge Handshake Authentication Protocol",
"C225::RSA Authentication Protocol",
"C227::Extensible Authentication Protocol",
"C229::Mitsubishi Security Info Exch Ptcl (SIEP)",
"C26F::Stampede Bridging Authorization Protocol",
"C281::Proprietary Authentication Protocol",
"C283::Proprietary Authentication Protocol",
"C481::Proprietary Node ID Authentication Protocol" );
# For Multilink PPP see RFC 1717
@TEK::PM::endpointclass = ("00::Null Class",
"01::Locally Assigned Address",
"02::IP Address",
"03::IEEE 802.1 MAC Address",
"04::PPP Magic-Number Block",
"05::Public Switched Network Directory Number");
}
######################################################################
sub new
{
my ($class, $host, $user, $pass) = @_;
my $self = { '.conn' => undef,
'.prompt' => "",
'.host' => $host,
'.user' => $user,
'.pass' => $pass };
bless $self, $class;
return $self;
}
######################################################################
sub DESTROY
{
my ($self) = @_;
$self->close();
}
######################################################################
sub open
{
my ($self) = @_;
$self->{ '.conn' } = new Net::Telnet( Errmode => 'return' );
my $conn = $self->{ '.conn' };
$conn->open( $self->{ '.host'} );
$conn->waitfor( '/login: $/i' );
$conn->print( $self->{ '.user' } );
$conn->waitfor( '/Password: $/' );
$conn->print( $self->{ '.pass' } );
my $foo;
($foo, $self->{ '.prompt' }) = $conn->waitfor('/\S+>\s+/');
}
######################################################################
sub close
{
my ($self) = @_;
$self->{ '.conn' }->close() if $self->{ '.conn' };
undef $self->{ '.conn' };
}
######################################################################
sub sendCommand
{
my ($self, $command) = @_;
my $prematch = '';
my $match = '';
my $text = '';
my $prompt = $self->{ '.prompt' };
my $more = "-- Press Return for More -- ";
$self->{ '.conn' }->print( $command );
while ( 1 )
{
($prematch, $match) = $self->{ '.conn' }->waitfor( "/$more|$prompt/i");
$text .= $prematch;
if ( $match eq "-- Press Return for More -- " )
{
$self->{ '.conn' }->print("");
next;
}
last if ( $match eq $prompt or ! $match );
}
return $text;
}
######################################################################
sub whoson
{
my ($self, $lookfor) = @_;
my ($text, $ret) = ('', '');
my $all = $self->sendCommand("show all");
my $ses = $self->sendCommand("show sessions");
my ($mcount, $pcount, $ports, $modems) = (0, 0, 0, 0);
$modems = scalar split(/\n/, $self->sendCommand("show modems")) - 2;
my $s = $all;
while ( $s =~ /S(\d*)\s*(.{5}) (.{3}) (.{16}) /is )
{
$ports ++;
$s = $';
my ($serial, $speed, $modem, $host) = ($1, $2, $3, $4);
($host) = $host =~ /(\d+)/;
next if $host eq '';
$pcount++;
my ($user, $ip, $start, $idle) = $ses =~
m#S$serial\s*([^ ]*)\s*([^ ]*)\s*.{25}\s*([^ ]*)\s*([0-9,:]*)#;
$speed = sprintf("%.1f", $speed / 1000);
my $connect = $speed;
my $type = "ISDN";
my $retr;
if ( $modem =~ /^(M\d+)/ )
{
my $m = $self->sendCommand( "show $1" );
my ($tr, $rr, $ct, $rtr, $ren) = $m =~
/Transmit\ Rate:\ (\d+).*
Receive\ Rate:\ (\d+).*
Connection\ Type:\ (\S+).*
Retrains:\ (\d+).*
Renegotiations:\ (\d+)/six;
$connect = sprintf("%.1f/%.1f", $tr / 1000, $rr / 1000);
$type = $ct;
$retr = "$rtr/$ren";
$mcount++;
}
$modem = "" if $modem eq "on ";
($modem) = $modem =~ /(\d+)/;
my $s = $self->sendCommand( "show S$serial" );
$type .= "/MPP" if ( $s =~ /Multilink/ );
$type .= "/Stac" if ( $s =~ /Stac/ );
next if $lookfor and substr($user, 0, length $lookfor) ne $lookfor;
$user = substr($user, 0, 8);
$text .= sprintf( "%2s %2s %2s %-8s %-9.9s %-3.3s %-16.16s " .
"%-15.15s %6.6s %6.6s\n",
$serial, $modem, $host, $user, $connect,
$retr, $type, $ip, $start, $idle);
}
my $mp = sprintf("%.1f", $mcount / $modems * 100);
my $pp = sprintf("%.1f", $pcount / $ports * 100);
$ret = ("\nModems in use: $mcount/$modems ($mp\%) " .
"Ports in use: $pcount/$ports ($pp\%)\n\n")
if not $lookfor;
$ret .= ("Sr Md If Username Down/Up v/^ Connect Type " .
"Host Login Idle\n" .
"-- -- -- -------- --------- --- ---------------- " .
"--------------- ------ ------\n");
return $ret . $text . "\n";
}
######################################################################
sub kick
{
my ($self,$user) = @_;
my $ses = $self->sendCommand( "show sessions" );
my $text = "Kicking User $user....\n";
while ( $ses =~ /(S\d*)\s*($user)/isg )
{
$ses = $';
$text .= " " . $self->sendCommand( "reset $1" );
}
$text .= "Done\n";
return $text;
}
######################################################################
sub reset
{
my ($self,$port) = @_;
my $text = "Reseting Port $port...\n";
$text .= " " . $self->sendCommand( "reset $port" );
$text .= "Done\n";
return $text;
}
######################################################################
sub debugold
{
my ($self) = @_;
local $SIG{INT} = sub { $TEK::PM::CTRLC_DEBUG = 1; };
$TEK::PM::CTRLC_DEBUG=0;
print "Starting Debug session...\n";
$self->sendCommand( "set DEBUG 0x51" );
$self->sendCommand( "set CONSOLE" );
while ( ! $TEK::PM::CTRLC_DEBUG )
{
my $line = $self->{ '.conn' }->getline( Timeout => 1 );
print $line if $line;
}
$self->sendCommand( "set DEBUG OFF" );
$self->sendCommand( "reset CONSOLE" );
$self->close();
print "\nClosing Debug session....\n";
}
######################################################################
sub resolve
{
my $addr = shift;
my $name = gethostbyaddr(pack( "C4", split /\./, $1), &AF_INET) || $1;
$name =~ s/\.tekinteractive\.com//;
$name =~ s/\.mixi\.net//;
return $name;
}
######################################################################
sub snoop
{
my ($self,$user) = @_;
local $SIG{INT} = sub { $TEK::PM::CTRLC_SNOOP = 1; };
$TEK::PM::CTRLC_SNOOP=0;
print "Starting snoop session...\n";
my $config = $self->sendCommand( "ifconfig" );
my $all = $self->sendCommand( "show all" );
my $ses = $self->sendCommand( "show ses" );
my ($serial) = $ses =~ /(S\d+)\s*$user/;
my ($host) = $all =~ /$serial\s*.{5} .{3} (.{16}) /is;
$host =~ s#\s*##g;
my ($ip) = $config =~ /$host: .*?dest (\S+) /is;
print "User $user on $host and $ip...\n";
if ( $ip )
{
$self->sendCommand( "delete filter snoop" );
$self->sendCommand( "add filter snoop" );
$self->sendCommand( "set filter snoop 1 permit $ip/32" );
$self->sendCommand( "set filter snoop 2 permit $ip/0 $ip/32" );
$self->sendCommand( "ptrace snoop" );
$self->sendCommand( "reset CONSOLE" );
while ( ! $TEK::PM::CTRLC_SNOOP )
{
$_ = $self->{ '.conn' }->getline( Timeout => 1 );
if ($_)
{
my ($proto, $src_addr, $src_port, $dest_addr, $dest_port);
s!(\d+\.\d+\.\d+\.\d+)(\.\d+)?!resolve($1). $2!xeg;
if (($proto, $src_addr, $src_port, $dest_addr, $dest_port) =
/(TCP|UDP) from (\S+)\.(\d+) to (\S+)\.(\d+)/)
{
my ($seq) = /seq (\S+)/;
my ($ack) = /ack (\S+)/;
my ($win, $flags) = /win (\d+)/;
$_ = $';
my ($flags, $size) = /, (.*?)\s*(?:$|, (\d+) bytes)/;
$seq = hex($seq);
$ack = hex($ack);
print "$proto $src_addr:$src_port > ",
"$dest_addr:$dest_port seq $seq ack $ack ",
"win $win $flags";
print " ($size)" if $size;
print "\n";
}
elsif (/icmp/)
{
/icmp from (\S+) to (\S+) type (.*)$/;
print "ICMP: $1 > $2: $3\n";
}
else
{
print;
}
}
}
$self->sendCommand( "ptrace" );
$self->sendCommand( "reset CONSOLE" );
}
else
{
print "Unable to find user.\n";
}
$self->close();
print "\nClosing snoop session....\n";
}
######################################################################
sub tcpdump
{
my ($self, $user) = @_;
local $SIG{INT} = sub { $TEK::PM::CTRLC_SNOOP = 1; };
$TEK::PM::CTRLC_SNOOP=0;
print "Starting snoop session...\n";
my $config = $self->sendCommand( "ifconfig" );
my $all = $self->sendCommand( "show all" );
my $ses = $self->sendCommand( "show ses" );
my ($serial) = $ses =~ /(S\d+)\s*$user/;
my ($host) = $all =~ /$serial\s*.{5} .{3} (.{16}) /is;
$host =~ s#\s*##g;
my ($ip) = $config =~ /$host: .*?dest (\S+) /is;
print "User $user on $host and $ip...\n";
if ($ip)
{
system("tcpdump", "host", $ip);
}
else
{
print "Unable to find user.\n";
}
$self->close();
print "\nClosing snoop session....\n";
}
######################################################################
sub multi_login_kick
{
my ($self, @exempt) = @_;
my $text = '';
my $all = $self->sendCommand( "show all" );
my $ses = $self->sendCommand( "show ses" );
my $s = $ses;
my %users;
while ( $s =~ /S\d+\s*([^ ]*)\s*[^ ]*\s*.{25}\s*[^ ]*\s*[0-9,:]*/ )
{
$s = $';
next if $1 eq "-";
$users{ $1 }++;
}
foreach my $user ( keys %users )
{
next unless $users{ $user } > 1;
if ( not grep( /$user/, @exempt ) )
{
# $self->kick( $user );
print "Hey, Kick user $user...\n";
}
}
}
######################################################################
sub prompt
{
my ($self) = @_;
return $self->{ '.prompt' };
}
######################################################################
sub open_manual
{
my ($self) = @_;
$self->{ '.conn' } = new Net::Telnet();
my $conn = $self->{ '.conn' };
$conn->open( $self->{ '.host'} );
my ($pre, $login) = $conn->waitfor( '/login: $/i' );
return $pre . $login;
}
######################################################################
sub username
{
my ($self, $username) = @_;
my $conn = $self->{ '.conn' };
$self->{ '.user' } = $username;
$conn->print( $username );
my ($pre, $pass) = $conn->waitfor( '/login: $|Password: $/' );
return $pre . $pass;
}
######################################################################
sub password
{
my ($self, $password) = @_;
my $conn = $self->{ '.conn' };
$conn->print( $password );
my $foo;
($foo, $self->{ '.prompt' }) = $conn->waitfor('/\S+>\s+|login: $/');
if ($self->{ '.prompt' } =~ /login: /)
{
return $foo . $self->{ '.prompt' };
}
else
{
return $self->{ '.prompt' };
}
}
######################################################################
sub debug
{
my ($self,$mode) = @_;
local $SIG{INT} = sub { $TEK::PM::CTRLC_DEBUG = 1; };
$TEK::PM::CTRLC_DEBUG=0;
print "Starting Debug session...\n";
$self->sendCommand( "set DEBUG 0x51" );
$self->sendCommand( "set CONSOLE" );
my $lines = '';
while ( ! $TEK::PM::CTRLC_DEBUG )
{
my ($prematch, $match) =
$self->{ '.conn' }->waitfor( Match => "/Sending|Received/i",
Timeout => 1 );
$lines .= $prematch;
next if !$match;
if ( $lines and ($mode or $lines !~ /LCP_ECHO/) )
{
$lines =~ s# \n(\w\w )#$1#sg;
$lines =~ s#\n\n#\n#sg;
my ($line1,$line2,$rest) = split( '\n', $lines, 3 );
$self->pppdecode( $line1, $line2 );
$rest =~ s#\n##sg;
print "$rest\n" if $rest;
}
$lines = $match;
}
$self->sendCommand( "set DEBUG OFF" );
$self->sendCommand( "reset CONSOLE" );
$self->close();
print "\nClosing Debug session....\n";
}
###########################################################################
sub pppdecode
{
my ($self, $line, $hexstring) = @_;
if( !(index($line,$TEK::PM::CRCFLAG) != -1) )
{
chop($line);
}
# Identify PPP related items that do not require parsing
if( index($line,"Open") != -1 ||
index($line,"Apparent") != -1 ||
index($line,"CRC") != -1 ||
index($line,"LMI") != -1 ||
index($line,"Annex") != -1 ||
index($line,"Re-opening") != -1 ||
index($line,"Succeeded") != -1 )
{
print( "**** $line\n" );
}
# Identify items we can parse
if( $self->checkparseflags( $line ) )
{
# For CRC errors since hex is found in first line
if(index($line,$TEK::PM::CRCFLAG) != -1)
{
my $dud;
($dud, $hexstring) = split(/: /,$line);
print "CRC[$hexstring]\n";
}
# For everything else
else
{
print("\n$line\n");
}
# Clean up hexstring before parsing
$hexstring = $self->clean($hexstring);
# Send hexstring to parsing routines
if(index($line,$LCPFLAG) != -1)
{
$self->parselcp($hexstring); # LCP
}
elsif(index($line,$PAPFLAG) != -1)
{
$self->parsepap($hexstring); # PAP
}
elsif(index($line,$CHAPFLAG) != -1)
{
$self->parsechap($hexstring); # CHAP
}
elsif(index($line,$IPCPFLAG) != -1)
{
$self->parseipcp($hexstring); # IPCP
}
elsif(index($line,$IPXFLAG) != -1)
{
$self->parseipxcp($hexstring); # IPXCP
}
elsif(index($line,$CCPFLAG) != -1)
{
$self->parseccp($hexstring);
}
elsif(index($line,$UNFLAG) != -1)
{
$self->parseunknown($hexstring); # UNKNOWN
}
elsif(index($line,$REJECT) != -1)
{
$self->parseunknown($hexstring);
}
elsif(index($line,$CRCFLAG) != -1)
{
$self->parseunknown($hexstring); # CRC
}
}
}
###########################################################################
sub parseccp
{
# Parse and decode CCP packets
# initialize local variables
my $self = shift;
my @newlist;
my $data = "";
my $pid = "";
my $plength = "";
my $pdata = "";
my $pcode = "";
my $length = "";
my $i = 0;
my $option = "";
# Get and Display Packet Information
($pcode, $pid, $plength, $pdata) = split(/::/, $self->buster($_[0]));
print($self->showhex($_[0]),"\n Packet Info: Code: $pcode, ID: $pid, ",
$self->hex2dec($plength)," bytes.\n");
# Get a list of options
@newlist = $self->old($pdata);
# Cycle thru list of options and decode them
for($i=0;$i<@newlist;$i++)
{
($option, $length, $data) = split(/::/,$newlist[$i]);
#print " == option: $option, length: $length, data: $data ==\n";
print(" ", $self->match(@TEK::PM::ccpoption, $option),
" [0x$option] length: (", $self->hex2dec($length)," bytes)");
# Handles the case when there are no options.
if($data ne "")
{
print(" ", $self->match(@TEK::PM::protolist,substr($data,0,4)),
" [0x$data]");
}
print("\n");
}
}
###########################################################################
sub parselcp
{
#Parse and decode LCP packets
#initialize variables
my $self = shift;
my @newlist = "";
my $option = "";
my $length = "";
my $data = "";
my $pcode = "";
my $pid = "";
my $plength = "";
my $pdata = "";
my $i = 0;
# Get and Display General packet information
($pcode, $pid, $plength, $pdata) = split(/::/,$self->buster($_[0]));
print( $self->showhex($_[0]),
"\n Packet Info: Code: $pcode, ID: $pid, ",
$self->hex2dec($plength)," bytes.\n");
# Get a list of options and decode them
@newlist = $self->old($pdata);
for($i=0;$i<@newlist;$i++)
{
($option, $length, $data) = split(/::/,$newlist[$i]);
if($option ne "00")
{
print(" ", $self->match(@TEK::PM::lcpoption,$option),
"[0x$option], length: (",$self->hex2dec($length)," bytes)");
# Handles case of no data like LCP_ECHO_REQUESTS
if($data ne "")
{
# print(", ",
# $self->match(@TEK::PM::protolist,substr($data,0,4)),
# "[0x$data]");
if($option eq "01")
{
print " ",$self->hex2dec($data)," bytes [0x$data]";
}
else
{
print(", ",
$self->match(@TEK::PM::protolist,substr($data,0,4)),
"[0x$data]");
}
}
print("\n");
# Parse Multilink (RFC1717)
if($option eq "13")
{
$self->parseendpoint($data);
}
# Parse MRRU
elsif($option eq "11")
{
$self->parseMRRU($data);
}
}
}
}
###########################################################################
sub parsepap
{
# Decodes PAP packets displaying information like usernames, passwords,
# messages, etc.
# initialize variables
my $self = shift;
my @newlist;
my $loginlen = "";
my $firstbyte = "";
my $login = "";
my $pcode = "";
my $pdata = "";
my $pass = "";
my $data = "";
my $pid = "";
my $plength = "";
my $i = 0;
# Get and Display Packet Information
($pcode, $pid, $plength, $pdata) = split(/::/,$self->buster($_[0]));
print($self->showhex($_[0]),
"\n Packet Info: Code: $pcode, ID: $pid, ",
$self->hex2dec($plength)," bytes.\n");
# Get a list of options (with PAP there will only be one option
@newlist = $self->old($pdata);
($loginlen, $firstbyte, $data) = split(/::/,$newlist[$i]);
$data = $firstbyte.$data; # combine first byte with rest of data.
# Take care of Authentication-Requests
if($pcode eq "01")
{
$login = substr($data,0,($self->hex2dec($loginlen)*2));
$data = substr($data,$self->hex2dec($loginlen)*2,
length($data)-($self->hex2dec($loginlen)*2));
$plength = $self->hex2dec(substr($data,0,2));
$pass = substr($data,2,length($data)-2);
# Display Login Info
print(" Login ID: ",$self->hex2asc($login));
print(" (",$self->hex2dec($loginlen)," bytes)");
print(", [0x$login]\n");
# Display Password Info
print(" Password: ",$self->hex2asc($pass));
print(" ($plength bytes)");
print(", [0x$pass]\n");
}
# Take care of Authentication Acks and Naks
else
{
print(" Message: ",
$self->hex2asc(substr($data,0,($self->hex2dec($loginlen))*2)),
" (",$self->hex2dec($loginlen)," bytes),\n [0x",
substr($data,0,($self->hex2dec($loginlen))*2),"]\n");
}
}
###########################################################################
sub parsechap
{
# Parse CHAP packets to display CHAP values and names.
# initialize variables
my $self = shift;
my @newlist;
my $data = "";
my $code = "";
my $id = "";
my $length = "";
my $valsize = 0;
my $value = 0;
my $name = "";
# Get general packet information
($code, $id, $length, $data) = split(/::/,$self->buster($_[0]));
# Display general packet information
print($self->showhex($_[0]),"\n Packet Info: Code: $code, ID: $id, ",
$self->hex2dec($length)," bytes.\n");
# Take Care of CHAP Challenges and Responses
if($code eq "01" || $code eq "02")
{
# Determine CHAP parameters
$valsize = substr($data,0,2);
$value = substr($data,2,$self->hex2dec($valsize)*2);
$name = substr($data,2+($self->hex2dec($valsize)*2),
length($data)-(2+($self->hex2dec($valsize)*2)));
# Display CHAP parameters
print(" ValSize[0x$valsize]: (",
$self->hex2dec($valsize)," bytes), ");
print("Value: [0x",$value,"]\n");
print(" Name: ",$self->hex2asc($name)," [0x$name]\n");
}
# Take Care of CHAP Successes and Failures
elsif($code eq "03" || $code eq "04")
{
$data = $length.$data;
$name = substr($data,4,length($data)-8);
print(" Message: ",$self->hex2asc($name)," [0x$name]\n");
}
}
###########################################################################
sub parseipcp
{
# Parses and decodes IPCP packets
# initialize variables
my $self = shift;
my @newlist = "";
my $option = "";
my $length = "";
my $data = "";
my $pcode = "";
my $pid = "";
my $plength = "";
my $pdata = "";
my $i = 0;
# Get and display packet information
($pcode, $pid, $plength, $pdata) = split(/::/,$self->buster($_[0]));
print($self->showhex($_[0]),"\n Packet Info: Code: $pcode, ID: $pid, ",
$self->hex2dec($plength)," bytes.\n");
# Get list of options
@newlist = $self->old($pdata);
# Parse and decode list of options
for($i=0;$i<@newlist;$i++)
{
($option, $length, $data) = split(/::/,$newlist[$i]);
print(" ", $self->match(@TEK::PM::ipcpoption,$option),
" [0x$option], length: (",$self->hex2dec($length)," bytes), ");
# Convert hex ip address to dotted decimal
if($option eq "03" ||
$option eq "81" ||
$option eq "82" ||
$option eq "83" ||
$option eq "84")
{
$data = $self->hex2ip($data);
print "[";
}
# IP-Addresses Deprecated
elsif($option eq "01")
{
print("\n Source-IP-Address: [",
$self->hex2ip(substr($data,0,8)),"]\n");
print(" Destination-IP-Adress: [",
$self->hex2ip(substr($data,8,8)),"]\n Data: [0x");
}
# Decode protocol data
else
{
print($self->match(@TEK::PM::protolist,substr($data,0,4))," [0x");
}
print("$data]\n");
}
}
###########################################################################
sub parseipxcp
{
# Parses the hexstring for IPXCP options
# initialize variables
my $self = shift;
my @newlist;
my $pcode = "";
my $data = "";
my $pid = "";
my $plength = "";
my $pdata = "";
my $option = "";
my $length = "";
my $i = 0;
# Get and Display Packet Information
($pcode, $pid, $plength, $pdata) = split(/::/,$self->buster($_[0]));
print($self->showhex($_[0]),"\n Packet Info: Code: $pcode, ID: $pid, ",
$self->hex2dec($plength)," bytes.\n");
# Get a list of options
@newlist = $self->old($pdata);
# Cycle thru list of options and decode them
for($i=0;$i<@newlist;$i++)
{
($option, $length, $data) = split(/::/,$newlist[$i]);
#print " == option: $option, length: $length, data: $data ==\n";
print(" ",$self->match(@TEK::PM::ipxoption, $option),
" [0x$option] length: (",$self->hex2dec($length)," bytes)");
# Handles the case when there are no options.
if($data ne "")
{
print(" ",$self->match(@TEK::PM::protolist,substr($data,0,4)),
" [0x$data]");
}
print("\n");
}
}
###########################################################################
sub parseunknown
{
my $self = shift;
# initialize variables
my $hexstring = $_[0];
my $i = 0;
my $count = 0;
my $ascstring = "";
my $perline = 10;
my @ascii_table = ("00::[NULL]", "01::[SOH]", "02::[STX]", "03::[ETX]",
"04::[EOT]", "05::[ENQ]", "06::[ACK]", "07::[BEL]",
"08::[BS]", "09::[HT]", "0A::[NL]", "0B::[VT]",
"0C::[NP]", "0D::[CR]", "OE::[SO]", "OF::[SI]",
"10::[DLE]", "11::[DC1]", "12::[DC2]", "13::[DC3]",
"14::[DC4]", "15::[NAK]", "16::[SYN]", "17::[ETB]",
"18::[CAN]", "19::[EM]", "1A::[SUB]", "1B::[ESC]",
"1C::[FS]", "1D::[GS]", "1E::[RS]", "1F::[US]",
"20::[SP]", "21::!", "22::\"", "23::#",
"24::\$", "25::%", "26::&", "27::'",
"28::(", "29::)", "2A::*", "2B::+",
"2C::,", "2D::-", "2E::.", "2F::/",
"30::0", "31::1", "32::2", "33::3",
"34::4", "35::5", "36::6", "37::7",
"38::8", "39::9", "3A:::", "3B::;",
"3C::<", "3D::=", "3E::>", "3F::?",
"40::@", "41::A", "42::B", "43::C",
"44::D", "45::E", "46::F", "47::G",
"48::H", "49::I", "4A::J", "4B::K",
"4C::L", "4D::M", "4E::N", "4F::O",
"50::P", "51::Q", "52::R", "53::S",
"54::T", "55::U", "56::V", "57::W",
"58::X", "59::Y", "5A::Z", "5B::[",
"5C::\\", "5D::]", "5E::^", "5F::_",
"60::`", "61::a", "62::b", "63::c",
"64::d", "65::e", "66::f", "67::g",
"68::h", "69::i", "6A::j", "6B::k",
"6C::l", "6D::m", "6E::n", "6F::o",
"70::p", "71::q", "72::r", "73::s",
"74::t", "75::u", "76::v", "77::w",
"78::x", "79::y", "7A::z", "7B::{",
"7C::|", "7D::}", "7E::~", "7F::[DEL]" );
# loop thru hexstring displaying rows and columns of hex
for($i=0;$i<length($_[0]);$i=$i+2)
{
$hexstring = $hexstring . substr($_[0],$i,2) . " ";
my $tmp = $self->match(@ascii_table,substr($_[0],$i,2));
if($tmp eq "") {$tmp = "[?]";}
$ascstring = $ascstring . $tmp;
$count++;
if($count > $perline)
{
#print(" $hexstring ", $self->fixascii($ascstring),"\n");
print(" $hexstring ",$ascstring,"\n");
$hexstring = "";
$ascstring = "";
$count=0;
}
}
# Display last line.
if($hexstring ne "")
{
# print(" $hexstring ",$self->fixascii($ascstring),"\n");
print(" $hexstring ",$ascstring,"\n");
}
}
###########################################################################
sub old
{
# Option, Length Data
# This function takes a hexstring and splits out options, lengths and data
# and returns them in a list.
# Format of returned array elements:
# option::length::data
# initialize variables
my $self = shift;
my @optionlist;
my ($string) = @_;
my $count = 0;
my $option = "";
my $length = "";
my $declength = "";
my $data = "";
# Cycle thru string chopping off the beginning as it is parsed
while($string ne "")
{
$option = substr($string,0,2);
$length = substr($string,2,2);
$declength = $self->hex2dec($length);
$data = substr($string,4,($declength-2)*2);
$string = substr($string,$declength*2,
length($string)-length($declength*2));
# Build array element
$optionlist[$count] = join("::",($option,$length,$data));
$count=$count+1; # increment count
}
return @optionlist; # return array of options
}
###########################################################################
sub buster {
# Returns a :: delimated string containing general
# packet information such
# as code, ID, length and packet data.
my $self = shift;
my $code = substr($_[0],0,2);
my $id = substr($_[0],2,2);
my $length = substr($_[0],4,4);
my $data = substr($_[0],8,length($_[0])-6);
# Return header information
return(join("::",($code,$id,$length,$data)));
}
###########################################################################
sub hex2dec {
my $self = shift;
# Converts passed value from decimal to hex
return hex($_[0]);
}
###########################################################################
sub hex2ip
{
# Converts hex string into a dotted decimal IP address
my $self = shift;
my $return = "";
$return = $self->hex2dec( substr($_[0],0,2)). "." . $self->hex2dec( substr($_[0],2,2)) . "." . $self->hex2dec(substr($_[0],4,2)).".".$self->hex2dec(substr($_[0],6,2));
}
###########################################################################
sub hex2asc
{
# Converts hex string into ascii byte by byte
my $self = shift;
my $i = "0";
my $retval = "";
# Cycle thru string two bytes at a time.
for($i=0;$i<length($_[0]);$i=$i+2)
{
$retval = $retval.sprintf("%c",hex(substr($_[0],$i,2)));
}
return($retval);
}
###########################################################################
sub showhex
{
# Build formatted hex string to be displayed with spaces between bytes
my $self = shift;
my $retval = "";
my $i = 0;
my $count = 0;
my $perline = 22;
for($i=0;$i<length($_[0]);$i=$i+2)
{
$retval = $retval.substr($_[0],$i,2)." ";
if($count > $perline)
{
$retval = $retval."\n";
$count = 0;
}
$count++;
}
return($retval);
}
###########################################################################
sub fixascii
{
my $self = shift;
my $string = $_[0];
my $char = "";
my $retval = "";
my $i = 0;
my $padchar = " ";
my $printable = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890~!@#$%^&*()_+`-=[]\\{}|;':\",.<>/?";
for($i=0;$i<length($string);$i++)
{
$char = substr($string,$i,1);
if(index($printable,$char) != -1)
{
$retval = $retval.$char;
}
else
{
$retval = $retval."X";
}
}
return($retval);
}
###########################################################################
sub ishex
{
# Determines is passed string is a hex string
my $self = shift;
$_ = substr($_[0],0,2);
if((tr/a-fA-F0-9 /a-fA-F0-9 / eq "2") && substr($_[0],2,1) eq " ") {
return(1); # Returns a 1 for true if string is hex
}
else {
return(0); # Returns a 0 for false if string is not hex
}
}
###########################################################################
sub clean
{
my $self = shift;
my ($hexstring) = @_;
# Cleans up hex string before parsing
$hexstring =~ s/ //g; # remove spaces
$hexstring =~ s/\n$//g; # remove newlines
$hexstring =~ tr/a-z/A-Z/; # capitalize everything
$hexstring =~ tr/A-F,0-9//cd;
return($hexstring);
}
###########################################################################
sub match {
# Return a matching value in array
# We receive an array.
# Last element of array is the item to matched against.
# initialize variables
my ($self) = shift;
my (@array) = @_;
my $retval = "";
my $count = 0;
my $string = "";
my $desc = "";
# cycle thru array searching for match
for($count=0;$count<@array-1;$count++)
{
($string, $desc) = split(/::/,$array[$count]);
if($string eq $array[@array-1])
{
$retval = $desc; # set description to retrun value
$count = @array; # terminate loop
}
}
# pad returned strings with a space for output formatting
if(length($retval)>0)
{
$retval = $retval." ";
}
return($retval); # return description to calling function
}
###########################################################################
sub parseMRRU
{
my $self = shift;
my $option = $_[0];
my $MRRU = substr($_[0],0,4);
print( " Max-Receive-Reconstructed-Unit (MRRU): ",
hex($MRRU)," bytes.\n" );
}
###########################################################################
sub parseendpoint
{
my $self = shift;
my $class = substr($_[0],0,2);
my $address = substr($_[0],2,length($_[0])-2);
print(" Class [0x$class]: ",
$self->match(@TEK::PM::endpointclass,$class)," ");
if($class eq "02")
{
print($self->hex2ip($address));
}
# Public Switched Network DN
elsif($class eq "05")
{
print("= ", $self->hex2asc($address));
}
elsif($class eq "00")
{
print("Null Address");
}
else
{
print( $self->showhex($address));
}
print("\n");
}
###########################################################################
sub argument
{
my $self = shift;
my (@arglist) = @_;
# Check Arguments
if($_[0] eq "")
{
print("No file name provided.\n");
die("Usage: dring [filename]\n");
}
return($_[0]); # Return filename
}
###########################################################################
sub checkparseflags
{
my $self = shift;
my ($line) = $_[0];
my $retval = 0;
if( index($line,$TEK::PM::PAPFLAG) != -1 ||
index($line,$TEK::PM::IPCPFLAG) != -1 ||
index($line,$TEK::PM::LCPFLAG) != -1 ||
index($line,$TEK::PM::CHAPFLAG) != -1 ||
index($line,$TEK::PM::UNFLAG) != -1 ||
index($line,$TEK::PM::CRCFLAG) != -1 ||
index($line,$TEK::PM::IPXFLAG) )
{
$retval = 1;
}
return $retval;
}
######################################################################
######################################################################
######################################################################
######################################################################
######################################################################
package main;
use strict;
#use TEK::PM;
use Getopt::Long;
use Term::ReadLine;
$| = 1;
my $host = "<your-default-host-here";
my $user = "!root";
my $password = "<your-!root-password-here";
my @exempt = ("user1", "user2", "user3");
my $result = GetOptions("host=s" => \$host);
my $cmd = shift;
my $arg = shift;
my $pm = new TEK::PM($host, $user, $password);
######################################################################
sub run($)
{
my ($sub) = @_;
$pm->open;
&$sub;
$pm->close;
}
######################################################################
if ($cmd =~ /^w(ho(son)?)?$/) { run sub { print $pm->whoson($arg) }; }
elsif ($cmd eq "kick") { run sub { print $pm->kick($arg) }; }
elsif ($cmd eq "reset") { run sub { print $pm->reset($arg) }; }
elsif ($cmd eq "debug") { run sub { $pm->debug() }; }
elsif ($cmd eq "debugv") { run sub { $pm->debug(1) }; }
elsif ($cmd eq "snoop") { run sub { $pm->snoop($arg) }; }
elsif ($cmd eq "tcpdump") { run sub { $pm->tcpdump($arg) }; }
elsif ($cmd eq "login") { pmlogin(); }
elsif ($cmd eq "multiboot")
{
run sub { $pm->multi_login_kick(@exempt) };
}
elsif ($cmd eq "command" or $cmd eq "cmd")
{
run sub { print "\n", $pm->sendCommand(join(' ', $arg, @ARGV)), "\n" };
}
else
{
print <<EOF;
Usage: pm [-host <portmaster-name>] command
Where command is one of the following:
w | who | whoson [<user>]
kick <user>
snoop <user>
tcpdump <user>
cmd | command <pm command>
reset <port>
debug
login
EOF
;
}
######################################################################
sub pmlogin
{
local $SIG{INT} = 'IGNORE';
my $term = new Term::ReadLine 'pm';
my $prompt = $pm->open_manual;
my $bad = 0;
@ARGV = ();
while (1)
{
if ($bad == 3)
{
$pm->close;
return;
}
if ($user)
{
$prompt = $pm->username($user);
}
else
{
print $prompt;
my $login = <>;
chomp $login;
$prompt = $pm->username($login);
next if $prompt =~ /login:/;
}
if ($password)
{
$prompt = $pm->password($password);
}
else
{
print $prompt;
system "stty -echo";
my $password = <>;
chomp $password;
print "\n";
system "stty echo";
$prompt = $pm->password($password);
}
last if $prompt !~ /login/;
undef $user;
undef $password;
$bad++;
}
while (defined ($_ = $term->readline($prompt)))
{
print $pm->sendCommand($_);
last if $_ eq 'exit' or $_ eq 'quit';
}
print "\n" unless $_ eq 'exit' or $_ eq 'quit';
}
----------cut here-----------
-
To unsubscribe, email 'majordomo@livingston.com' with
'unsubscribe portmaster-users' in the body of the message.