File Coverage

blib/lib/RAS/HiPerARC.pm

Criterion	Covered	Total	%
statement	9	106	8.4
branch	0	30	0.0
condition	0	6	0.0
subroutine	3	10	30.0
pod	7	7	100.0
total	19	159	11.9

## RAS::HiPerARC.pm
### PERL module for accessing a 3Com/USR Total Control HiPerARC
#########################################################

package RAS::HiPerARC;
$VERSION = "1.03";

use strict "subs"; use strict "refs";

# This uses Net::Telnet to connect to the RAS
use Net::Telnet ;

# The name $ras will be used consistently as the
# reference to the RAS::HiPerARC object we're handling

# The constructor method, of course
sub new {
   my($class) = shift ;
   my($ras) = {} ;
   %$ras = @_ ;

   unless ($ras->{hostname}) { warn "ERROR: ", (ref($class) || $class), " - Hostname not specified.\n"; return(); }
   $ras->{'VERSION'} = $VERSION;
   $ras->{prompt} = 'HiPer>> ' unless $ras->{prompt};

   bless($ras, ref($class) || $class);
}


# for debugging - printenv() prints to STDERR
# the entire contents of %$ras
sub printenv {
   my($ras) = shift;
   while (($key,$value) = each(%$ras)) { warn "$key = $value\n"; }
}


# This runs the specified commands on the router and returns
# a list of refs to arrays containing the commands' output
sub run_command {
   my($ras) = shift;
   my(@returnlist);
   my($prompt) = '/' . $ras->{prompt} . '$/';

   while ($command = shift) {
      my($session) = new Net::Telnet;
      $session->errmode("return");
      $session->open($ras->{hostname});
      if ($session->errmsg) {
         warn "ERROR: ",ref($ras)," - Cannot connect to host $ras->{hostname} - ",$session->errmsg,"\n"; return(); }
      $session->login($ras->{login},$ras->{password});
      if ($session->errmsg) {
         warn "ERROR: ",ref($ras)," - Logging in to host $ras->{hostname} - ",$session->errmsg,"\n"; return(); }
      $session->print("\n"); $session->waitfor($prompt);
      if ($session->errmsg) {
         warn "ERROR: ",ref($ras)," - Waiting for command prompt on host $ras->{hostname} - ",$session->errmsg,"\n"; return(); }
      $session->print($command);
      my(@output);

      while (1) {
         $session->print(""); my($line) = $session->getline ;
         if ($session->errmsg) {
            warn "ERROR: ",ref($ras)," - Waiting on output from command \"$command\" on host $ras->{hostname} - ",$session->errmsg,"\n"; return(); }
         if ($line =~ /^$ras->{prompt}$/) { $session->print('quit'); $session->close; last; }

         # After the 1st More prompt, the ARC sends
         # ^M\s{a whole line's worth}^M to clear each line for printing
         $line =~ s/^--More--\s+\015?\s*\015?//;
         # Trim off trailing whitespace
         $line =~ s/\s*$/\n/;

         push(@output, $line);
      }

      shift(@output); # Trim the echoed command
      push(@returnlist, \@output);
   } # end of shifting commands

   # We're returning a list of references to lists.
   # Each ref points to an array containing the returned text
   # from the command, and the list of refs corresponds
   # to the list of commands we were given
   return(@returnlist);
} # end of run_command


# usergrep() - takes a username and returns an array of
# ports on which the user was found
sub usergrep {
   my($ras) = shift;
   my($username) = shift; return() unless $username;
   my($output) = $ras->run_command('list connections');
   my(@ports);

   foreach (@$output) {
      my($port,$user);
      next unless /^slot:\d+\/mod:\d+\s+/;
      $port = unpack("x0 a15", $_) ; $port =~ s/^\s*(\S+)\s*$/$1/;
      $user = unpack("x15 a20", $_); $user =~ s/^\s*(\S+)\s*$/$1/;
      ($user eq $username) && push(@ports,$port);
   }
   return(@ports);
}


# userports() returns a hash of arrays
# keys are the usernames of all users currently connected
# values are arrays of ports that that user in connected on
sub userports {
   my($ras) = shift;
   my($output) = $ras->run_command('list conn');
   my(%userports);

   foreach (@$output) {
      my($port,$user);
      next unless /^slot:\d+\/mod:\d+\s+/;
      $port = unpack("x0 a15", $_) ; $port =~ s/^\s*(\S+)\s*$/$1/;
      $user = unpack("x15 a20", $_); $user =~ s/^\s*(\S+)\s*$/$1/;
      push(@{$userports{$user}},$port);
   }
   return(%userports);
}


# portusage() returns a list: # of ports, list of users
sub portusage {
   my($ras) = shift;
   my($interfaces,$connections) = $ras->run_command('list interfaces','list connections');
   my(@users);

   @$interfaces = grep(/^slot:\d+\/mod:\d+\s+Up\s+Up\s*$/, @$interfaces);

   foreach (@$connections) {
      my($port,$user);
      next unless /^slot:\d+\/mod:\d+\s+/;
      $user = unpack("x15 a20", $_); $user =~ s/^\s*(\S+)\s*$/$1/;
      next if ($user =~ /^\s*$/);
      push(@users,$user);
   }

   return(scalar(@$interfaces),@users);
}


# This does a usergrep() and then disconnects the specified user
sub userkill {
   my($ras) = shift;
   my($username); $username = shift; return() unless $username;
   my(@ports) = $ras->usergrep($username);
   return('') unless @ports;

   my($resetcmd) = "reset modems " . join(',',@ports);
   $ras->run_command($resetcmd);
   return(@ports);
}


#############################################################
1;#So PERL knows we're cool
__END__;