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