[BACK]Return to Trango.pm CVS log [TXT][DIR] Up to [local] / trango / Net-Telnet-Trango / lib / Net / Telnet

Annotation of trango/Net-Telnet-Trango/lib/Net/Telnet/Trango.pm, Revision 1.60

1.40      andrew      1: package Net::Telnet::Trango;
                      2:
1.60    ! andrew      3: # $RedRiver: Trango.pm,v 1.59 2009/07/31 21:44:33 andrew Exp $
1.40      andrew      4: use strict;
                      5: use warnings;
                      6: use base 'Net::Telnet';
                      7:
                      8: =pod
                      9:
                     10: =head1 NAME
                     11:
                     12: Net::Telnet::Trango
                     13: - Perl extension for accessing the Trango telnet interface
                     14:
                     15: =head1 SYNOPSIS
                     16:
                     17:   use Net::Telnet::Trango;
                     18:   my $t = new Net::Telnet::Trango ( Timeout => 5 );
                     19:
1.41      andrew     20:   $t->open( Host => $ap ) or die "Error connecting: $!";
1.40      andrew     21:
                     22:   $t->login('password') or die "Couldn't log in: $!";
                     23:
                     24:   # Do whatever
                     25:
                     26:   $t->exit;
                     27:   $t->close;
                     28:
                     29: =head1 DESCRIPTION
                     30:
1.41      andrew     31: Perl access to the telnet interface on Trango APs and SUs.
1.40      andrew     32:
1.41      andrew     33: A handy feature is that it will parse the output from certain commands that is
                     34: in the format "[key1] value1 [key2] value2" and put those in a hashref that is
                     35: returned.  This makes using the output from things like sysinfo very easy to
                     36: do.
1.40      andrew     37:
                     38: =head2 EXPORT
                     39:
                     40: None
                     41:
                     42: =head1 METHODS
                     43:
                     44: =cut
                     45:
1.59      andrew     46: our $VERSION = '0.05';
1.40      andrew     47:
                     48: my $EMPTY = q{};
                     49: my $SPACE = q{ };
                     50:
                     51: =pod
                     52:
                     53: =head2 B<new> - Creates a new Net::Telnet::Trango object.
                     54:
                     55:     new([Options from Net::Telnet,]
                     56:         [Decode => 0,]);
                     57:
                     58: Same as new from L<Net::Telnet> but sets the default Trango Prompt:
1.54      andrew     59: '/[\$#]>\s*\Z/'
1.40      andrew     60:
                     61: It also takes an optional parameter 'Decode'.  If not defined it
                     62: defaults to 1, if it is set to 0, it will not decode the output and
                     63: instead return a reference to an array of the lines that were returned
                     64: from the command.
                     65:
                     66: =cut
                     67:
                     68: sub new {
                     69:     my $class = shift;
                     70:
1.59      andrew     71:     my %args = ();
1.40      andrew     72:     if ( @_ == 1 ) {
                     73:         $args{'Host'} = shift;
                     74:     }
                     75:     else {
                     76:         %args = @_;
                     77:     }
                     78:
1.54      andrew     79:     $args{'Prompt'} ||= '/[\$#]>\s*\r?\n?$/';
1.40      andrew     80:
1.59      andrew     81:     my $decode = $args{'Decode'};
1.40      andrew     82:     delete $args{'Decode'};
                     83:
                     84:     my $self = $class->SUPER::new(%args);
                     85:     bless $self if ref $self;
                     86:
1.59      andrew     87:     $args{Decode}       = defined $decode ? $decode : 1;
                     88:     $args{is_connected} = 0;
                     89:     $args{logged_in}    = 0;
                     90:
                     91:     *$self->{net_telnet_trango} = \%args;
                     92:
1.40      andrew     93:     return $self;
                     94: }
                     95:
                     96: #  _password <new password> <new password>
                     97: #  ? [command]
                     98: #  apsearch <secs> <ch#> <h|v> [<ch#> <h|v>]...
                     99: #  arp -bcast <on|off>
                    100: #  bcastscant <all|suid> <ch#> <h|v> [<ch#> <h|v> ...
                    101: #  bye
                    102: #  cf2cf ap [default|<size>]
                    103: #  date
                    104: #  date <month> <day> <year>
                    105: #  freq scantable
                    106: #  freq channeltable
                    107: #  freq writescan [<ch#> <h|v>]
                    108: #  freq writechannel [<ch#> <freq>] ...
                    109: #  freq <ch #> <h|v>
                    110: #  help [command]
                    111: #  heater [<on temp> <off temp>]
                    112: #  ipconfig [<new ip> <new subnet mask> <new gateway>]
