=================================================================== RCS file: /cvs/trango/Net-Telnet-Trango/lib/Net/Telnet/Trango.pm,v retrieving revision 1.40 retrieving revision 1.52 diff -u -r1.40 -r1.52 --- trango/Net-Telnet-Trango/lib/Net/Telnet/Trango.pm 2007/02/06 21:15:28 1.40 +++ trango/Net-Telnet-Trango/lib/Net/Telnet/Trango.pm 2008/02/18 19:13:32 1.52 @@ -1,6 +1,6 @@ package Net::Telnet::Trango; -# $RedRiver: Trango.pm,v 1.39 2007/02/06 20:41:42 andrew Exp $ +# $RedRiver: Trango.pm,v 1.51 2008/02/18 16:37:35 andrew Exp $ use strict; use warnings; use base 'Net::Telnet'; @@ -17,7 +17,7 @@ use Net::Telnet::Trango; my $t = new Net::Telnet::Trango ( Timeout => 5 ); - $t->open( Host => $fox ) or die "Error connecting: $!"; + $t->open( Host => $ap ) or die "Error connecting: $!"; $t->login('password') or die "Couldn't log in: $!"; @@ -28,12 +28,12 @@ =head1 DESCRIPTION -Perl access to the telnet interface on Trango Foxes, SUs and APs. +Perl access to the telnet interface on Trango APs and SUs. -Another handy feature is that it will parse the output from certain -commands that is in the format "[key1] value1 [key2] value2" and put -those in a hashref that is returned. This makes using the output from -things like sysinfo very easy to do. +A handy feature is that it will parse the output from certain commands that is +in the format "[key1] value1 [key2] value2" and put those in a hashref that is +returned. This makes using the output from things like sysinfo very easy to +do. =head2 EXPORT @@ -61,7 +61,7 @@ [Decode => 0,]); Same as new from L but sets the default Trango Prompt: -'/#> *$/' +'/#>\s*\Z/' It also takes an optional parameter 'Decode'. If not defined it defaults to 1, if it is set to 0, it will not decode the output and @@ -81,7 +81,7 @@ %args = @_; } - $args{'Prompt'} ||= '/#> *$/'; + $args{'Prompt'} ||= '/#>\s*\r?\n?$/'; foreach my $key ( keys %args ) { $PRIVATE{$key} = $args{$key}; @@ -112,6 +112,7 @@ # help [command] # heater [ ] # ipconfig [ ] +# linktest [ [<# of pkts> [<# of cycle>]]] # log [<# of entries, 1..179>] # log <# of entries, 1..179> # logout @@ -322,6 +323,7 @@ my $success = 'Success\\.'; my %COMMANDS = ( + _clear => { String => "\n" }, tftpd => { decode => 'all', expect => $success }, ver => { decode => 'all' }, sysinfo => { decode => 'all', expect => $success }, @@ -342,6 +344,7 @@ { String => 'su testrflink', decode => 'each', expect => $success }, save_ss => { String => 'save ss', expect => $success }, opmode => { decode => 'all', expect => $success }, + arq => { decode => 'all' }, ); my %ALIASES = ( @@ -490,7 +493,7 @@ my ( $type, $sep1, $subtype, $sep2, $ver ) = $banner =~ - /Welcome to Trango Broadband Wireless (\S+)([\s-]+)(\S+)([\s-]+)(.+)$/i; + /Welcome to Trango Broadband Wireless,? (\S+)([\s-]+)(\S+)([\s-]+)(.+)$/i; $type .= $sep1 . $subtype; $ver = $subtype . $sep2 . $ver; @@ -504,6 +507,41 @@ =pod +=head2 B - Link test to SU + +linktest('suid'[, 'pkt len, bytes'[, '# of pkts'[, '# of cycles']]]); + +Returns a hash reference to the results of the test + +=cut + +sub linktest +{ + my $self = shift; + my $suid = shift; + # These numbers are what I found as defaults when running the command + my $pkt_len = shift || 1600; + my $pkt_cnt = shift || 500; + my $cycles = shift || 10; + + my %config = @_; + + # * 2, one for the FromAP, one FromSU. Then / 1000 to get to ms. + # XXX This might need to be changed, this makes the default timeout the + # same as $pkt_len, and that might not be enough at slower speeds. + $config{Timeout} ||= int(($pkt_len * $pkt_cnt * $cycles * 2 ) / 1000); + + my $string = join $SPACE, 'linktest', $suid, $pkt_len, $pkt_cnt, $cycles; + return $self->cmd( + %config, + String => $string, + decode => 'linktest', + ); + +} + +=pod + =head2 B - Set the password on SUs connected to the AP. su_password('new_password'[, 'suid']) If no suid is specified, @@ -892,6 +930,7 @@ $cmd{'String'} .= $SPACE . $cfg{'args'}; } + #print "Running cmd $cmd{String}\n"; my @lines; if ( $cfg{'no_prompt'} ) { $self->print( $cmd{'String'} ); @@ -903,6 +942,16 @@ $self->last_lines( \@lines ); + my $last = $self->lastline; + my $prompt = $self->prompt; + $prompt =~ s{^/}{}xms; + $prompt =~ s{/[gixms]*$}{}xms; + while (@lines && $last =~ qr($prompt)) { + pop @lines; + $last = $lines[-1]; + } + $self->last_error($EMPTY); + my $vals = 1; if ( $PRIVATE{'Decode'} && $cfg{'decode'} ) { if ( $cfg{'decode'} eq 'each' ) { @@ -913,16 +962,22 @@ } elsif ( $cfg{'decode'} eq 'maclist' ) { $vals = _decode_maclist(@lines); + if (! $vals) { + $self->last_error("Error decoding maclist"); + } } + elsif ( $cfg{'decode'} eq 'linktest' ) { + $vals = _decode_linktest(@lines); + if (! $vals) { + $self->last_error("Error decoding linktest"); + } + } else { $vals = _decode_lines(@lines); } } - $self->last_vals($vals); - my $last = $self->lastline; - if ( ( not $cfg{'expect'} ) || $last =~ /$cfg{'expect'}$/ ) { if ( $cfg{'cmd_disconnects'} ) { $self->logged_in(0); @@ -941,12 +996,12 @@ my $err; if (grep { /\[ERR\]/ } @lines) { $err = _decode_lines(@lines); - } + } - if (ref $err eq 'HASH' && $err ->{ERR}) { + if (ref $err eq 'HASH' && $err->{ERR}) { $self->last_error($err->{ERR} ); } else { - $self->last_error("Error with command ($cfg{'String'}): $last"); + $self->last_error("Error with command ($cmd{'String'}): $last"); } return; } @@ -965,9 +1020,50 @@ my $in_key = 0; my $in_val = 1; - foreach my $line (@lines) { - next if $line =~ /$success$/; + LINE: while (my $line = shift @lines) { + next LINE if $line =~ /$success\Z/; + next LINE if $line =~ /^ \*+ \s+ \d+ \s+ \*+ \Z/xms; + # Special decode for sysinfo on a TrangoLink 45 + if ($line =~ /^(.* Channel \s+ Table):\s*(.*)\Z/xms) { + my $key = $1; + my $note = $2; + + my %vals; + while ($line = shift @lines) { + if ($line =~ /^\Z/) { + $conf{$key} = \%vals; + $conf{$key}{note} = $note; + next LINE; + } + + my $decoded = _decode_lines($line); + if ($decoded) { + %vals = (%vals, %{ $decoded }); + } + } + } + # Another special decode for the TrangoLink + elsif ($line =~ /^ + RF \s Band \s \# + (\d+) \s+ + \( ([^\)]+) \) \s* + (.*)$ + /xms) { + my $num = $1; + my $band = $2; + my $extra = $3; + + if ($extra =~ /\[/) { + my $decoded = _decode_lines($extra); + $conf{'RF Band'}{$num} = $decoded; + } + else { + $conf{'RF Band'}{$num}{$extra} = 1; + } + next LINE; + } + my @chars = split //, $line; my $last_key = $EMPTY; @@ -1061,6 +1157,42 @@ return \@decoded; } +#=item _decode_linktest + +sub _decode_linktest { + my @lines = @_; + my %decoded; + foreach my $line (@lines) { + + if ($line =~ s/^(\d+) \s+ //xms) { + my $line_id = $1; + my ($tm, $rt); + if ($line =~ s/\s+ (\d+ \s+ \w+) \s* $//xms) { + $rt = $1; + } + if ($line =~ s/\s+ (\d+ \s+ \w+) \s* $//xms) { + $tm = $1; + } + + my $d = _decode_lines($line. "\n"); + $decoded{tests}[$line_id] = $d; + $decoded{tests}[$line_id]{'time'} = $tm; + $decoded{tests}[$line_id]{rate} = $rt; + } + + else { + my $d = _decode_lines($line . "\n"); + if ($d) { + while (my ($k, $v) = each %{ $d }) { + $decoded{$k} = $v; + } + } + } + + } + return \%decoded; +} + #=item _decode_sulog sub _decode_sulog { @@ -1135,8 +1267,6 @@ return \@decoded; } else { - - # XXX we should have a way to set last error, not sure why we don't return; } }