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