1.46      andrew    113: #  linktest <suid> [<pkt len, bytes> [<# of pkts> [<# of cycle>]]]
1.40      andrew    114: #  log [<# of entries, 1..179>]
                    115: #  log <sum> <# of entries, 1..179>
                    116: #  logout
                    117: #  opmode [ap [y]]
                    118: #  password
                    119: #  ping <ip addr>
                    120: #  polar <h|v>
                    121: #  power <setism|setunii> <max|min|<dBm>>
                    122: #  reboot
                    123: #  restart
                    124: #  remarks [<str>]
                    125: #  rfrxthreshold [<ism|unii> <-90|-85|-80|-75|-70|-65>]
                    126: #  rfrxth [<ism|unii> <-90|-85|-80|-75|-70|-65>]
                    127: #  sysinfo
                    128: #  set suid <id>
                    129: #  set apid <id>
                    130: #  set baseid <id>
                    131: #  set defaultopmode [<ap|su> <min,0..10>]
                    132: #  set defaultopmode off
                    133: #  set snmpcomm [<read | write | trap (id or setall)> <str>]
                    134: #  set mir [on|off]
                    135: #  set mir threshold <kbps>
                    136: #  set rssitarget [<ism|unii> <dBm>]
                    137: #  set serviceradius [<ism | unii> <miles>]
                    138: #  ssrssi <ch #> <h|v>
                    139: #  su [<suid>|all]
                    140: #  su changechannel <all|suid> <ch#> <h|v>
                    141: #  su ipconfig <suid> <new ip> <new subnet> <new gateway>
                    142: #  su [live|poweroff|priority]
                    143: #  su <ping|info|status> <suid>
                    144: #  su powerleveling <all|suid>
                    145: #  su reboot <all|suid>
                    146: #  su restart <all|suid>
                    147: #  su testrflink <all|suid> [r]
                    148: #  su testrflink <setlen> [64..1600]
                    149: #  su testrflink <aptx> [20..100]
                    150: #  su sw <suid|all> <sw #> <on|off>
                    151: #  sudb [dload | view]
                    152: #  sudb add <suid> pr <cir,kbps> <mir,kbps> <device id,hex>
                    153: #  sudb add <suid> reg <cir,kbps> <mir,kbps> <device id,hex>
                    154: #  sudb delete <all|<suid>>
                    155: #  sudb modify <suid> <cir|mir> <kbps>
                    156: #  sudb modify <suid> <su2su> <group id,hex>
                    157: #  sudb view
                    158: #  sulog [lastmins | sampleperiod <1..60>]
                    159: #  sulog [<# of entry,1..18>]
                    160: #  survey <ism|unii> <time, sec> <h|v>
                    161: #  sw [<sw #> <on|off>]
                    162: #  temp
                    163: #  tftpd [on|off]
                    164: #  time
                    165: #  time <hour> <min> <sec>
                    166: #  save <mainimage|fpgaimage> <current chksum> <new chksum>
                    167: #  save <systemsetting|sudb>
                    168: #  updateflash <mainimage|fpgaimage> <current chksum> <new chksum>
                    169: #  updateflash <systemsetting|sudb>
                    170:
                    171: =pod
                    172:
                    173: =head1 ACCESSORS
                    174:
                    175: These are usually only set internally.
                    176:
                    177: =head2 B<firmware_version> - returns the firmware version
                    178:
                    179: Returns the firmware version if available, otherwise undef.
                    180:
                    181: It should be available after a successful open().
                    182:
                    183: =head2 B<host_type> - return the type of host you are connected to.
                    184:
                    185: returns the type of host from the login banner for example M5830S or M5300S.
                    186:
                    187: Should be available after a successful open().
                    188:
                    189: =head2 B<is_connected> - Status of the connection to host.
                    190:
                    191: returns 1 when connected, undef otherwise.
                    192:
                    193: =head2 B<logged_in> - Status of being logged in to the host.
                    194:
                    195: returns 1 after a successful login(), 0 if it failed and undef if
                    196: login() was never called.
                    197:
                    198: =head2 B<login_banner> - The banner when first connecting to the host.
                    199:
                    200: returns the banner that is displayed when first connected at login.
                    201: Only set after a successful open().
                    202:
                    203: =head2 B<last_lines> - The last lines of output from the last cmd().
                    204:
                    205: returns, as an array ref, the output from the last cmd() that was run.
                    206:
                    207: =head2 B<last_error> - A text output of the last error that was encountered.
                    208:
                    209: returns the last error reported.  Probably contains the last entry in
                    210: last_lines.
                    211:
                    212: =head1 ALIASES
                    213:
                    214: =head2 B<bye> - alias of exit()
                    215:
                    216: Does the same as exit()
                    217:
                    218: =head2 B<restart> - alias of reboot()
                    219:
                    220: Does the same as reboot()
                    221:
                    222: =head2 B<save_systemsetting> - alias of save_ss()
                    223:
                    224: Does the same as save_ss()
                    225:
                    226: =head1 COMMANDS
                    227:
                    228: Most of these are just shortcuts to C<cmd(String =E<gt> METHOD)>,
                    229: as such they accept the same options as C<cmd()>.
                    230: Specifically they take a named paramater "args", for example:
                    231: C<tftpd(args =E<gt> 'on')> would enable tftpd
                    232:
                    233: =head2 B<tftpd> - The output from the tftpd command
                    234:
                    235: Returns a hash ref of the decoded output from the
                    236: command.
                    237:
                    238: Also see enable_tftpd() and disable_tftpd() as those check that it was
                    239: successfully changed.
                    240:
                    241: =head2 B<ver> - The output from the ver command
                    242:
                    243: Returns a hash ref of the decoded output from the
                    244: command.
                    245:
                    246: =head2 B<sysinfo> - The output from the sysinfo command
                    247:
                    248: Returns a hash ref of the decoded output from the
                    249: command.
                    250:
                    251: =head2 B<exit> - Exits the connection
                    252:
                    253: exits the command session with the Trango and closes
                    254: the connection
                    255:
                    256: =head2 B<reboot> - Sends a reboot command
                    257:
                    258: reboots the Trango and closes the connection
                    259:
1.60    ! andrew    260: =head2 B<reset> <all|0..2> - Sends a reset command
1.59      andrew    261:
                    262: resets settings to default
                    263:
1.40      andrew    264: =head2 B<remarks> - Set or retrieve the remarks.
                    265:
                    266: Takes an optional argument, which sets the remarks.
                    267: If there is no argument, returns the current remarks.
                    268:
                    269:   my $old_remarks = $t->remarks();
                    270:   $t->remarks($new_remarks);
                    271:
                    272: =head2 B<sulog> - The output from the sulog command
                    273:
                    274: Returns an array ref of hashes containing each log
                    275: line.
                    276:
                    277: =head2 B<save_sudb> - saves the sudb
                    278:
                    279: Returns true on success, undef on failure
                    280:
                    281: =head2 B<syslog> - The output from the sulog command
                    282:
                    283: Returns a hashref of the output from the syslog command
                    284:
                    285: =head2 B<pipe> - the pipe command
                    286:
                    287: Returns the output from the pipe command
                    288:
                    289: =head2 B<maclist> - retrieves the maclist
                    290:
                    291: Returns the output from the maclist command
                    292:
                    293: =head2 B<maclist_reset> - resets the maclist.
                    294:
                    295: No useful output.
                    296:
                    297: =head2 B<eth_link> - eth link command
                    298:
                    299: Returns the output from the eth link command
                    300:
                    301: This command seems to cause some weird issues.  It often will cause the
                    302: command after it to appear to fail.  I am not sure why.
                    303:
                    304: =head2 B<su_info> - gets the su info
                    305:
                    306: Returns information about the SU.
                    307:
                    308: You need to pass in the $suid and it will return the info for that suid.
                    309:
                    310:   $t->su_info($suid);
                    311:
                    312: =head2 B<su_testrflink> - tests the RF Link to an su
                    313:
                    314:   $t->su_testrflink($suid|'all');
                    315:
                    316: =head2 B<save_ss> - saves the config.
                    317:
                    318: Returns 1 on success, undef on failure.
                    319:
1.59      andrew    320: =head2 B<set_baseid> - sets baseid
                    321:
                    322:     $t->set_baseid($baseid);
                    323:
                    324: =head2 B<set_suid> - sets baseid
                    325:
                    326:     $t->set_suid($baseid);
                    327:
                    328: =head2 B<set_defaultopmode> - sets default opmode
                    329:
                    330:     $t->set_defaultopmode(ap|su);
                    331:
                    332: =head2 B<opmode> - sets or returns the opmode
                    333:
                    334:     $t->opmode([ap y|su y]);
                    335:
                    336: =head2 B<freq> - sets or returns the freq
                    337:
                    338:     $channel = '11 v';
                    339:     $t->freq([$channel]);
                    340:
                    341: =head2 B<freq_writescan> - sets the freq writescan
                    342:
                    343:     $channels = '11 v 11 h 12 v 12 h';
                    344:     $t->freq_writescan($channels);
                    345:
                    346: =head2 B<freq_scantable> - returns the freq scantable
                    347:
                    348:     $channels = $t->freq_scantable();
                    349:     # now $channels eq '11 v 11 h 12 v 12 h';
