scottk/wlan-lanforge-scripts
1
0
Fork 0
mirror of https://github.com/Telecominfraproject/wlan-lanforge-scripts.git synced 2025-10-30 18:27:53 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
0f4e71e17b139d78ce242140db8a2555a2871563
wlan-lanforge-scripts/LANforge/Utils.pm
Jed Reynolds d16c42603f Utils: fixes some number parsing
2020-03-23 22:01:30 -07:00

1160 lines
31 KiB
Perl
Raw Blame History

package LANforge::Utils;
use strict;
use warnings;
use Carp;
use Net::Telnet;
$| = 1;
#$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
#$SIG{ __WARN__ } = sub { Carp::confess( @_ ) };
if ($ENV{DEBUG}) {
use Data::Dumper;
}
##################################################
## the object constructor ##
## To use: $ep = LANforge::Utils->new(); ##
## or: $ep2 = $ep->new(); ##
##################################################
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
$self->{telnet} = undef;
$self->{cli_send_silent} = 0;
$self->{cli_rcv_silent} = 0;
$self->{error} = "";
$self->{async_waitfor} = '/btbits>> $/';
$self->{prompt} = '/btbits>> $/';
bless( $self, $class );
return $self;
}
sub connect {
my ($self, $host, $port) = @_;
my $t = new Net::Telnet(Prompt => '/btbits>> $/',
Timeout => 30);
$self->{telnet} = \$t;
$t->open(Host => $host,
Port => $port,
Timeout => 20);
$t->max_buffer_length(16 * 1024 * 1000); # 16 MB buffer
$t->waitfor($self->{prompt});
$t->print("set_flag brief 0"); # If we leave it brief, RSLT prompt is not shown.
$t->waitfor($self->{prompt});
if ($self->isQuiet()) {
if (defined $ENV{'LOG_CLI'} && $ENV{'LOG_CLI'} ne "") {
$self->cli_send_silent(0);
$self->log_cli("# $0 ".`date "+%Y-%m-%d %H:%M:%S"`);
}
else {
$self->cli_send_silent(1); # Do not show input to telnet
}
$self->cli_rcv_silent(1); # Repress output from telnet
}
else {
$self->cli_send_silent(0); # Show input to telnet
$self->cli_rcv_silent(0); # Show output from telnet
}
return ${$self->{telnet}};
}
sub telnet {
my $self = shift;
die("Utils::telnet -- telnet object undefined")
if (!(defined $self->{telnet}));
my $t = ${$self->{telnet}};
$t->max_buffer_length(50 * 1024 * 1024);
$t->print("\n");
$t->waitfor($self->{prompt});
return $t;
}
# This submits the command and returns the success/failure
# of the command. If the results from the command are not
# immediately available (say, if LANforge needs to query a remote
# resource for endpoint stats, then that results may NOT be
# in the returned string. In that case, you must wait for the
# prompt to be seen, so use the doAsyncCmd below instead.
# doCmd is good for rapidly doing lots of configuration without
# waiting for each step (port creation, for example) to fully
# complete.
sub doCmd {
my $self = shift;
my $cmd = shift;
#print "CMD[[$cmd]]\n";
my $t = ${$self->{telnet}};
if ( !$self->cli_send_silent() || (defined $ENV{'LOG_CLI'} && $ENV{'LOG_CLI'} ne "")) {
$self->log_cli($cmd);
}
$t->print($cmd);
my @rslt = $t->waitfor('/ >>RSLT:(.*)/');
if ( !$self->cli_rcv_silent() ) {
print "**************\n@rslt\n................\n\n";
}
return join( "\n", @rslt );
}
# This will wait for the prompt, not just for the results.
# Use this instead of doCmd if you are unsure.
sub doAsyncCmd {
my $self = shift;
my $cmd = shift;
my $t = ${$self->{telnet}};
my @rv = ();
if ( !$self->cli_send_silent() || (defined $ENV{'LOG_CLI'} && $ENV{'LOG_CLI'} ne "")) {
$self->log_cli($cmd);
}
$t->print($cmd);
my @rslt = $t->waitfor('/ \>\>RSLT:(.*)/');
my @rslt2 = $t->waitfor( $self->async_waitfor() );
@rv = (@rslt, @rslt2);
if ( !$self->cli_rcv_silent() ) {
print "**************\n @rv \n................\n\n";
}
return join( "\n", @rv );
} # ~doAsyncCmd
sub normalize_bucket_hdr {
my $self = shift;
my $amt = shift;
my $rv = "Min Max Avg ";
my $i;
for ($i = 0; $i<$amt; $i++) {
if ($i == 0) {
$rv .= "0 ";
}
elsif ($i == 1) {
$rv .= "1 ";
}
else {
$rv .= 2**($i-1) . "-" . (2**($i) - 1) . " ";
}
}
return $rv;
}
# Normalize lat1, taking peer latency (lat2) into account for negative latency and such.
sub normalize_latency {
my $self = shift;
my $lat1 = shift;
my $lat2 = shift;
#print "lat1 -:$lat1:-\n";
#print "lat2 -:$lat2:-\n";
my $min1 = 0;
my $min2 = 0;
# Looks like this: 5 -:5:- 6 [ 17 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ] (1)
if ($lat1 =~ /(\S+)\s+-:(\S+):-\s+(\S+)\s+\[\s+(.*)\s+\]\s+\((\S+)\)/) {
$min1 = $1;
}
if ($lat2 =~ /(\S+)\s+-:(\S+):-\s+(\S+)\s+\[\s+(.*)\s+\]\s+\((\S+)\)/) {
$min2 = $1;
}
# For instance, min1 is -5, min2 is 25, rt-latency is 20.
# Adjust lat1 by (25 - -5) / 2
# For instance, min1 is 25, min2 is -5, rt-latency is 20.
# Adjust lat1 by (-5 -25) / 2
#print "min1: $min1 min2: $min2 half: " . int(($min2 - $min1) / 2) . "\n";
# So, the above seems nice, but often we have a small negative value due to
# clock drift in one direction, and large latency in the other (due to real one-way latency)
# So, we will just adjust enough to make the smallest value positive.
my $adjust = 0;
if ($min1 < 0) {
$adjust = -$min1;
}
elsif ($min2 < 0) {
$adjust = $min2;
}
return $self->normalize_bucket($lat1, $adjust);
}
sub normalize_bucket {
my $self = shift;
my $line = shift;
my $adjust = shift;
#print "line -:$line:-\n";
# Looks like this: 5 -:5:- 6 [ 17 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ] (1)
if ($line =~ /(\S+)\s+-:(\S+):-\s+(\S+)\s+\[\s+(.*)\s+\]\s+\((\S+)\)/) {
my $min = $1;
my $avg = $2;
my $max = $3;
my $bks = $4;
my $width = $5; # Assumes one currently
if (!($width eq "1")) {
return $line;
}
else {
my @bkts = split(/\s+/, $bks);
@bkts = (@bkts, "0");
my $i;
my $rv = ($min + $adjust) . " " . ($max + $adjust) . " " . ($avg + $adjust) . " ";
#print "bkts len: " . @bkts . "\n";
my @nbkts = (0) x (@bkts);
for ($i = 0; $i<@bkts; $i++) {
# Figure out the bkt range
my $minv = 0;
my $maxv = 2 ** $i - 1;
if ($i > 0) {
$minv = 2 ** ($i - 1);
}
# Adjust by the min value, which is treated as an offset
$minv += $min;
$maxv += $min;
# And adjust based on round-trip time to deal with clock lag
$minv += $adjust;
$maxv += $adjust;
# And now find the normalized bucket this fits in
#print "maxv: $maxv\n";
my $z;
my $idx = 0;
for ($z = 0; $z < 32; $z++) {
if ($maxv < (2 ** $z)) {
#print "maxv: $maxv z: $z 2^$z: " . 2 ** $z . + "\n";
$idx = $z;
# Everything else falls in the last bucket
if ($idx >= @bkts) {
$idx = (@bkts - 1);
}
last;
}
}
#print "idx: $idx i: $i minv: $minv maxv: $maxv min: $min adjust: $adjust\n";
#print "nbkts: " . $nbkts[$idx];
#print " bkts: " . $bkts[$i] . "\n";
my $nv = $nbkts[$idx] + $bkts[$i];
@nbkts[$idx] = $nv;
}
for ($i = 0; $i < @nbkts; $i++) {
$rv .= ($nbkts[$i] . " ");
}
return $rv;
}
}
else {
return $line;
}
}
# Uses cached values (so it will show Phantom ones too)
sub getPortListing {
my $self = shift;
my $shelf = shift;
my $card = shift;
my @rv = ();
my $prts = $self->doAsyncCmd( "show_port " . $shelf . " " . $card );
if ( $prts =~ /Timed out waiting for/g ) {
$self->error("Partial Failure: Timed out");
}
my @ta = split( /\n/, $prts );
my $i;
for ( $i = 0 ; $i < @ta ; $i++ ) {
my $ln = $ta[$i];
if ( $ln =~ /Shelf:\s+\d+,\s+Card:\s+\d+,\s+Port:\s+\d+\s+Type/ ) {
my $ptxt;
while ( $ln =~ /\S+/ ) {
$ptxt .= "$ln\n";
$i++;
$ln = $ta[$i];
}
my $p1 = new LANforge::Port();
$p1->decode($ptxt);
@rv = ( @rv, $p1 );
}
}
return @rv;
} #~getPortListing
sub updatePortRetry {
my $self = shift;
return $self->updatePort( shift, shift, shift, shift, shift, 10000 );
}
# Call with args: Port, (these next ones are optional): Shelf-id, Card-id, Port-Id
sub updatePort {
my $self = shift;
my $port = shift;
my $sid = shift; #shelf-id
my $max_retries = undef;
if ( defined($sid) ) {
$port->shelf_id($sid);
$port->card_id(shift);
$port->port_id(shift);
$max_retries = shift;
}
if ( !defined($max_retries) ) {
$max_retries = 10;
}
# Since I use this for testing, I'm going to obliterate the port's data so that
# there will be no question as to whether or not the update worked.
$port->initDataMembers(); #Shouldn't mess with the shelf, card, or port id.
my $cmd =
"nc_show_port "
. $port->shelf_id() . " "
. $port->card_id() . " "
. $port->port_id;
#print "cmd -:$cmd:-\n";
# Use the non-caching port show.
my $prt = $self->doAsyncCmd($cmd);
# There is a small race condition, where one report may be on the way back to the
# main server when the first request is still being sent. So, we'll ask again. This
# one will definately be up to date.
$prt = "";
my $i = 0;
while (1) {
$prt = $self->doAsyncCmd($cmd);
if ( !$self->cli_rcv_silent() ) { # added by Adam - 8/9/2004
print "prt: $prt\n";
}
if ( $i++ > $max_retries ) {
last;
}
if ( ( $prt =~ /Could not find that Port/g )
|| ( $prt =~ /Timed out waiting/g )
|| ( !( $prt =~ /, Port:/g ) ) )
{
sleep(5);
}
else {
last;
}
}
if ( !$self->cli_rcv_silent() ) { # added by Adam - 8/9/2004
print "decoding port -:$prt:-\n";
}
$port->decode($prt);
} #updatePort
sub updateEndpoint {
my $self = shift;
my $endp = shift;
my $name = shift;
my $fast = shift;
if ( defined($name) ) {
$endp->name($name);
}
# Since I use this for testing, I'm going to obliterate the Endpoint's data so that
# there will be no question as to whether or not the update worked.
$endp->initDataMembers(); #Shouldn't mess with the shelf, card, or port id.
my $ep;
if ($fast) {
$ep = $self->doAsyncCmd( "show_endpoint " . $endp->name() );
}
else {
# Use the non-caching endpoint show.
$ep = $self->doAsyncCmd( "nc_show_endpoint " . $endp->name() );
# There is a small race condition, where one report may be on the way back to the
# main server when the first request is still being sent. So, we'll ask again. This
# one will definately be up to date.
$ep = $self->doAsyncCmd( "nc_show_endpoint " . $endp->name() );
}
#print "EP show_endp results for cmd: " . $endp->name() . "\n-:$ep:-\n";
$endp->decode($ep);
if ( $endp->isCustom() ) {
$ep = $self->doCmd( "show_endp_pay " . $endp->name() . " 5000" );
$endp->decodePayload($ep);
}
} #updateEndpoint
sub log_cli {
my $self = shift;
my $cmd = shift;
my $using_stdout = 0;
#print "utils::log_cli: $ENV{'LOG_CLI'}\n";
if (defined $ENV{'LOG_CLI'} && $ENV{'LOG_CLI'} ne "") {
if ($ENV{'LOG_CLI'} =~ /^--/) {
die("Incorrect format for LOG_CLI, it should be '1' or filename like '/tmp/cmdlog.txt'");
}
if ($ENV{'LOG_CLI'} eq "1" || $ENV{'LOG_CLI'} =~ /STDOUT/i) {
$using_stdout = 1;
#print "STDOUT utils::log_cli: $ENV{'LOG_CLI'}\n";
}
else { # write to a file
if ( ! -f $ENV{'LOG_CLI'}) {
print "Creating new file $ENV{'LOG_CLI'}\n";
`touch $ENV{'LOG_CLI'}`;
chmod(0666, $ENV{'LOG_CLI'});
}
if ( -w $ENV{'LOG_CLI'}) {
open(my $fh, ">>", $ENV{'LOG_CLI'});
if (defined $fh) {
#print "FILE utils::log_cli: \n";
print $fh "$cmd\n";
close $fh;
}
else {
warn ("$ENV{'LOG_CLI'} not writable");
$using_stdout=1;
#print "ELSE STDOUT utils::log_cli: $ENV{'LOG_CLI'}\n";
}
}
}
}
if ($using_stdout == 1 || !isQuiet() ) {
print qq(\nCMD: \"$cmd\"\n);
}
}
# returns 1 if we're quiet, 0 if we're verbose
# if $::quiet is undefined, we assume verbose
sub isQuiet {
my $self = shift;
return 0
if (! defined $::quiet);
if (length( do { no warnings "numeric"; $::quiet & "" } )) {
# we're numeric
if ($::quiet != 0) {
#print "numeric and quiet [$::quiet]\n";
return 1;
}
#print "numeric and verbose [$::quiet]\n";
return 0;
}
# else we're textual
if ($::quiet =~ /(1|yes|on)/i) {
#print "textual and quiet [$::quiet]\n";
return 1;
}
#print "textual and verbose [$::quiet]\n";
return 0;
}
sub async_waitfor {
my $self = shift;
if (@_) { $self->{async_waitfor} = shift }
return $self->{async_waitfor};
}
sub error {
my $self = shift;
if (@_) { $self->{error} = shift }
return $self->{error};
}
sub cli_rcv_silent {
my $self = shift;
if (@_) { $self->{cli_rcv_silent} = shift }
return $self->{cli_rcv_silent};
}
sub cli_send_silent {
my $self = shift;
if (@_) { $self->{cli_send_silent} = shift }
return $self->{cli_send_silent};
}
sub fmt_cmd {
#print Dumper(@_);
my $self = shift;
my $rv;
my $mod_hunk;
my $show_err = 0;
my $item = 1;
my $prev_item;
for my $hunk (@_) {
if (defined $hunk && $hunk eq '') {
print STDERR "\nfmt_cmd() arg $item blank, converting to NA\n";
print STDERR " prev argument was [$prev_item]\n" if (defined $prev_item);
$show_err = 1;
}
die("rv[${rv}]\n --> fmt_cmd passed an array, bye.") if (ref($hunk) eq 'ARRAY');
die("rv[${rv}]\n --> fmt_cmd passed a hash, bye.") if (ref($hunk) eq 'HASH');
$mod_hunk = $hunk;
$mod_hunk = "0" if ($hunk eq "0" || $hunk eq "+0");
if( $hunk eq "" ) {
#print "hunk[".$hunk."] --> ";
$mod_hunk = 'NA';
#print "hunk[".$hunk."]\n";
#print "fmt_cmd: warning: hunk was blank, now NA. Prev hunks: $rv\n"
}
$prev_item = $hunk;
$item++;
$rv .= ( $mod_hunk =~m/ +/) ? "'$mod_hunk' " : "$mod_hunk ";
}
if (rindex($rv, ' ', length($rv)-2) > 1) {
#print STDERR "[$rv]\n";
$rv =~ s/\s+$//g;
#print STDERR "[$rv]\n";
}
print STDERR qq(\nFormatted cmd: "$rv"\n) if ($show_err or $::quiet ne "yes");
return $rv;
}
##
## Check if usleep() exists
##
our $has_usleep = 0;
if (defined &usleep) {
print("I see usleep\n");
$LANforge::Utils::has_usleep=1;
}
sub sleep_ms {
my $self;
my $millis = 0;
if (@_ > 1) {
($self, $millis) = @_;
}
else {
$millis = pop(@_);
}
return if (!(defined $millis) || ($millis == 0));
my $secs = $millis / 1000;
if ($LANforge::Utils::has_usleep) {
usleep($millis);
}
else {
select(undef, undef, undef, $secs);
}
}
sub sleep_sec {
my $self;
my $secs = 0;
if (@_ > 1) {
($self, $secs) = @_;
}
else {
($secs) = @_;
}
return if (!(defined $secs) || ($secs == 0));
if ($LANforge::Utils::has_usleep) {
usleep($secs);
}
else {
select(undef, undef, undef, $secs);
}
}
##
## Returns ref to map of all stations maching a parent device
## EG: $rh_eid_map = $u->get_eid_map($::resource)
##
sub get_eid_map {
my ($self, $resource) = @_;
my $rh_eid_map = {};
my @ports_lines = split(/\r?\n/, $self->doAsyncCmd("nc_show_ports 1 $resource all"));
chomp(@ports_lines);
my ($eid, $card, $port, $type, $mac, $dev, $parent, $ip);
foreach my $line (@ports_lines) {
# collect all stations on that radio add them to @interfaces
if ($line =~ /^Shelf: /) {
$card = undef; $port = undef;
$type = undef; $parent = undef;
$eid = undef; $mac = undef;
$dev = undef;
$ip = undef;
}
# careful about that comma after card!
# NO EID for Shelf: 1, Card: 1, Port: 2 Type: WIFI-Radio Alias:
($card, $port, $type) = $line =~ m/^Shelf: 1, Card: (\d+),\s+Port: (\d+)\s+Type: (\w+)/;
if ((defined $card) && ($card ne "") && (defined $port) && ($port ne "") && ($type ne "VRF")) {
$eid = "1.".$card.".".$port;
my $rh_eid = {
eid => $eid,
type => $type,
parent => undef,
dev => undef,
};
$rh_eid_map->{$eid} = $rh_eid;
}
#elsif ($line =~ /^Shelf/) {
# #print "NO EID for $line\n";
#}
if (!(defined $eid) || ($eid eq "")) {
#print "NO EID for $line\n";
next;
}
($mac, $dev) = $line =~ / MAC: ([0-9:a-fA-F]+)\s+DEV: (\S+)/;
if ((defined $mac) && ($mac ne "")) {
#print "$eid MAC: $line\n";
$rh_eid_map->{$eid}->{mac} = $mac;
$rh_eid_map->{$eid}->{dev} = $dev;
}
($parent) = $line =~ / Parent.Peer: (\S+) /;
if ((defined $parent) && ($parent ne "")) {
#print "$eid PARENT: $line\n";
$rh_eid_map->{$eid}->{parent} = $parent;
}
($ip) = $line =~ m/ IP: *([^ ]+) */;
if ((defined $ip) && ($ip ne "")) {
#print "$eid IP: $line\n";
$rh_eid_map->{$eid}->{ip} = $ip;
}
} # foreach
#foreach $eid (keys %eid_map) {
# print "eid $eid ";
#}
return $rh_eid_map;
}
##
## retrieve an eid/name record by name using a refrence
## to an eid_map
##
sub find_by_name {
my ($self, $rh_eid_map, $devname) = @_;
while (my ($eid, $rh_rec) = each %{$rh_eid_map}) {
#print "fbn: ".$rh_rec->{dev}."\n";
if ((defined $rh_rec->{dev}) && ($rh_rec->{dev} eq $devname)) {
return $rh_rec;
}
}
return -1;
}
##
## retrieve ports on radio from EID map
## EG: $ra_interfaces = $u->ports_on_radio($rh_eid_map, $radio_name);
##
sub ports_on_radio {
my ($self, $rh_rec2_map, $radio) = @_;
my $ra_ifs = [];
#print "PARENT IS $radio\n";
foreach my $rh_rec2 (values %{$rh_rec2_map}) {
next if (!(defined $rh_rec2->{parent}));
#print "\npor: ".$rh_rec2->{parent}.">".$rh_rec2->{dev}."\n";
if ($rh_rec2->{parent} eq $radio) {
#print $rh_rec2->{dev}."<-".$rh_rec2->{parent}." ";
my $devn = $rh_rec2->{dev};
push(@$ra_ifs, $devn);
}
}
return $ra_ifs;
}
sub test_groups {
my ($self) = @_;
my @group_lines = split(/\r?\n/, $self->doAsyncCmd("show_group all"));
sleep_ms(30);
#print Dumper(\@group_lines);
my @matches = grep {/TestGroup name:\s+/} @group_lines;
#print Dumper(\@matches);
my $ra_group_names = [];
for my $line (@matches) {
push(@$ra_group_names, ($line =~ /TestGroup name:\s+(\S+)\s+\[/));
}
#print Dumper($ra_group_names);
return $ra_group_names;
}
##
sub group_items {
my ($self, $tg_name) = @_;
die("Utils::group_items wants a test group name, bye.")
if (!(defined $tg_name) || ("" eq $tg_name));
my @lines = split(/\r?\n/, $self->doAsyncCmd( "show_group '$tg_name'"));
sleep_ms(30);
my $ra_items = [];
my $started = 0;
foreach my $line (@lines) {
$started ++ if ($line =~ /\s*Cross Connects:/);
next unless ($started);
last if ($line =~ /^\s*$/);
$line =~ s/^\s*Cross Connects:\s*//;
$line =~ s/^\s+//;
$line =~ s/\s+$//;
my @hunks = split(/\s+/, $line);
push(@$ra_items, split(/\s+/, $line));
}
if (@$ra_items < 1) {
print STDERR "No cross connects found for test group $tg_name.\n";
return [];
}
return $ra_items;
}
# Generic disassembly of lines created by show
our @starting_exceptions = (
# please keep these sorted
"Command:",
"Conn Established:",
"Conn Timeouts:",
"Cx Detected:",
"DNS Servers:",
"Endpoint [",
"GenericEndp [",
"Latency:",
"Pkt-Gaps:",
"Results[",
">>RSLT:",
"Rx Bytes:",
"Rx Bytes (On Wire):",
"Rx Duplicate Pkts:",
"Rx OOO Pkts:",
"Rx Pkts:",
"Rx Pkts (On Wire):",
"RX-Silence:",
"Shelf: 1,",
"TCP Retransmits:",
"Tx Bytes:",
"Tx Bytes (On Wire):",
"Tx Failed Bytes:",
"Tx Failed Pkts:",
"Tx Pkts:",
"Tx Pkts (On Wire):",
"Tx-Retries:",
);
# Generic disassembly of lines created by show
our @port_starting_exceptions = (
# please keep these sorted
"Advertising:",
"Current:",
"Missed-Beacons:",
"Partner:",
"Supported:",
"Tx-Excessive-Retry:",
"Rx-Invalid-CRYPT:",
"Rx-Invalid-MISC:",
);
our @one_line_keys = (
"Latency:",
"Pkt-Gaps:",
"RX-Silence:",
"Cx Detected:",
);
#
# examples of using this:
# $rh = u->show_as_hash($txt)
# $rh = u->show_as_hash(\$txt)
# $rh = u->show_as_hash(split(/\n/, $txt))
# $rh = u->show_as_hash(\@lines)
#
sub show_as_hash {
my ($self, $in, $isport) = (undef, undef, 0);
if (@_ > 1) {
($self, $in, $isport) = @_;
}
else {
$in = pop(@_);
}
my @lines = ();
# this allows us to pass in \$txt, split(/\n/, $txt) or just $txt
if ((ref $in) eq "") {
@lines = split(/\r?\n/, $in);
}
elsif ((ref $in) eq "SCALAR") {
@lines = split(/\r?\n/, $$in);
}
elsif ((ref $in) eq "ARRAY") {
@lines = @$in;
}
#print "show_as_hash, isport: $isport\n";
my $rh_pairs = {};
my @special = ();
# https://stackoverflow.com/questions/31724503/most-efficient-way-to-check-if-string-starts-with-needle-in-perl
my $key = undef;
my $value = undef;
my @hunks = ();
my $prefix = "";
#print Dumper(\@lines);
chomp(@lines);
my $found_start_x = 0;
foreach my $line (@lines) {
if ($isport) {
#print "Port line -:$line:-\n";
foreach my $start (@LANforge::Utils::port_starting_exceptions) {
# we purposefully are not wasting time trimming whitespace
my $i = index($line, $start);
if ($i >= 0) {
push(@special, $line);
$found_start_x++;
last;
}
}
}
else {
foreach my $start (@LANforge::Utils::starting_exceptions) {
# we purposefully are not wasting time trimming whitespace
my $i = index($line, $start);
if ($i >= 0) {
push(@special, $line);
$found_start_x++;
last;
}
}
}
if ($found_start_x) {
$found_start_x = 0;
next;
}
if ($isport) {
#print "line -:$line:-\n";
if ($line =~ /^\s+\[Configured\]/) {
#print "Prefix to cfg\n";
$prefix = "Cfg";
next;
}
if ($line =~ /^\s+\[Probed\]/) {
$prefix = "Probed";
next;
}
$line =~ s/ (dbm|[kmg]?bps)/$1/ig;
$line =~ s/DNS Servers/DNS-Servers/ig;
$line =~ s/TX Queue Len/TX-Queue-Len/ig;
$line =~ s/Missed Beacons/Missed-Beacons/ig;
#print "$i: ".$lines[$i]."\n";
}
# at this point, every line should be split using colons and spaces
@hunks = split(/\s+/, $line);
foreach my $hunk (@hunks) {
if (rindex($hunk, ':') == length($hunk)-1) {
$key = substr($hunk, 0, rindex($hunk, ':'));
next;
}
$value = $hunk;
if ((defined $key) && ("" ne $key)) {
my $val = (defined $value) ? $value : "";
#print "Adding key -:$key:- val -:$val:-\n";
$rh_pairs->{$key} = $val;
if ($prefix ne "") {
#print "Adding prefixed key -:$prefix-$key:- val -:$val:-\n";
$rh_pairs->{"$prefix-$key"} = $val;
}
$key = undef;
$value = undef;
}
}
}
@hunks = ();
$key = undef;
$value = undef;
foreach my $line (@special) {
#print "\nspecial: $line";
my $rh_vals = undef;
# special cases for certain lines
if (index($line, '>>RSLT:') >= 0) {
$rh_vals = {
'Cmd' => substr($line, index($line, 'Cmd:')+5),
'RSLT' => substr($line, index($line, ':')+2, (index($line, ' Cmd:') - index($line, ':')-3)),
};
foreach my $subkey (keys %$rh_vals) {
$rh_pairs->{$subkey} = $rh_vals->{$subkey}
}
#$rh_pairs->{"RSLT"} = $rh_vals;
#print Dumper($rh_pairs->{"RSLT"});
$rh_vals = undef;
$key = undef;
$value = undef;
next;
}
if (index($line, 'Endpoint [') >= 0) {
my $flags = substr($line, index($line, '(')+1, -1); # split(/\s+/,
my $name = substr($line, index($line, '[')+1, index($line, ']') - index($line, '[')-1);
$rh_vals = {
'Endpoint-name' => $name,
'Endpoint-flags' => $flags,
};
foreach my $subkey (keys %$rh_vals) {
$rh_pairs->{$subkey} = $rh_vals->{$subkey}
}
#$rh_pairs->{"Endpoint"} = $rh_vals;
$rh_vals = undef;
$key = undef;
$value = undef;
next;
}
if (index($line, 'Shelf: 1,') >= 0) {
$line =~ s/1,/1/;
if ($line =~ /Endpoint/ ) {
my ($card, $port, $endpoint, $eptype, $patt ) =
$line =~ /Shelf:\s+1\s+Card:\s+(\d+)\s+Port:\s+(\S+)\s+Endpoint:\s+(\S+)\s+Type:\s+(\S+)\s+Pattern:\s+(\S+)$/;
$rh_pairs->{Shelf} = 1;
$rh_pairs->{Card} = $card;
$rh_pairs->{Resource} = $card;
$rh_pairs->{Port} = $port;
$rh_pairs->{Endpoint} = $endpoint;
$rh_pairs->{Type} = $eptype;
$rh_pairs->{Pattern} = $patt;
}
}
my $found_oneline = 0;
foreach my $keyv (@LANforge::Utils::one_line_keys) {
if (index($line, $keyv) >= 0) {
$found_oneline++;
if (rindex($keyv, ':') >= 1) {
$keyv = substr($keyv, 0, rindex($keyv, ':'));
}
$rh_pairs->{$keyv} = substr($line, index($line, ":")+2);
last;
}
next if ($found_oneline);
}
# This is parsing bucket counters, maybe more
my $i = index($line, ':');
$key = substr($line, 0, $i);
$key =~ s/^\s*//g;
$value = substr($line, $i+1);
$rh_pairs->{$key} = $value; # Add full line to hash
$value =~ s/^\s*//g;
@hunks = split(/\s+/, $value);
$rh_vals = $self->hunks_to_hashes($key, \@hunks);
foreach my $subkey (keys %$rh_vals) {
my $val = $rh_vals->{$subkey};
#print("Adding subkey -:$subkey:- val -:$val:-\n");
$rh_pairs->{$subkey} = $val;
}
$rh_vals = undef;
$key = undef;
$value = undef;
}
# Add some common short-hand actions that we supported in the past.
my $val;
$val = $rh_pairs->{"Rx-Pkts-Per-Sec"};
if (defined($val)) {
$rh_pairs->{"rx_pps"} = $val;
}
$val = $rh_pairs->{"Tx-Pkts-Per-Sec"};
if (defined($val)) {
$rh_pairs->{"tx_pps"} = $val;
}
$val = $rh_pairs->{"Rx-Pkts-Total"};
if (defined($val)) {
$rh_pairs->{"rx_pkts"} = $val;
$rh_pairs->{"Rx Pkts"} = $val;
$rh_pairs->{"Rx-Pkts"} = $val;
}
$val = $rh_pairs->{"Tx-Pkts-Total"};
if (defined($val)) {
$rh_pairs->{"tx_pkts"} = $val;
$rh_pairs->{"Tx Pkts"} = $val;
$rh_pairs->{"Tx-Pkts"} = $val;
}
$val = $rh_pairs->{"Rx-Bytes-bps"};
if (defined($val)) {
$rh_pairs->{"rx_bps"} = $val;
}
$val = $rh_pairs->{"Tx-Bytes-bps"};
if (defined($val)) {
$rh_pairs->{"tx_bps"} = $val;
}
$val = $rh_pairs->{"Rx-Bytes-Total"};
if (defined($val)) {
$rh_pairs->{"Rx-Bytes"} = $val;
$rh_pairs->{"Rx Bytes"} = $val;
}
$val = $rh_pairs->{"Tx-Bytes-Total"};
if (defined($val)) {
$rh_pairs->{"Tx-Bytes"} = $val;
$rh_pairs->{"Tx Bytes"} = $val;
}
#foreach $key (sort keys %$rh_pairs) {
# print "{$key} => $rh_pairs->{$key}\n";
#}
#die("debugging");
return $rh_pairs;
}
sub hunks_to_hashes {
my ($self, $prefix, $input) = (undef, undef, undef);
if (@_ > 2) {
($self, $prefix, $input) = @_;
}
else {
$prefix = shift;
$input = shift;
}
my @hunks = ();
if (ref($input) eq "ARRAY") {
@hunks = @$input;
}
elsif (ref($input) eq "SCALAR") {
@hunks = (@$input);
}
else {
die("Utils::hunks_to_hashes() expects an array");
}
if (index($prefix, ' ') >= 0) {
$prefix =~ s/\s+/-/g
}
my $rh = {};
my $key = undef;
my $value = undef;
foreach my $hunk (@hunks) {
if (rindex($hunk, '/s') >= 1) {
$key = $prefix."-Per-Sec";
$value = substr($hunk, 0, index($hunk, '/s'));
$rh->{$key} = (defined $value) ? $value : "";
# create bps not just Bps
if (index($prefix, "Bytes") >= 1) {
my $bps = (0 + $value) * 8;
$rh->{$prefix."-bps"} = $bps;
}
$key = undef;
$value = undef;
next;
}
if (rindex($hunk, ':') == length($hunk)-1) {
$key = $prefix .'-'. substr($hunk, 0, rindex($hunk, ':'));
next;
}
$value = $hunk;
if ((defined $key) && ("" ne $key)) {
$rh->{$key} = (defined $value) ? $value : "";
if ((index($prefix, "Bytes") >= 1)
&& ((index($key, "Total") >=0 ) || (index($key, "Cur") >=0 ))) {
my $bits = (0 + $value) * 8;
my $nkey = $key;
$nkey =~ s/Bytes/Bits/;
$rh->{$nkey} = $bits;
}
$key = undef;
$value = undef;
}
}
return $rh;
}
sub expand_unit_str {
my ($self, $string) = @_;
die("Utils::expand_unit_str expects string to parse")
if (!(defined $string) || ("" eq $string));
return 0 if ($string =~ /^[0\.]+\s*\w+$/);
my ($num, $suf) = $string =~ /^([\.0-9]+)\s*(\w*)$/;
if (!(defined $num) || ("" eq $num)) {
die("Utils::expand_unit_str exects something like 33Mbps or '33 Mbps', not $string");
}
my $multiplier = 1;
#print "String[$string] => $num Suffix $suf\n";
if (!(defined $suf) || ("" eq $suf)) {
$multiplier = 1;
print STDERR "Utils::expand_unit_str saw no suffix in [$string]\n";
}
elsif ($suf =~ /^bps$/i) {
$multiplier = 1;
}
elsif ($suf =~ /^kbps$/i) {
$multiplier = 1000;
}
elsif ($suf =~ /^mbps$/i) {
$multiplier = 1000 * 1000;
}
elsif ($suf =~ /^gbps$/i) {
$multiplier = 1000 * 1000 * 1000;
}
return int($num) * $multiplier;
}
####
1;
__END__
=head1 NAME
Port - class to implement various LANforge utility and helper functions.
=head1 SYNOPSIS
use LANforge::Utils
#################
# class methods #
#################
$ob = LANforge::Utils->new;
#######################
# object data methods #
#######################
### get versions ###
$telnet = $ob->telnet();
### set versions ###
$ob->telnet($t);
########################
# other object methods #
########################
$ob->doCmd("$Some CLI command\n");
$ob->doAsyncCmd("$Some Asynchronous CLI command\n");
=head1 DESCRIPTION
The Utils class gives you some powerful and packaged access to various
LANforge CLI objects.
=head1 AUTHOR
Ben Greear (greearb@candelatech.com)
Copyright (c) 2020 Candela Technologies. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=end
Reference in New Issue View Git Blame Copy Permalink