[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.41

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

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