1.40      andrew    350:
                    351:
                    352: =cut
                    353:
                    354: my $success  = 'Success\\.';
                    355: my %COMMANDS = (
1.57      andrew    356:     _clear      => { String    => "\n" },
                    357:     tftpd       => { decode    => 'all', expect => $success },
1.40      andrew    358:     ver         => { decode    => 'all' },
1.57      andrew    359:     sysinfo     => { decode    => 'all', expect => $success },
                    360:     updateflash => { decode    => 'all', expect => $success },
                    361:     sulog       => { decode    => 'sulog', expect => $success },
                    362:     'exit'      => { no_prompt => 1, cmd_disconnects => 1 },
                    363:     reboot      => { no_prompt => 1, cmd_disconnects => 1 },
1.59      andrew    364:     'reset'   => {},
                    365:     remarks   => { decode => 'all', expect => $success },
                    366:     save_sudb => { String => 'save sudb', expect => $success },
                    367:     syslog  => { expect => $success },
                    368:     'pipe'  => {},      # XXX needs a special decode
1.57      andrew    369:     maclist => { decode => 'maclist' },
                    370:     maclist_reset => { String => 'maclist reset', expect => 'done' },
1.59      andrew    371:     eth_link      => { String => 'eth link',      expect => $success },
                    372:     su_info => { String => 'su info', decode => 'all', expect => $success },
1.40      andrew    373:     su_testrflink =>
1.57      andrew    374:         { String => 'su testrflink', decode => 'each', expect => $success },
1.59      andrew    375:     save_ss    => { String => 'save ss', expect => $success },
                    376:     set_baseid => {
                    377:         String => 'set baseid',
                    378:         decode => 'all',
                    379:         expect => $success
                    380:     },
                    381:     set_suid => {
                    382:         String => 'set suid',
                    383:         decode => 'all',
                    384:         expect => $success
                    385:     },
                    386:     set_defaultopmode => {
                    387:         String => 'set defaultopmode',
                    388:         decode => 'all',
                    389:         expect => $success
                    390:     },
                    391:     opmode => { decode => 'all',  expect => $success },
                    392:     freq   => { decode => 'freq', expect => $success },
                    393:     freq_writescan =>
                    394:         { String => 'freq writescan', decode => 'all', expect => $success },
                    395:     freq_scantable =>
                    396:         { String => 'freq scantable', decode => 'all', expect => $success },
                    397:     arq => { decode => 'all' },
1.40      andrew    398: );
                    399:
                    400: my %ALIASES = (
1.57      andrew    401:     bye               => 'exit',
                    402:     restart           => 'reboot',
                    403:     Host              => 'host',
1.40      andrew    404:     save_systemseting => 'save_ss',
                    405: );
                    406:
                    407: my %ACCESS = map { $_ => 1 } qw(
1.57      andrew    408:     firmware_version
                    409:     host_type
                    410:     is_connected
                    411:     logged_in
                    412:     login_banner
                    413:     Timeout
                    414:     last_lines
                    415:     last_vals
                    416:     last_error
                    417:     Decode
1.40      andrew    418: );
                    419:
                    420: sub AUTOLOAD {
                    421:     my $self = shift;
                    422:
                    423:     my ($method) = ( our $AUTOLOAD ) =~ /^.*::(\w+)$/
1.57      andrew    424:         or die "Weird: $AUTOLOAD";
1.40      andrew    425:
                    426:     if ( exists $ALIASES{$method} ) {
                    427:         $method = $ALIASES{$method};
                    428:         return $self->$method(@_);
                    429:     }
                    430:
                    431:     if ( exists $COMMANDS{$method} ) {
                    432:         my %cmd;
                    433:         foreach my $k ( keys %{ $COMMANDS{$method} } ) {
                    434:             $cmd{$k} = $COMMANDS{$method}{$k};
                    435:         }
                    436:         $cmd{'String'} ||= $method;
                    437:         $cmd{'args'} .= $SPACE . shift if ( @_ == 1 );
                    438:         return $self->cmd( %cmd, @_ );
                    439:     }
                    440:
                    441:     if ( exists $ACCESS{$method} ) {
1.59      andrew    442:         my $s    = *$self->{net_telnet_trango};
                    443:         my $prev = $s->{$method};
                    444:         ( $s->{$method} ) = @_ if @_;
1.40      andrew    445:         return $prev;
                    446:     }
                    447:
                    448:     $method = "SUPER::$method";
                    449:     return $self->$method(@_);
                    450: }
                    451:
                    452: =pod
                    453:
                    454: =head2 B<open> - Open a connection to a Trango AP.
                    455:
                    456: Calls Net::Telnet::open() then makes sure you get a password prompt so
                    457: you are ready to login() and parses the login banner so you can get
                    458: host_type() and firmware_version()
                    459:
                    460: =cut
                    461:
                    462: sub open {
                    463:     my $self = shift;
                    464:
                    465:     unless ( $self->SUPER::open(@_) ) {
                    466:         $self->last_error( "Couldn't connect to " . $self->host . ":  $!" );
                    467:         return;
                    468:     }
                    469:
                    470:     ## Get to login prompt
                    471:     unless (
                    472:         $self->waitfor(
                    473:             -match   => '/password: ?$/i',
                    474:             -errmode => "return",
                    475:         )
1.57      andrew    476:         )
1.40      andrew    477:     {
                    478:         $self->last_error( "problem connecting to host ("
1.57      andrew    479:                 . $self->host . "): "
                    480:                 . $self->lastline );
1.40      andrew    481:         return;
                    482:     }
                    483:
                    484:     $self->parse_login_banner( $self->lastline );
                    485:
                    486:     $self->is_connected(1);
                    487:
                    488:     return $self->is_connected;
                    489: }
                    490:
                    491: =pod
                    492:
                    493: =head2 B<login> - Login to the AP.
                    494:
                    495: Calls open() if not already connected, then sends the password and sets
                    496: logged_in() if successful
                    497:
                    498: =cut
                    499:
                    500: sub login {
                    501:     my $self = shift;
                    502:
                    503:     unless ( $self->is_connected ) {
                    504:         $self->open or return;
                    505:     }
                    506:
                    507:     my $password = shift;
                    508:
                    509:     $self->print($password);
                    510:     unless (
                    511:         $self->waitfor(
                    512:             -match   => $self->prompt,
                    513:             -errmode => "return",
                    514:         )
1.57      andrew    515:         )
1.40      andrew    516:     {
                    517:         $self->last_error( "login ($self->host) failed: " . $self->lastline );
                    518:         return;
                    519:     }
                    520:
                    521:     $self->logged_in(1);
                    522:
                    523:     return $self->logged_in;
                    524: }
                    525:
                    526: =pod
                    527:
                    528: =head2 B<parse_login_banner> - Converts the login_banner to something useful.
                    529:
                    530: Takes a login banner (what you get when you first connect to the Trango)
                    531: or reads what is already in login_banner() then parses it and sets
                    532: host_type() and firmware_version() as well as login_banner()
                    533:
                    534: =cut
                    535:
                    536: sub parse_login_banner {
                    537:     my $self = shift;
                    538:
                    539:     if (@_) {
                    540:         $self->login_banner(@_);
                    541:     }
                    542:
                    543:     my $banner = $self->login_banner;
                    544:
1.57      andrew    545:     my ( $type, $sep1, $subtype, $sep2, $ver )
                    546:         = $banner
                    547:         =~ /Welcome to Trango Broadband Wireless,? (\S+)([\s-]+)(\S+)([\s-]+)(.+)$/i;
1.40      andrew    548:
                    549:     $type .= $sep1 . $subtype;
                    550:     $ver = $subtype . $sep2 . $ver;
                    551:
                    552:     $self->login_banner($banner);
                    553:     $self->host_type($type);
                    554:     $self->firmware_version($ver);
                    555:
                    556:     return 1;
                    557: }
                    558:
                    559: =pod
                    560:
