mirror of
https://github.com/Telecominfraproject/wlan-lanforge-scripts.git
synced 2025-11-01 03:07:56 +00:00
Add LANforge perl modules.
This commit is contained in:
Ben Greear
2155
LANforge/Endpoint.pm
Normal file
2155
LANforge/Endpoint.pm
Normal file
File diff suppressed because it is too large
Load Diff
192
LANforge/GuiJson.pm
Normal file
192
LANforge/GuiJson.pm
Normal file
@@ -0,0 +1,192 @@
|
|||||||
|
package LANforge::GuiJson;
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
use JSON;
|
||||||
|
use base 'Exporter';
|
||||||
|
|
||||||
|
if (defined $ENV{'DEBUG'}) {
|
||||||
|
use Data::Dumper;
|
||||||
|
use diagnostics;
|
||||||
|
use Carp;
|
||||||
|
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
|
||||||
|
}
|
||||||
|
|
||||||
|
our $NL="\n";
|
||||||
|
|
||||||
|
our @EXPORT_OK=qw(GetHeaderMap GuiResponseToArray GuiResponseToHash GetRecordsMatching GetFields);
|
||||||
|
our $refs_example = q( \@portnames or ["sta1", "sta2"] not ("sta1", "sta2"));
|
||||||
|
=pod
|
||||||
|
=head1 GuiResponseToArray
|
||||||
|
=cut
|
||||||
|
sub GuiResponseToArray {
|
||||||
|
my $response = shift;
|
||||||
|
my $ra_data = decode_json($response);
|
||||||
|
return $ra_data;
|
||||||
|
}
|
||||||
|
|
||||||
|
=pod
|
||||||
|
=head1 GuiResponseToHash
|
||||||
|
=cut
|
||||||
|
sub GuiResponseToHash {
|
||||||
|
my $response = shift;
|
||||||
|
my $ra_data = decode_json($response);
|
||||||
|
my $rh_data = {};
|
||||||
|
$rh_data->{'handler'} = $ra_data->[0]->{'handler'};
|
||||||
|
$rh_data->{'uri'} = $ra_data->[1]->{'uri'};
|
||||||
|
$rh_data->{'header'} = $ra_data->[2]->{'header'};
|
||||||
|
$rh_data->{'data'} = $ra_data->[3]->{'data'};
|
||||||
|
#print Dumper($rh_data);
|
||||||
|
return $rh_data;
|
||||||
|
}
|
||||||
|
|
||||||
|
=pod
|
||||||
|
=head1 GetHeaderMap
|
||||||
|
GuiJson::GenHeaderMap expects a reference to a header array like
|
||||||
|
{ 'header' => ['a', 'b', 'c']}
|
||||||
|
=cut
|
||||||
|
sub GetHeaderMap {
|
||||||
|
my $r_header = shift;
|
||||||
|
my $ra_header = undef;
|
||||||
|
#if (defined $ENV{'DEBUG'}) {
|
||||||
|
# print "DEBUGGING a:".ref($r_header)."\n";
|
||||||
|
# print Dumper($r_header);
|
||||||
|
#}
|
||||||
|
if (ref($r_header) eq 'ARRAY') {
|
||||||
|
$ra_header = $r_header;
|
||||||
|
}
|
||||||
|
elsif (ref($r_header) eq 'HASH' ) {
|
||||||
|
if( defined $r_header->{'header'}) {
|
||||||
|
$ra_header = $r_header->{'header'};
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $rh_headermap = {};
|
||||||
|
if (!defined $ra_header) {
|
||||||
|
print STDERR "GetHeaderMap: arg1 needs to be an array of header names, you get an empty hash\n";
|
||||||
|
return $rh_headermap;
|
||||||
|
}
|
||||||
|
my $index = 0;
|
||||||
|
for my $headername (@$ra_header) {
|
||||||
|
$rh_headermap->{$headername} = $index;
|
||||||
|
$index++;
|
||||||
|
}
|
||||||
|
return $rh_headermap;
|
||||||
|
}
|
||||||
|
|
||||||
|
=pod
|
||||||
|
=head1 GetRecordsMatching
|
||||||
|
GetRecordsMatching expects results of GetGuiResponseToHash and a list of port EIDs or names
|
||||||
|
$ra_ports = GetRecordsMatching($rh_data, $header_name, $value)
|
||||||
|
=cut
|
||||||
|
sub GetRecordsMatching {
|
||||||
|
my $rh_resp_map = shift;
|
||||||
|
my $header_name = shift;
|
||||||
|
my $ra_needles = shift;
|
||||||
|
my $ra_results = [];
|
||||||
|
if (!defined $rh_resp_map || ref($rh_resp_map) ne 'HASH') {
|
||||||
|
print STDERR "GetRecordsMatching wants arg1: json data structure\n";
|
||||||
|
return $ra_results;
|
||||||
|
}
|
||||||
|
if (!defined $header_name || $header_name eq '') {
|
||||||
|
print STDERR "GetRecordsMatching wants arg2: header name\n";
|
||||||
|
return $ra_results;
|
||||||
|
}
|
||||||
|
my $rh_headers = GetHeaderMap($rh_resp_map);
|
||||||
|
if (!defined $rh_headers->{$header_name}) {
|
||||||
|
print STDERR "GetRecordsMatching cannot find header named <$header_name>\n";
|
||||||
|
return $ra_results;
|
||||||
|
}
|
||||||
|
#print "GetRecordsMatching arg3 is ".ref($ra_needles)."\n";
|
||||||
|
if (!defined $ra_needles || ref($ra_needles) ne 'ARRAY') {
|
||||||
|
print Dumper($ra_needles);
|
||||||
|
my $example = q( \@portnames or ["sta1", "sta2"] not ("sta1", "sta2"));
|
||||||
|
print STDERR "GetRecordsMatching wants arg3: list values to match against <$header_name>.\nPass array references, eg:\n$example\n";
|
||||||
|
return $ra_results;
|
||||||
|
}
|
||||||
|
#print STDERR Dumper($ra_needles);
|
||||||
|
#print Dumper($rh_headers);
|
||||||
|
|
||||||
|
my $value = undef;
|
||||||
|
my @matches = undef;
|
||||||
|
for my $ra_port (@{$rh_resp_map->{'data'}}) {
|
||||||
|
$value = $ra_port->[ $rh_headers->{$header_name}];
|
||||||
|
#print "$header_name: $value\n";
|
||||||
|
@matches = grep { /$value/ } @$ra_needles;
|
||||||
|
if (@matches) {
|
||||||
|
push(@$ra_results, $ra_port);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return $ra_results;
|
||||||
|
}
|
||||||
|
|
||||||
|
=pod
|
||||||
|
=head1 GetFields
|
||||||
|
Returns matching fields from a record;
|
||||||
|
$ra_needles are an array of strings to match to select records
|
||||||
|
$ra_field_names are field names to return from those records
|
||||||
|
$rh = GetFields($rh_response_map, $header_name, $ra_needles, $ra_field_names)
|
||||||
|
=cut
|
||||||
|
sub GetFields {
|
||||||
|
my $rh_resp_map = shift;
|
||||||
|
my $header_name = shift;
|
||||||
|
my $ra_needles = shift;
|
||||||
|
my $ra_field_names = shift;
|
||||||
|
my $ra_records = [];
|
||||||
|
my $rh_field_values = {};
|
||||||
|
|
||||||
|
if (!defined $rh_resp_map || ref($rh_resp_map) ne 'HASH') {
|
||||||
|
print STDERR "GetFields wants arg1: json data structure\n";
|
||||||
|
return $rh_field_values;
|
||||||
|
}
|
||||||
|
if (!defined $header_name || $header_name eq '') {
|
||||||
|
print STDERR "GetFields wants arg2: header name\n";
|
||||||
|
return $rh_field_values;
|
||||||
|
}
|
||||||
|
my $rh_headers = GetHeaderMap($rh_resp_map);
|
||||||
|
#print "Header names: ". Dumper($rh_headers);
|
||||||
|
|
||||||
|
if (!defined $rh_headers->{$header_name}) {
|
||||||
|
print STDERR "GetFields cannot find header named <$header_name>\n";
|
||||||
|
return $rh_field_values;
|
||||||
|
}
|
||||||
|
if (!defined $ra_needles || ref($ra_needles) ne 'ARRAY') {
|
||||||
|
print Dumper($ra_needles);
|
||||||
|
|
||||||
|
print STDERR "GetFields wants arg3: list values to match against <$header_name>.\nPass array references, eg:\n$::refs_example\n";
|
||||||
|
return $rh_field_values;
|
||||||
|
}
|
||||||
|
if (!defined $ra_field_names || ref($ra_field_names) ne 'ARRAY') {
|
||||||
|
my $arg_str = join(", ", @$ra_needles);
|
||||||
|
print STDERR "GetFields wants arg4: list field names to return if <$header_name> matches <$arg_str>\nPass array references, eg:\n$::refs_example\n";
|
||||||
|
return $rh_field_values;
|
||||||
|
}
|
||||||
|
|
||||||
|
$ra_records = GetRecordsMatching($rh_resp_map, $header_name, $ra_needles);
|
||||||
|
return $rh_field_values if (@$ra_records < 1);
|
||||||
|
|
||||||
|
for my $ra_record (@$ra_records) {
|
||||||
|
next if (@$ra_record < 1);
|
||||||
|
next if (! defined @$ra_record[$rh_headers->{$header_name}]);
|
||||||
|
my $record_name = @$ra_record[$rh_headers->{$header_name}];
|
||||||
|
next if (!defined $record_name || "$record_name" eq "");
|
||||||
|
#print "record name[$record_name]\n";
|
||||||
|
|
||||||
|
#print Dumper($ra_record);
|
||||||
|
my $rh_record_vals = {};
|
||||||
|
$rh_field_values->{$record_name} = $rh_record_vals;
|
||||||
|
#print Dumper($ra_field_names);
|
||||||
|
|
||||||
|
for my $field_name (@$ra_field_names) {
|
||||||
|
next if (!defined $rh_headers->{$field_name});
|
||||||
|
my $field_idx = $rh_headers->{$field_name};
|
||||||
|
next if (!defined $field_name || "$field_name" eq "");
|
||||||
|
next if (!defined @$ra_record[$rh_headers->{$field_name}]);
|
||||||
|
#print "Field Name $field_name [".@$ra_record[$field_idx]."] ";
|
||||||
|
$rh_record_vals->{$field_name} = @$ra_record[$field_idx];
|
||||||
|
}
|
||||||
|
#print Dumper($rh_record_vals);
|
||||||
|
}
|
||||||
|
return $rh_field_values;
|
||||||
|
}
|
||||||
|
1;
|
||||||
1066
LANforge/Port.pm
Normal file
1066
LANforge/Port.pm
Normal file
File diff suppressed because it is too large
Load Diff
398
LANforge/Utils.pm
Normal file
398
LANforge/Utils.pm
Normal file
@@ -0,0 +1,398 @@
|
|||||||
|
package LANforge::Utils;
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
use Carp;
|
||||||
|
#$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
|
||||||
|
#$SIG{ __WARN__ } = sub { Carp::confess( @_ ) };
|
||||||
|
#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} = '/default\@btbits\>\>/';
|
||||||
|
|
||||||
|
bless( $self, $class );
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
# 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;
|
||||||
|
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() ); #'/default\@btbits\>\>/');
|
||||||
|
@rv = ( @rslt, @rslt2 );
|
||||||
|
|
||||||
|
if ( !$self->cli_rcv_silent() ) {
|
||||||
|
print "**************\n @rv \n................\n\n";
|
||||||
|
}
|
||||||
|
return join( "\n", @rv );
|
||||||
|
} #doAsyncCmd
|
||||||
|
|
||||||
|
# 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 "\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 telnet {
|
||||||
|
my $self = shift;
|
||||||
|
if (@_) { $self->{telnet} = shift }
|
||||||
|
|
||||||
|
$self->{telnet}->max_buffer_length(50 * 1024 * 1024);
|
||||||
|
return $self->{telnet};
|
||||||
|
}
|
||||||
|
|
||||||
|
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;
|
||||||
|
for my $hunk (@_) {
|
||||||
|
if (defined $hunk && $hunk eq '') {
|
||||||
|
print STDERR "\nfmt_cmd() found blank argument. Converting to NA\n";
|
||||||
|
$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"
|
||||||
|
}
|
||||||
|
$rv .= ( $mod_hunk =~m/ +/) ? "'$mod_hunk' " : "$mod_hunk ";
|
||||||
|
}
|
||||||
|
chomp $rv;
|
||||||
|
print STDERR "\ncmd: $rv\n" if($show_err or $::quiet ne "yes");
|
||||||
|
return $rv;
|
||||||
|
}
|
||||||
|
|
||||||
|
1; # So the require or use succeeds (perl stuff)
|
||||||
|
__END__
|
||||||
|
|
||||||
|
|
||||||
|
# Plain Old Documentation (POD)
|
||||||
|
|
||||||
|
=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) 2001 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.
|
||||||
|
|
||||||
|
|
||||||
|
=head1 VERSION
|
||||||
|
Version 0.0.1 May 26, 2001
|
||||||
|
|
||||||
|
=end
|
||||||
123
LANforge/csv.pm
Normal file
123
LANforge/csv.pm
Normal file
@@ -0,0 +1,123 @@
|
|||||||
|
package LANforge::csv;
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
use diagnostics;
|
||||||
|
use Carp;
|
||||||
|
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
|
||||||
|
#use Data::Dumper;
|
||||||
|
#use Data::Dumper::Concise;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $proto = shift;
|
||||||
|
my $class = ref($proto) || $proto;
|
||||||
|
my $self = {};
|
||||||
|
$self->{'ignore_comments'} = 1;
|
||||||
|
$self->{'skip_comments'} = 0;
|
||||||
|
$self->{'trim_whitespace'} = 1;
|
||||||
|
$self->{'rows'}=();
|
||||||
|
|
||||||
|
bless($self, $class);
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub readFile {
|
||||||
|
my $self = shift;
|
||||||
|
my $filename = shift;
|
||||||
|
die ("readFile: no filename provided.")
|
||||||
|
if (!defined $filename || $filename eq "");
|
||||||
|
|
||||||
|
open(my $fh, "<", "$filename")
|
||||||
|
or die("readFile: $!");
|
||||||
|
|
||||||
|
my @lines = ();
|
||||||
|
while(<$fh>) {
|
||||||
|
chomp;
|
||||||
|
my @row = undef;
|
||||||
|
#print "COMMENT: $_\n" if (/^\s*?\#.*/ && $self->{ignore_comments});
|
||||||
|
next if (/^\s*?\#.*/ && $self->{skip_comments});
|
||||||
|
|
||||||
|
if (/^\s*?\#.*/ && $self->{ignore_comments}) {
|
||||||
|
@row = ();
|
||||||
|
push(@{$self->{rows}}, \@row);
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
@row = split(/,/);
|
||||||
|
}
|
||||||
|
# trim() on all cell values
|
||||||
|
if ($self->{trim_whitespace}) {
|
||||||
|
s{^\s+|\s+$}{}g foreach @row;
|
||||||
|
}
|
||||||
|
push(@{$self->{rows}}, \@row);
|
||||||
|
}
|
||||||
|
close $fh;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub getRow {
|
||||||
|
my $self = shift;
|
||||||
|
my $row_num = shift;
|
||||||
|
die("getRow: no row number provided")
|
||||||
|
if (!defined($row_num) || $row_num eq "");
|
||||||
|
|
||||||
|
return undef if ($row_num >= @{$self->rows});
|
||||||
|
return ${$self->rows}[$row_num];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub getCell {
|
||||||
|
my $self = shift;
|
||||||
|
my $cell_num = shift;
|
||||||
|
my $row_num = shift;
|
||||||
|
my $default = (shift || 'undef');
|
||||||
|
|
||||||
|
die("getCell: no row number provided")
|
||||||
|
if (!defined($row_num) || $row_num eq "");
|
||||||
|
die("getCell: no cell number provided")
|
||||||
|
if (!defined($cell_num) || $cell_num eq "");
|
||||||
|
|
||||||
|
if ($row_num >= @{$self->{rows}}) {
|
||||||
|
#warn Dumper(@{$self->{rows}});
|
||||||
|
warn "row $row_num greater than number of rows(@{$self->{rows}})\n";
|
||||||
|
return $default;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $ra_row = ${$self->{rows}}[$row_num];
|
||||||
|
|
||||||
|
if (!defined $ra_row) {
|
||||||
|
#warn "row $row_num unset\n";
|
||||||
|
return $default;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($cell_num >= @{$ra_row}) {
|
||||||
|
#warn "cell $cell_num beyond size of row (".@{$ra_row}.")\n";
|
||||||
|
#warn Dumper($ra_row);
|
||||||
|
return $default;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (!defined $ra_row->[$cell_num]) {
|
||||||
|
#warn "value at [$cell_num,$row_num] unset\n";
|
||||||
|
#warn Dumper($ra_row);
|
||||||
|
return $default;
|
||||||
|
}
|
||||||
|
return $ra_row->[$cell_num];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub getRows {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->{rows};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub rows {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->{rows};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub numRows {
|
||||||
|
my $self = shift;
|
||||||
|
return 0+@{$self->{rows}};
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
=pod
|
||||||
|
This is a simple CSV parser, please install Text::CSV or someting more sophisticated
|
||||||
|
For instance, do not embed commas or newlines into the csv cells.
|
||||||
|
=end
|
||||||
Reference in New Issue
Block a user