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