1.46      andrew    561: =head2 B<linktest> - Link test to SU
                    562:
                    563: linktest('suid'[, 'pkt len, bytes'[, '# of pkts'[, '# of cycles']]]);
                    564:
                    565: Returns a hash reference to the results of the test
                    566:
                    567: =cut
                    568:
1.57      andrew    569: sub linktest {
                    570:     my $self = shift;
                    571:     my $suid = shift;
                    572:
1.46      andrew    573:     # These numbers are what I found as defaults when running the command
                    574:     my $pkt_len = shift || 1600;
1.57      andrew    575:     my $pkt_cnt = shift || 500;
1.46      andrew    576:     my $cycles  = shift || 10;
                    577:
1.57      andrew    578:     my %config = @_;
1.46      andrew    579:
                    580:     # * 2, one for the FromAP, one FromSU.  Then / 1000 to get to ms.
                    581:     # XXX This might need to be changed, this makes the default timeout the
                    582:     # same as $pkt_len, and that might not be enough at slower speeds.
1.57      andrew    583:     $config{Timeout} ||= int( ( $pkt_len * $pkt_cnt * $cycles * 2 ) / 1000 );
1.46      andrew    584:
                    585:     my $string = join $SPACE, 'linktest', $suid, $pkt_len, $pkt_cnt, $cycles;
                    586:     return $self->cmd(
                    587:         %config,
                    588:         String => $string,
                    589:         decode => 'linktest',
                    590:     );
                    591:
                    592: }
                    593:
                    594: =pod
                    595:
1.40      andrew    596: =head2 B<su_password> - Set the password on SUs connected to the AP.
                    597:
                    598: su_password('new_password'[, 'suid']) If no suid is specified,
                    599: the default is "all".
                    600:
                    601:   $t->su_password('good_pass', 5);
                    602:
                    603: =cut
                    604:
                    605: sub su_password {
                    606:     my $self     = shift;
                    607:     my $new_pass = shift || $EMPTY;
                    608:     my $su       = shift || 'all';
                    609:
                    610:     unless ( defined $new_pass ) {
                    611:         $self->last_error("No new password");
                    612:
                    613:         #return;
                    614:     }
                    615:
                    616:     return $self->cmd(
1.57      andrew    617:         String => 'su password '
                    618:             . $su
                    619:             . $SPACE
                    620:             . $new_pass
                    621:             . $SPACE
                    622:             . $new_pass,
1.40      andrew    623:         expect => $success,
                    624:     );
                    625: }
                    626:
                    627: =pod
                    628:
1.59      andrew    629: =head2 B<ipconfig> - Change IP configuration
                    630:
                    631: ipconfig( 'new_ip', 'new_subnet', 'new_gateway' )
                    632:
                    633:   $t->ipconfig( '10.0.1.5', '255.255.255.0', '10.0.1.1' );
                    634:
                    635: =cut
                    636:
                    637: sub ipconfig {
                    638:     my $self = shift;
                    639:
                    640:     my $string = join $SPACE, 'ipconfig', @_;
                    641:
                    642:     if ( @_ == 3 ) {
                    643:         $self->print($string);
                    644:         my @lines = $self->waitfor( Match => '/save\s+and\s+activate/', );
                    645:         $self->print('y');
                    646:
                    647:         $self->logged_in(0);
                    648:         $self->is_connected(0);
                    649:
                    650:         foreach my $line (@lines) {
                    651:             if ( $line =~ s/New \s configuration:\s+//xms ) {
                    652:                 return _decode_lines($line);
                    653:             }
                    654:         }
                    655:
                    656:         return {};
                    657:     }
                    658:
                    659:     # ipconfig [ <new ip> <new subnet> <new gateway> ]
                    660:     return $self->cmd( String => $string, expect => $success );
                    661: }
                    662:
                    663: =pod
                    664:
1.40      andrew    665: =head2 B<su_ipconfig> - Change IP configuration on SUs connected to the AP.
                    666:
                    667: su_ipconfig( 'suid', 'new_ip', 'new_subnet', 'new_gateway' )
                    668:
                    669:   $t->su_ipconfig( 5, '10.0.1.5', '255.255.255.0', '10.0.1.1' );
                    670:
                    671: =cut
                    672:
                    673: sub su_ipconfig {
                    674:     my $self = shift;
                    675:
                    676:     my $suid        = shift;
                    677:     my $new_ip      = shift;
                    678:     my $new_subnet  = shift;
                    679:     my $new_gateway = shift;
                    680:
                    681:     if ( $suid =~ /\D/ ) {
                    682:         $self->last_error("Invalid suid '$suid'");
                    683:         return;
                    684:     }
                    685:     unless ($new_ip) {
                    686:         $self->last_error("no new_ip passed");
                    687:         return;
                    688:     }
                    689:     unless ($new_subnet) {
                    690:         $self->last_error("no new_subnet passed");
                    691:         return;
                    692:     }
                    693:     unless ($new_gateway) {
                    694:         $self->last_error("no new_gateway passed");
                    695:         return;
                    696:     }
                    697:
                    698:     # su ipconfig <suid> <new ip> <new subnet> <new gateway>
                    699:     return $self->cmd(
1.57      andrew    700:         String => 'su ipconfig '
                    701:             . $suid
                    702:             . $SPACE
                    703:             . $new_ip
                    704:             . $SPACE
                    705:             . $new_subnet
                    706:             . $SPACE
                    707:             . $new_gateway,
1.40      andrew    708:         expect => $success,
                    709:     );
                    710: }
                    711:
                    712: =pod
                    713:
                    714: =head2 B<sudb_view> - Returns the output from the sudb view command
                    715:
                    716: returns a reference to an array of hashes each containing these keys
