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