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

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

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