1.57      andrew    717: 'suid', 'su2su', 'type', 'cir', 'mir' and 'mac'
1.40      andrew    718:
                    719: =cut
                    720:
                    721: sub sudb_view {
                    722:     my $self = shift;
                    723:
                    724:     my $lines = $self->cmd( String => 'sudb view', expect => $success ) || [];
                    725:
                    726:     return unless @{$lines};
                    727:
1.59      andrew    728:     my $s = *$self->{net_telnet_trango};
                    729:     return $lines if !$s->{'Decode'};
1.40      andrew    730:
                    731:     my @sus;
                    732:     foreach ( @{$lines} ) {
                    733:         next unless $_;
1.57      andrew    734:         if (/^
                    735:             \[(\d+)\]
                    736:             \s+
                    737:             [[:xdigit:]]{2}
                    738:             ([[:xdigit:]])
                    739:             ([[:xdigit:]])
1.58      andrew    740:             \s+
                    741:             (\d+)
1.57      andrew    742:             \s+
                    743:             (\d+)
                    744:             \s+
                    745:             ([[:xdigit:]\s]+)
                    746:         $/ixms
                    747:             )
                    748:         {
1.40      andrew    749:             my %s = (
1.57      andrew    750:                 suid  => $1,
                    751:                 su2su => $2 ? $2 : undef,
                    752:                 type  => $3 == 1 ? 'reg' : $3 == 5 ? 'pri' : $3,
                    753:                 cir   => $4,
                    754:                 mir   => $5,
                    755:                 mac   => $6,
1.40      andrew    756:             );
                    757:
1.57      andrew    758:             $s{'mac'} =~ s/\s//gxms;
1.40      andrew    759:             $s{'mac'} = uc( $s{'mac'} );
                    760:
                    761:             push @sus, \%s;
                    762:         }
                    763:     }
                    764:
                    765:     return \@sus;
                    766: }
                    767:
                    768: =pod
                    769:
                    770: =head2 B<sudb_add> - Adds an su to the sudb
                    771:
                    772: Takes the following paramaters
                    773:
                    774:     suid : numeric,
                    775:     type : (reg|pr)
                    776:     cir  : numeric,
                    777:     mir  : numeric,
                    778:     mac  : Almost any format, it will be reformatted,
                    779:
                    780: and returns true on success or undef otherwise.
                    781:
                    782:   $t->sudb_add($suid, 'reg', $cir, $mir, $mac);
                    783:
                    784: You should save_sudb() after calling this, or your changes  will be lost
                    785: when the AP is rebooted.
                    786:
                    787: =cut
                    788:
                    789: sub sudb_add {
                    790:     my $self = shift;
                    791:     my $suid = shift;
                    792:     my $type = shift;
                    793:     my $cir  = shift;
                    794:     my $mir  = shift;
                    795:     my $mac  = shift;
                    796:
                    797:     if ( $suid =~ /\D/ ) {
                    798:         $self->last_error("Invalid suid '$suid'");
                    799:         return;
                    800:     }
                    801:
                    802:     unless ( lc($type) eq 'reg' || lc($type) eq 'pr' ) {
                    803:         $self->last_error("Invalid type '$type'");
                    804:         return;
                    805:     }
                    806:
                    807:     if ( $cir =~ /\D/ ) {
                    808:         $self->last_error("Invalid CIR '$cir'");
                    809:         return;
                    810:     }
                    811:
                    812:     if ( $mir =~ /\D/ ) {
                    813:         $self->last_error("Invalid MIR '$mir'");
                    814:         return;
                    815:     }
                    816:
                    817:     my $new_mac = $mac;
1.55      andrew    818:     $new_mac =~ s/[^0-9A-Fa-f]//g;
1.40      andrew    819:     unless ( length $new_mac == 12 ) {
                    820:         $self->last_error("Invalid MAC '$mac'");
                    821:         return;
                    822:     }
                    823:     $new_mac = join $SPACE, $new_mac =~ /../g;
                    824:
1.57      andrew    825:     my $string
                    826:         = 'sudb add '
                    827:         . $suid
                    828:         . $SPACE
                    829:         . $type
                    830:         . $SPACE
                    831:         . $cir
                    832:         . $SPACE
                    833:         . $mir
                    834:         . $SPACE
                    835:         . $new_mac;
1.40      andrew    836:
                    837:     return $self->cmd( String => $string, expect => $success );
                    838: }
                    839:
                    840: =pod
                    841:
                    842: =head2 B<sudb_delete> - removes an su from the sudb
                    843:
                    844: Takes either 'all' or the  suid of the su to delete
                    845: and returns true on success or undef otherwise.
                    846:
                    847:   $t->sudb_delete($suid);
                    848:
                    849: You should save_sudb() after calling this, or your changes  will be lost
                    850: when the AP is rebooted.
                    851:
                    852: =cut
                    853:
                    854: sub sudb_delete {
                    855:     my $self = shift;
                    856:     my $suid = shift;
                    857:
                    858:     #if (lc($suid) ne 'all' || $suid =~ /\D/) {
                    859:     if ( $suid =~ /\D/ ) {
                    860:         $self->last_error("Invalid suid '$suid'");
                    861:         return;
                    862:     }
                    863:
                    864:     return $self->cmd( String => 'sudb delete ' . $suid, expect => $success );
                    865: }
                    866:
                    867: =pod
                    868:
                    869: =head2 B<sudb_modify> - changes the su information in the sudb
                    870:
                    871: Takes either the  suid of the su to change
                    872: as well as what you are changing, either "cir, mir or su2su"
                    873: and returns true on success or undef otherwise.
                    874:
                    875: cir and mir also take a value to set the cir/mir to.
                    876:
                    877: su2su takes a group id parameter that is in hex.
                    878:
                    879:   $t->sudb_modify($suid, 'cir', 512);
                    880:
                    881: You should save_sudb() after calling this, or your changes  will be lost
                    882: when the AP is rebooted.
                    883:
                    884: =cut
                    885:
                    886: sub sudb_modify {
                    887:     my $self  = shift;
                    888:     my $suid  = shift;
                    889:     my $opt   = shift;
                    890:     my $value = shift;
                    891:
                    892:     if ( $suid =~ /\D/ ) {
                    893:         $self->last_error("Invalid suid '$suid'");
                    894:         return;
                    895:     }
                    896:
                    897:     if ( lc($opt) eq 'cir' or lc($opt) eq 'mir' ) {
                    898:         if ( $value =~ /\D/ ) {
                    899:             $self->last_error("Invalid $opt '$value'");
                    900:             return;
                    901:         }
                    902:     }
                    903:     elsif ( lc($opt) eq 'su2su' ) {
                    904:         if ( $value =~ /[^0-9A-Za-f]/ ) {
                    905:             $self->last_error("Invalid MAC '$value'");
                    906:             return;
                    907:         }
                    908:     }
                    909:     else {
                    910:         $self->last_error("Invalid option '$opt'");
                    911:         return;
                    912:     }
                    913:
                    914:     my $string = 'sudb modify ' . $suid . $SPACE . $opt . $SPACE . $value;
                    915:
                    916:     return $self->cmd( String => $string, expect => $success );
                    917: }
                    918:
                    919: =pod
                    920:
                    921: =head2 B<enable_tftpd> - enable the TFTP server
                    922:
                    923: runs C<tftpd(args =E<gt> 'on')> and makes sure that Tftpd is now 'listen'ing
                    924:
                    925: =cut
                    926:
                    927: sub enable_tftpd {
                    928:     my $self = shift;
                    929:
                    930:     my $vals = $self->tftpd( args => 'on' );
                    931:
                    932:     if ( ref $vals eq 'HASH' && $vals->{'Tftpd'} eq 'listen' ) {
                    933:         return $vals;
                    934:     }
                    935:     else {
                    936:         return;
                    937:     }
                    938: }
                    939:
                    940: =pod
                    941:
                    942: =head2 B<disable_tftpd> - disable the TFTP server
                    943:
                    944: runs C<tftpd(args =E<gt> 'off')> and makes sure that Tftpd is now 'disabled'
                    945:
                    946: =cut
                    947:
                    948: sub disable_tftpd {
                    949:     my $self = shift;
                    950:
                    951:     my $vals = $self->tftpd( args => 'off' );
                    952:
                    953:     if ( ref $vals eq 'HASH' && $vals->{'Tftpd'} eq 'disabled' ) {
                    954:         return $vals;
                    955:     }
                    956:     else {
                    957:         return;
                    958:     }
                    959: }
                    960:
                    961: =pod
                    962:
                    963: =head2 B<cmd> - runs a command on the AP.
                    964:
                    965: This does most of the work.  At the heart, it calls Net::Telnet::cmd()
                    966: but it also does some special stuff for Trango.
                    967:
                    968: Normally returns the last lines from from the command
                    969:
                    970: If you are using this, rather than one of the "easy" methods above,
                    971: you probably want to read through the source of this module to see how
                    972: some of the other commands are called.
                    973:
                    974: In addition to the Net::Telnet::cmd() options, it also accepts these:
                    975:
                    976: I<decode>
                    977: - if this is true, then it will send the output lines to _decode_lines()
                    978: and then returns the decoded output
                    979:
                    980: I<no_prompt>
                    981: - if this is true, it does not wait for a prompt, so you are not stuck
                    982: waiting for something that will never happen.
                    983:
                    984: I<cmd_disconnects>
                    985: - if this is true, it then sets logged_in() to false, then it will
                    986: close() the connection and set is_connected() to false
                    987:
                    988: I<expect>
                    989: - if this is set (usually to 'Success.') it will check for that in the
                    990: last line of output and if it does not, will return undef because the
                    991: command probably failed
                    992:
                    993: I<args>
                    994: - a string containing the command line options that are passed to the
                    995: command
                    996:
                    997:     $t->cmd( String => 'exit', no_prompt => 1, cmd_disconnects => 1 );
                    998:
                    999: =cut
                   1000:
                   1001: sub cmd {
                   1002:     my $self = shift;
1.59      andrew   1003:     my $s    = *$self->{net_telnet_trango};
1.40      andrew   1004:
                   1005:     my @valid_net_telnet_opts = qw(
1.57      andrew   1006:         String
                   1007:         Output
                   1008:         Cmd_remove_mode
                   1009:         Errmode
                   1010:         Input_record_separator
                   1011:         Ors
                   1012:         Output_record_separator
                   1013:         Prompt
                   1014:         Rs
                   1015:         Timeout
1.40      andrew   1016:     );
                   1017:
                   1018:     my %cfg;
                   1019:     if ( @_ == 1 ) {
                   1020:         $cfg{'String'} = shift;
                   1021:     }
                   1022:     elsif ( @_ > 1 ) {
                   1023:         %cfg = @_;
                   1024:     }
                   1025:
                   1026:     $cfg{'Timeout'} ||= $self->Timeout;
                   1027:
                   1028:     unless ( $cfg{'String'} ) {
                   1029:         $self->last_error("No command passed");
                   1030:         return;
                   1031:     }
                   1032:
                   1033:     unless ( $self->is_connected ) {
                   1034:         $self->last_error("Not connected");
                   1035:         return;
                   1036:     }
                   1037:
                   1038:     unless ( $self->logged_in ) {
                   1039:         $self->last_error("Not logged in");
                   1040:         return;
                   1041:     }
                   1042:
                   1043:     my %cmd;
                   1044:     foreach (@valid_net_telnet_opts) {
                   1045:         if ( exists $cfg{$_} ) {
                   1046:             $cmd{$_} = $cfg{$_};
                   1047:         }
                   1048:     }
                   1049:     if ( $cfg{'args'} ) {
                   1050:         $cmd{'String'} .= $SPACE . $cfg{'args'};
                   1051:     }
                   1052:
1.44      mike     1053:     #print "Running cmd $cmd{String}\n";
1.40      andrew   1054:     my @lines;
                   1055:     if ( $cfg{'no_prompt'} ) {
                   1056:         $self->print( $cmd{'String'} );
                   1057:         @lines = $self->lastline;
                   1058:     }
                   1059:     else {
                   1060:         @lines = $self->SUPER::cmd(%cmd);
                   1061:     }
                   1062:
                   1063:     $self->last_lines( \@lines );
                   1064:
1.57      andrew   1065:     my $last   = $self->lastline;
1.52      andrew   1066:     my $prompt = $self->prompt;
                   1067:     $prompt =~ s{^/}{}xms;
                   1068:     $prompt =~ s{/[gixms]*$}{}xms;
1.57      andrew   1069:     while ( @lines && $last =~ qr($prompt) ) {
1.52      andrew   1070:         pop @lines;
                   1071:         $last = $lines[-1];
                   1072:     }
                   1073:     $self->last_error($EMPTY);
                   1074:
1.40      andrew   1075:     my $vals = 1;
1.59      andrew   1076:     if ( $s->{'Decode'} && $cfg{'decode'} ) {
1.40      andrew   1077:         if ( $cfg{'decode'} eq 'each' ) {
                   1078:             $vals = _decode_each_line(@lines);
                   1079:         }
                   1080:         elsif ( $cfg{'decode'} eq 'sulog' ) {
                   1081:             $vals = _decode_sulog(@lines);
                   1082:         }
                   1083:         elsif ( $cfg{'decode'} eq 'maclist' ) {
                   1084:             $vals = _decode_maclist(@lines);
1.57      andrew   1085:             if ( !$vals ) {
1.41      andrew   1086:                 $self->last_error("Error decoding maclist");
1.46      andrew   1087:             }
                   1088:         }
                   1089:         elsif ( $cfg{'decode'} eq 'linktest' ) {
                   1090:             $vals = _decode_linktest(@lines);
1.57      andrew   1091:             if ( !$vals ) {
1.46      andrew   1092:                 $self->last_error("Error decoding linktest");
1.41      andrew   1093:             }
1.40      andrew   1094:         }
1.59      andrew   1095:         elsif ( $cfg{'decode'} eq 'freq' ) {
                   1096:             $vals = _decode_freq(@lines);
                   1097:         }
1.40      andrew   1098:         else {
                   1099:             $vals = _decode_lines(@lines);
                   1100:         }
                   1101:     }
1.59      andrew   1102:     if ( ref $vals eq 'HASH' ) {
                   1103:         $vals->{_raw} = join q{}, @lines;
                   1104:     }
1.40      andrew   1105:     $self->last_vals($vals);
                   1106:
                   1107:     if ( ( not $cfg{'expect'} ) || $last =~ /$cfg{'expect'}$/ ) {
                   1108:         if ( $cfg{'cmd_disconnects'} ) {
                   1109:             $self->logged_in(0);
                   1110:             $self->close;
                   1111:             $self->is_connected(0);
                   1112:         }
                   1113:
1.59      andrew   1114:         if ( $s->{'Decode'} && $cfg{'decode'} ) {
1.40      andrew   1115:             return $vals;
                   1116:         }
                   1117:         else {
                   1118:             return \@lines;
                   1119:         }
                   1120:     }
                   1121:     else {
                   1122:         my $err;
1.57      andrew   1123:         if ( grep {/\[ERR\]/} @lines ) {
1.40      andrew   1124:             $err = _decode_lines(@lines);
1.57      andrew   1125:         }
1.40      andrew   1126:
1.57      andrew   1127:         if ( ref $err eq 'HASH' && $err->{ERR} ) {
                   1128:             $self->last_error( $err->{ERR} );
                   1129:         }
                   1130:         else {
1.42      andrew   1131:             $self->last_error("Error with command ($cmd{'String'}): $last");
1.40      andrew   1132:         }
                   1133:         return;
                   1134:     }
                   1135: }
                   1136:
                   1137: #=item _decode_lines
                   1138:
                   1139: sub _decode_lines {
                   1140:     my @lines = @_;
                   1141:
                   1142:     my %conf;
                   1143:
                   1144:     my $key = $EMPTY;
                   1145:     my $val = undef;
                   1146:     my @vals;
                   1147:     my $in_key = 0;
                   1148:     my $in_val = 1;
                   1149:
1.57      andrew   1150: LINE: while ( my $line = shift @lines ) {
1.52      andrew   1151:         next LINE if $line =~ /$success\Z/;
                   1152:         next LINE if $line =~ /^ \*+ \s+ \d+ \s+ \*+ \Z/xms;
                   1153:
                   1154:         # Special decode for sysinfo on a TrangoLink 45
1.57      andrew   1155:         if ( $line =~ /^(.* Channel \s+ Table):\s*(.*)\Z/xms ) {
1.52      andrew   1156:             my $key  = $1;
                   1157:             my $note = $2;
                   1158:
                   1159:             my %vals;
1.57      andrew   1160:             while ( $line = shift @lines ) {
                   1161:                 if ( $line =~ /^\Z/ ) {
1.52      andrew   1162:                     $conf{$key} = \%vals;
                   1163:                     $conf{$key}{note} = $note;
                   1164:                     next LINE;
                   1165:                 }
                   1166:
                   1167:                 my $decoded = _decode_lines($line);
                   1168:                 if ($decoded) {
1.57      andrew   1169:                     %vals = ( %vals, %{$decoded} );
1.52      andrew   1170:                 }
                   1171:             }
                   1172:         }
1.57      andrew   1173:
1.52      andrew   1174:         # Another special decode for the TrangoLink
1.57      andrew   1175:         elsif (
                   1176:             $line =~ /^
1.52      andrew   1177:             RF \s Band \s \#
                   1178:             (\d+) \s+
                   1179:             \( ([^\)]+) \) \s*
                   1180:             (.*)$
1.57      andrew   1181:         /xms
                   1182:             )
                   1183:         {
1.52      andrew   1184:             my $num   = $1;
                   1185:             my $band  = $2;
                   1186:             my $extra = $3;
                   1187:
1.57      andrew   1188:             if ( $extra =~ /\[/ ) {
1.52      andrew   1189:                 my $decoded = _decode_lines($extra);
                   1190:                 $conf{'RF Band'}{$num} = $decoded;
                   1191:             }
                   1192:             else {
                   1193:                 $conf{'RF Band'}{$num}{$extra} = 1;
                   1194:             }
                   1195:             next LINE;
                   1196:         }
1.40      andrew   1197:
                   1198:         my @chars = split //, $line;
                   1199:
                   1200:         my $last_key = $EMPTY;
                   1201:         foreach my $c (@chars) {
                   1202:
                   1203:             if ( $c eq '[' || $c eq "\r" || $c eq "\n" ) {
                   1204:                 if ( $c eq '[' ) {
                   1205:                     $in_key = 1;
                   1206:                     $in_val = 0;
                   1207:                 }
                   1208:                 else {
                   1209:                     $in_key = 0;
                   1210:                     $in_val = 1;
                   1211:                 }
                   1212:
                   1213:                 if ($key) {
                   1214:                     $key =~ s/^\s+//;
                   1215:                     $key =~ s/\s+$//;
                   1216:
                   1217:                     if ($val) {
                   1218:                         $val =~ s/^\s+//;
1.59      andrew   1219:                         $val =~ s/\s+\.*$//;
1.40      andrew   1220:                     }
                   1221:
                   1222:                     if ( $key eq 'Checksum' && $last_key ) {
                   1223:
                   1224:                         # Special case for these bastids.
                   1225:                         my $new = $last_key;
                   1226:                         $new =~ s/\s+\S+$//;
                   1227:                         $key = $new . $SPACE . $key;
                   1228:                     }
                   1229:
                   1230:                     $conf{$key} = $val;
                   1231:                     $last_key   = $key;
                   1232:                     $key        = $EMPTY;
                   1233:                 }
                   1234:                 elsif ($val) {
                   1235:                     push @vals, $val;
                   1236:                 }
                   1237:                 $val = $EMPTY;
                   1238:
                   1239:             }
                   1240:             elsif ( $c eq ']' ) {
                   1241:                 $in_val = 1;
                   1242:                 $in_key = 0;
                   1243:                 $c      = shift @chars;
                   1244:
                   1245:             }
                   1246:             elsif ($in_key) {
                   1247:                 $key .= $c;
                   1248:
                   1249:             }
                   1250:             elsif ($in_val) {
                   1251:                 $val .= $c;
                   1252:             }
                   1253:         }
                   1254:     }
                   1255:
                   1256:     unless ($key) {
                   1257:         push @vals, $val;
                   1258:     }
                   1259:
1.59      andrew   1260:     foreach my $val (@vals) {
                   1261:         if ( defined $val && length $val ) {
                   1262:             $val =~ s/^\s+//;
                   1263:             $val =~ s/\s+\.*$//;
                   1264:         }
                   1265:     }
                   1266:
1.40      andrew   1267:     if ( @vals == 1 ) {
                   1268:         $val = $vals[0];
                   1269:     }
                   1270:     elsif (@vals) {
                   1271:         $val = \@vals;
                   1272:     }
                   1273:     else {
                   1274:         $val = undef;
                   1275:     }
                   1276:
                   1277:     if (%conf) {
                   1278:         $conf{_pre} = $val if $val;
                   1279:         return \%conf;
                   1280:     }
                   1281:     else {
                   1282:         return $val;
                   1283:     }
                   1284: }
                   1285:
                   1286: #=item _decode_each_line
                   1287:
                   1288: sub _decode_each_line {
                   1289:     my @lines = @_;
                   1290:     my @decoded;
                   1291:     foreach my $line (@lines) {
                   1292:         my $decoded = _decode_lines($line);
1.59      andrew   1293:         push @decoded, $decoded if defined $decoded && length $decoded;
1.40      andrew   1294:     }
                   1295:     return \@decoded;
1.45      andrew   1296: }
                   1297:
                   1298: #=item _decode_linktest
                   1299:
                   1300: sub _decode_linktest {
                   1301:     my @lines = @_;
                   1302:     my %decoded;
                   1303:     foreach my $line (@lines) {
                   1304:
1.57      andrew   1305:         if ( $line =~ s/^(\d+) \s+ //xms ) {
1.45      andrew   1306:             my $line_id = $1;
1.57      andrew   1307:             my ( $tm, $rt );
                   1308:             if ( $line =~ s/\s+ (\d+ \s+ \w+) \s* $//xms ) {
                   1309:                 $rt = $1;
                   1310:             }
                   1311:             if ( $line =~ s/\s+ (\d+ \s+ \w+) \s* $//xms ) {
                   1312:                 $tm = $1;
                   1313:             }
1.49      andrew   1314:
1.57      andrew   1315:             my $d = _decode_lines( $line . "\n" );
                   1316:             $decoded{tests}[$line_id]         = $d;
1.49      andrew   1317:             $decoded{tests}[$line_id]{'time'} = $tm;
                   1318:             $decoded{tests}[$line_id]{rate}   = $rt;
1.45      andrew   1319:         }
                   1320:
                   1321:         else {
1.57      andrew   1322:             my $d = _decode_lines( $line . "\n" );
1.45      andrew   1323:             if ($d) {
1.57      andrew   1324:                 while ( my ( $k, $v ) = each %{$d} ) {
1.45      andrew   1325:                     $decoded{$k} = $v;
                   1326:                 }
1.57      andrew   1327:             }
1.45      andrew   1328:         }
                   1329:
                   1330:     }
                   1331:     return \%decoded;
1.40      andrew   1332: }
                   1333:
                   1334: #=item _decode_sulog
                   1335:
                   1336: sub _decode_sulog {
                   1337:     my @lines = @_;
                   1338:     my @decoded;
                   1339:     my $last_tm;
                   1340:     foreach my $line (@lines) {
                   1341:         my $decoded = _decode_lines($line);
                   1342:
                   1343:         if ( defined $decoded ) {
                   1344:             if ( $decoded->{'tm'} ) {
                   1345:                 $last_tm = $decoded->{'tm'};
                   1346:                 next;
                   1347:             }
                   1348:             else {
                   1349:                 $decoded->{'tm'} = $last_tm;
                   1350:             }
                   1351:             next unless $last_tm;
                   1352:
                   1353:             push @decoded, $decoded if defined $decoded;
                   1354:         }
                   1355:     }
                   1356:     return \@decoded;
                   1357: }
                   1358:
                   1359: #=item _decode_maclist
                   1360:
                   1361: sub _decode_maclist {
                   1362:     my @lines = @_;
                   1363:     my @decoded;
                   1364:     my $total_entries = 0;
                   1365:     my $current_tm    = 0;
                   1366:     foreach my $line (@lines) {
                   1367:         $line =~ s/\r?\n$//;
                   1368:         my ( $mac, $loc, $tm ) = $line =~ /
                   1369:             ([0-9a-fA-F ]{17})\s+
                   1370:             (.*)\s+
                   1371:             tm\s+
                   1372:             (\d+)
                   1373:         /x;
                   1374:
                   1375:         if ($mac) {
                   1376:             $mac =~ s/\s+//g;
                   1377:             $loc =~ s/^\s+//;
                   1378:             $loc =~ s/\s+$//;
                   1379:
                   1380:             my $suid = undef;
                   1381:             if ( $loc =~ /suid\s+=\s+(\d+)/ ) {
                   1382:                 $suid = $1;
                   1383:                 $loc  = undef;
                   1384:             }
                   1385:
                   1386:             push @decoded,
1.57      andrew   1387:                 {
1.40      andrew   1388:                 mac  => $mac,
                   1389:                 loc  => $loc,
                   1390:                 tm   => $tm,
                   1391:                 suid => $suid,
1.57      andrew   1392:                 };
1.40      andrew   1393:         }
                   1394:         elsif ( $line =~ /(\d+)\s+entries/ ) {
                   1395:             $total_entries = $1;
                   1396:         }
                   1397:         elsif ( $line =~ /current tm = (\d+)\s+sec/ ) {
                   1398:             $current_tm = $1;
                   1399:         }
                   1400:     }
                   1401:
                   1402:     map { $_->{'cur_tm'} = $current_tm } @decoded;
                   1403:
                   1404:     if ( scalar @decoded == $total_entries ) {
                   1405:         return \@decoded;
                   1406:     }
                   1407:     else {
                   1408:         return;
                   1409:     }
1.59      andrew   1410: }
                   1411:
                   1412: #=item _decode_freq
                   1413:
                   1414: sub _decode_freq {
                   1415:     my @lines   = @_;
                   1416:     my $decoded = _decode_lines(@lines);
                   1417:
                   1418:     if ( $decoded && $decoded->{ERR} ) {
                   1419:         return $decoded;
                   1420:     }
                   1421:
                   1422: LINE: foreach my $line (@lines) {
                   1423:         if (my ( $channel, $polarity, $freq )
                   1424:             = $line =~ /
                   1425:             Ch \s+ \#(\d+)
                   1426:             \s+
                   1427:             (\w+)
                   1428:             \s+
                   1429:             \[ (\d+) \s+ MHz\]
                   1430:         /ixms
                   1431:             )
                   1432:         {
                   1433:             $decoded = {
                   1434:                 channel   => $channel,
                   1435:                 polarity  => $polarity,
                   1436:                 frequency => $freq,
                   1437:             };
                   1438:             last LINE;
                   1439:         }
                   1440:     }
                   1441:     return $decoded;
1.40      andrew   1442: }
                   1443:
                   1444: 1;    # End of Net::Telnet::Trango
                   1445: __END__
                   1446:
                   1447: =head1 SEE ALSO
                   1448:
                   1449: Trango Documentation -
                   1450: L<http://www.trangobroadband.com/support/product_docs.htm>
                   1451:
                   1452: L<Net::Telnet>
                   1453:
                   1454: =head1 TODO
                   1455:
                   1456: There are still a lot of commands that are not accessed directly.  If
                   1457: you call them (as cmd("command + args") or whatever) and it works,
                   1458: please send me examples that work and I will try to get it incorporated
                   1459: into the next version of the script.
                   1460:
                   1461: I also want to be able to parse the different types of output from
                   1462: commands like su, sudb all and anything else that would be better
                   1463: available as a perl datastructure.
                   1464:
                   1465: =head1 AUTHOR
                   1466:
                   1467: Andrew Fresh E<lt>andrew@rraz.netE<gt>
                   1468:
                   1469: =head1 SUPPORT
                   1470:
                   1471: You can find documentation for this module with the perldoc command.
                   1472:
                   1473:     perldoc Net::Telnet::Trango
                   1474:
                   1475: You can also look for information at:
                   1476:
                   1477: =over 4
                   1478:
                   1479: =item * AnnoCPAN: Annotated CPAN documentation
                   1480:
                   1481: L<http://annocpan.org/dist/Net-Telnet-Trango>
                   1482:
                   1483: =item * CPAN Ratings
                   1484:
                   1485: L<http://cpanratings.perl.org/d/Net-Telnet-Trango>
                   1486:
                   1487: =item * RT: CPAN's request tracker
                   1488:
                   1489: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Telnet-Trango>
                   1490:
                   1491: =item * Search CPAN
                   1492:
                   1493: L<http://search.cpan.org/dist/Net-Telnet-Trango>
                   1494:
                   1495: =back
                   1496:
                   1497: =head1 COPYRIGHT AND LICENSE
                   1498:
                   1499: Copyright (C) 2005,2006,2007 by Andrew Fresh
                   1500:
                   1501: This program is free software; you can redistribute it and/or modify it
                   1502: under the same terms as Perl itself.
                   1503:
                   1504: =cut

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>