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