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

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

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