Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Net::Telnet; |
2 | ||
3 | ## Copyright 1997, 2000, 2002 Jay Rogers. All rights reserved. | |
4 | ## This program is free software; you can redistribute it and/or | |
5 | ## modify it under the same terms as Perl itself. | |
6 | ||
7 | ## See user documentation at the end of this file. Search for =head | |
8 | ||
9 | use strict; | |
10 | require 5.002; | |
11 | ||
12 | ## Module export. | |
13 | use vars qw(@EXPORT_OK); | |
14 | @EXPORT_OK = qw(TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL | |
15 | TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO | |
16 | TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE | |
17 | TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH | |
18 | TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS | |
19 | TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP | |
20 | TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD | |
21 | TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII | |
22 | TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP | |
23 | TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR | |
24 | TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME | |
25 | TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW | |
26 | TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON | |
27 | TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON | |
28 | TELOPT_EXOPL); | |
29 | ||
30 | ## Module import. | |
31 | use Exporter (); | |
32 | use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in); | |
33 | use Symbol qw(qualify); | |
34 | ||
35 | ## Base classes. | |
36 | use vars qw(@ISA); | |
37 | @ISA = qw(Exporter); | |
38 | if (&_io_socket_include) { # successfully required module IO::Socket | |
39 | push @ISA, "IO::Socket::INET"; | |
40 | } | |
41 | else { # perl version < 5.004 | |
42 | require FileHandle; | |
43 | push @ISA, "FileHandle"; | |
44 | } | |
45 | ||
46 | ## Global variables. | |
47 | use vars qw($VERSION @Telopts); | |
48 | $VERSION = "3.03"; | |
49 | @Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAME", "STATUS", | |
50 | "TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS", | |
51 | "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII", | |
52 | "LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP", | |
53 | "SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD", | |
54 | "TACACS UID", "OUTPUT MARKING", "TTYLOC", "3270 REGIME", "X.3 PAD", | |
55 | "NAWS", "TSPEED", "LFLOW", "LINEMODE", "XDISPLOC", "OLD-ENVIRON", | |
56 | "AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON"); | |
57 | ||
58 | ||
59 | ########################### Public Methods ########################### | |
60 | ||
61 | ||
62 | sub new { | |
63 | my ($class) = @_; | |
64 | my ( | |
65 | $errmode, | |
66 | $fh_open, | |
67 | $host, | |
68 | $self, | |
69 | %args, | |
70 | ); | |
71 | local $_; | |
72 | ||
73 | ## Create a new object with defaults. | |
74 | $self = $class->SUPER::new; | |
75 | *$self->{net_telnet} = { | |
76 | bin_mode => 0, | |
77 | blksize => &_optimal_blksize(), | |
78 | buf => "", | |
79 | cmd_prompt => '/[\$%#>] $/', | |
80 | cmd_rm_mode => "auto", | |
81 | dumplog => '', | |
82 | eofile => 1, | |
83 | errormode => "die", | |
84 | errormsg => "", | |
85 | fdmask => '', | |
86 | host => "localhost", | |
87 | inputlog => '', | |
88 | last_line => "", | |
89 | last_prompt => "", | |
90 | maxbufsize => 1_048_576, | |
91 | num_wrote => 0, | |
92 | ofs => "", | |
93 | opened => '', | |
94 | opt_cback => '', | |
95 | opt_log => '', | |
96 | opts => {}, | |
97 | ors => "\n", | |
98 | outputlog => '', | |
99 | pending_errormsg => "", | |
100 | port => 23, | |
101 | pushback_buf => "", | |
102 | rs => "\n", | |
103 | subopt_cback => '', | |
104 | telnet_mode => 1, | |
105 | time_out => 10, | |
106 | timedout => '', | |
107 | unsent_opts => "", | |
108 | }; | |
109 | ||
110 | ## Indicate that we'll accept an offer from remote side for it to echo | |
111 | ## and suppress go aheads. | |
112 | &_opt_accept($self, | |
113 | { option => &TELOPT_ECHO, | |
114 | is_remote => 1, | |
115 | is_enable => 1 }, | |
116 | { option => &TELOPT_SGA, | |
117 | is_remote => 1, | |
118 | is_enable => 1 }, | |
119 | ); | |
120 | ||
121 | ## Parse the args. | |
122 | if (@_ == 2) { # one positional arg given | |
123 | $host = $_[1]; | |
124 | } | |
125 | elsif (@_ > 2) { # named args given | |
126 | ## Get the named args. | |
127 | (undef, %args) = @_; | |
128 | ||
129 | ## Parse all other named args. | |
130 | foreach (keys %args) { | |
131 | if (/^-?binmode$/i) { | |
132 | $self->binmode($args{$_}); | |
133 | } | |
134 | elsif (/^-?cmd_remove_mode$/i) { | |
135 | $self->cmd_remove_mode($args{$_}); | |
136 | } | |
137 | elsif (/^-?dump_log$/i) { | |
138 | $self->dump_log($args{$_}); | |
139 | } | |
140 | elsif (/^-?errmode$/i) { | |
141 | $errmode = $args{$_}; | |
142 | } | |
143 | elsif (/^-?fhopen$/i) { | |
144 | $fh_open = $args{$_}; | |
145 | } | |
146 | elsif (/^-?host$/i) { | |
147 | $host = $args{$_}; | |
148 | } | |
149 | elsif (/^-?input_log$/i) { | |
150 | $self->input_log($args{$_}); | |
151 | } | |
152 | elsif (/^-?input_record_separator$/i or /^-?rs$/i) { | |
153 | $self->input_record_separator($args{$_}); | |
154 | } | |
155 | elsif (/^-?option_log$/i) { | |
156 | $self->option_log($args{$_}); | |
157 | } | |
158 | elsif (/^-?output_log$/i) { | |
159 | $self->output_log($args{$_}); | |
160 | } | |
161 | elsif (/^-?output_record_separator$/i or /^-?ors$/i) { | |
162 | $self->output_record_separator($args{$_}); | |
163 | } | |
164 | elsif (/^-?port$/i) { | |
165 | $self->port($args{$_}); | |
166 | } | |
167 | elsif (/^-?prompt$/i) { | |
168 | $self->prompt($args{$_}); | |
169 | } | |
170 | elsif (/^-?telnetmode$/i) { | |
171 | $self->telnetmode($args{$_}); | |
172 | } | |
173 | elsif (/^-?timeout$/i) { | |
174 | $self->timeout($args{$_}); | |
175 | } | |
176 | else { | |
177 | &_croak($self, "bad named parameter \"$_\" given " . | |
178 | "to " . ref($self) . "::new()"); | |
179 | } | |
180 | } | |
181 | } | |
182 | ||
183 | if (defined $errmode) { # user wants to set errmode | |
184 | $self->errmode($errmode); | |
185 | } | |
186 | ||
187 | if (defined $fh_open) { # user wants us to attach to existing filehandle | |
188 | $self->fhopen($fh_open) | |
189 | or return; | |
190 | } | |
191 | elsif (defined $host) { # user wants us to open a connection to host | |
192 | $self->host($host); | |
193 | $self->open | |
194 | or return; | |
195 | } | |
196 | ||
197 | $self; | |
198 | } # end sub new | |
199 | ||
200 | ||
201 | sub DESTROY { | |
202 | } # end sub DESTROY | |
203 | ||
204 | ||
205 | sub binmode { | |
206 | my ($self, $mode) = @_; | |
207 | my ( | |
208 | $prev, | |
209 | $s, | |
210 | ); | |
211 | ||
212 | $s = *$self->{net_telnet}; | |
213 | $prev = $s->{bin_mode}; | |
214 | ||
215 | if (@_ >= 2) { | |
216 | unless (defined $mode) { | |
217 | $mode = 0; | |
218 | } | |
219 | ||
220 | $s->{bin_mode} = $mode; | |
221 | } | |
222 | ||
223 | $prev; | |
224 | } # end sub binmode | |
225 | ||
226 | ||
227 | sub break { | |
228 | my ($self) = @_; | |
229 | my $s = *$self->{net_telnet}; | |
230 | my $break_cmd = "\xff\xf3"; | |
231 | ||
232 | $s->{timedout} = ''; | |
233 | ||
234 | &_put($self, \$break_cmd, "break"); | |
235 | } # end sub break | |
236 | ||
237 | ||
238 | sub buffer { | |
239 | my ($self) = @_; | |
240 | my $s = *$self->{net_telnet}; | |
241 | ||
242 | \$s->{buf}; | |
243 | } # end sub buffer | |
244 | ||
245 | ||
246 | sub buffer_empty { | |
247 | my ($self) = @_; | |
248 | my ( | |
249 | $buffer, | |
250 | ); | |
251 | ||
252 | $buffer = $self->buffer; | |
253 | $$buffer = ""; | |
254 | } # end sub buffer_empty | |
255 | ||
256 | ||
257 | sub close { | |
258 | my ($self) = @_; | |
259 | my $s = *$self->{net_telnet}; | |
260 | ||
261 | $s->{eofile} = 1; | |
262 | $s->{opened} = ''; | |
263 | close $self | |
264 | if defined fileno($self); | |
265 | ||
266 | 1; | |
267 | } # end sub close | |
268 | ||
269 | ||
270 | sub cmd { | |
271 | my ($self, @args) = @_; | |
272 | my ( | |
273 | $cmd_remove_mode, | |
274 | $errmode, | |
275 | $firstpos, | |
276 | $last_prompt, | |
277 | $lastpos, | |
278 | $lines, | |
279 | $ors, | |
280 | $output, | |
281 | $output_ref, | |
282 | $prompt, | |
283 | $remove_echo, | |
284 | $rs, | |
285 | $rs_len, | |
286 | $s, | |
287 | $telopt_echo, | |
288 | $timeout, | |
289 | %args, | |
290 | ); | |
291 | my $cmd = ""; | |
292 | local $_; | |
293 | ||
294 | ## Init. | |
295 | $self->timed_out(''); | |
296 | $self->last_prompt(""); | |
297 | $s = *$self->{net_telnet}; | |
298 | $output = []; | |
299 | $cmd_remove_mode = $self->cmd_remove_mode; | |
300 | $errmode = $self->errmode; | |
301 | $ors = $self->output_record_separator; | |
302 | $prompt = $self->prompt; | |
303 | $rs = $self->input_record_separator; | |
304 | $timeout = $self->timeout; | |
305 | ||
306 | ## Parse args. | |
307 | if (@_ == 2) { # one positional arg given | |
308 | $cmd = $_[1]; | |
309 | } | |
310 | elsif (@_ > 2) { # named args given | |
311 | ## Get the named args. | |
312 | (undef, %args) = @_; | |
313 | ||
314 | ## Parse the named args. | |
315 | foreach (keys %args) { | |
316 | if (/^-?cmd_remove/i) { | |
317 | $cmd_remove_mode = &_parse_cmd_remove_mode($self, $args{$_}); | |
318 | } | |
319 | elsif (/^-?errmode$/i) { | |
320 | $errmode = &_parse_errmode($self, $args{$_}); | |
321 | } | |
322 | elsif (/^-?input_record_separator$/i or /^-?rs$/i) { | |
323 | $rs = &_parse_input_record_separator($self, $args{$_}); | |
324 | } | |
325 | elsif (/^-?output$/i) { | |
326 | $output_ref = $args{$_}; | |
327 | if (defined($output_ref) and ref($output_ref) eq "ARRAY") { | |
328 | $output = $output_ref; | |
329 | } | |
330 | } | |
331 | elsif (/^-?output_record_separator$/i or /^-?ors$/i) { | |
332 | $ors = $self->output_record_separator($args{$_}); | |
333 | } | |
334 | elsif (/^-?prompt$/i) { | |
335 | $prompt = &_parse_prompt($self, $args{$_}); | |
336 | } | |
337 | elsif (/^-?string$/i) { | |
338 | $cmd = $args{$_}; | |
339 | } | |
340 | elsif (/^-?timeout$/i) { | |
341 | $timeout = &_parse_timeout($self, $args{$_}); | |
342 | } | |
343 | else { | |
344 | &_croak($self, "bad named parameter \"$_\" given " . | |
345 | "to " . ref($self) . "::cmd()"); | |
346 | } | |
347 | } | |
348 | } | |
349 | ||
350 | ## Override some user settings. | |
351 | local $s->{errormode} = "return"; | |
352 | local $s->{time_out} = &_endtime($timeout); | |
353 | $self->errmsg(""); | |
354 | ||
355 | ## Send command and wait for the prompt. | |
356 | $self->put($cmd . $ors) | |
357 | and ($lines, $last_prompt) = $self->waitfor($prompt); | |
358 | ||
359 | ## Check for failure. | |
360 | $s->{errormode} = $errmode; | |
361 | return $self->error("command timed-out") if $self->timed_out; | |
362 | return $self->error($self->errmsg) if $self->errmsg ne ""; | |
363 | ||
364 | ## Save the most recently matched prompt. | |
365 | $self->last_prompt($last_prompt); | |
366 | ||
367 | ## Split lines into an array, keeping record separator at end of line. | |
368 | $firstpos = 0; | |
369 | $rs_len = length $rs; | |
370 | while (($lastpos = index($lines, $rs, $firstpos)) > -1) { | |
371 | push(@$output, | |
372 | substr($lines, $firstpos, $lastpos - $firstpos + $rs_len)); | |
373 | $firstpos = $lastpos + $rs_len; | |
374 | } | |
375 | ||
376 | if ($firstpos < length $lines) { | |
377 | push @$output, substr($lines, $firstpos); | |
378 | } | |
379 | ||
380 | ## Determine if we should remove the first line of output based | |
381 | ## on the assumption that it's an echoed back command. | |
382 | if ($cmd_remove_mode eq "auto") { | |
383 | ## See if remote side told us they'd echo. | |
384 | $telopt_echo = $self->option_state(&TELOPT_ECHO); | |
385 | $remove_echo = $telopt_echo->{remote_enabled}; | |
386 | } | |
387 | else { # user explicitly told us how many lines to remove. | |
388 | $remove_echo = $cmd_remove_mode; | |
389 | } | |
390 | ||
391 | ## Get rid of possible echo back command. | |
392 | while ($remove_echo--) { | |
393 | shift @$output; | |
394 | } | |
395 | ||
396 | ## Ensure at least a null string when there's no command output - so | |
397 | ## "true" is returned in a list context. | |
398 | unless (@$output) { | |
399 | @$output = (""); | |
400 | } | |
401 | ||
402 | ## Return command output via named arg, if requested. | |
403 | if (defined $output_ref) { | |
404 | if (ref($output_ref) eq "SCALAR") { | |
405 | $$output_ref = join "", @$output; | |
406 | } | |
407 | elsif (ref($output_ref) eq "HASH") { | |
408 | %$output_ref = @$output; | |
409 | } | |
410 | } | |
411 | ||
412 | wantarray ? @$output : 1; | |
413 | } # end sub cmd | |
414 | ||
415 | ||
416 | sub cmd_remove_mode { | |
417 | my ($self, $mode) = @_; | |
418 | my ( | |
419 | $prev, | |
420 | $s, | |
421 | ); | |
422 | ||
423 | $s = *$self->{net_telnet}; | |
424 | $prev = $s->{cmd_rm_mode}; | |
425 | ||
426 | if (@_ >= 2) { | |
427 | $s->{cmd_rm_mode} = &_parse_cmd_remove_mode($self, $mode); | |
428 | } | |
429 | ||
430 | $prev; | |
431 | } # end sub cmd_remove_mode | |
432 | ||
433 | ||
434 | sub dump_log { | |
435 | my ($self, $name) = @_; | |
436 | my ( | |
437 | $fh, | |
438 | $s, | |
439 | ); | |
440 | ||
441 | $s = *$self->{net_telnet}; | |
442 | $fh = $s->{dumplog}; | |
443 | ||
444 | if (@_ >= 2) { | |
445 | unless (defined $name) { | |
446 | $name = ""; | |
447 | } | |
448 | ||
449 | $fh = &_fname_to_handle($self, $name) | |
450 | or return; | |
451 | $s->{dumplog} = $fh; | |
452 | } | |
453 | ||
454 | $fh; | |
455 | } # end sub dump_log | |
456 | ||
457 | ||
458 | sub eof { | |
459 | my ($self) = @_; | |
460 | ||
461 | *$self->{net_telnet}{eofile}; | |
462 | } # end sub eof | |
463 | ||
464 | ||
465 | sub errmode { | |
466 | my ($self, $mode) = @_; | |
467 | my ( | |
468 | $prev, | |
469 | $s, | |
470 | ); | |
471 | ||
472 | $s = *$self->{net_telnet}; | |
473 | $prev = $s->{errormode}; | |
474 | ||
475 | if (@_ >= 2) { | |
476 | $s->{errormode} = &_parse_errmode($self, $mode); | |
477 | } | |
478 | ||
479 | $prev; | |
480 | } # end sub errmode | |
481 | ||
482 | ||
483 | sub errmsg { | |
484 | my ($self, @errmsgs) = @_; | |
485 | my ( | |
486 | $prev, | |
487 | $s, | |
488 | ); | |
489 | ||
490 | $s = *$self->{net_telnet}; | |
491 | $prev = $s->{errormsg}; | |
492 | ||
493 | if (@_ >= 2) { | |
494 | $s->{errormsg} = join "", @errmsgs; | |
495 | } | |
496 | ||
497 | $prev; | |
498 | } # end sub errmsg | |
499 | ||
500 | ||
501 | sub error { | |
502 | my ($self, @errmsg) = @_; | |
503 | my ( | |
504 | $errmsg, | |
505 | $func, | |
506 | $mode, | |
507 | $s, | |
508 | @args, | |
509 | ); | |
510 | local $_; | |
511 | ||
512 | $s = *$self->{net_telnet}; | |
513 | ||
514 | if (@_ >= 2) { | |
515 | ## Put error message in the object. | |
516 | $errmsg = join "", @errmsg; | |
517 | $s->{errormsg} = $errmsg; | |
518 | ||
519 | ## Do the error action as described by error mode. | |
520 | $mode = $s->{errormode}; | |
521 | if (ref($mode) eq "CODE") { | |
522 | &$mode($errmsg); | |
523 | return; | |
524 | } | |
525 | elsif (ref($mode) eq "ARRAY") { | |
526 | ($func, @args) = @$mode; | |
527 | &$func(@args); | |
528 | return; | |
529 | } | |
530 | elsif ($mode =~ /^return$/i) { | |
531 | return; | |
532 | } | |
533 | else { # die | |
534 | if ($errmsg =~ /\n$/) { | |
535 | die $errmsg; | |
536 | } | |
537 | else { | |
538 | ## Die and append caller's line number to message. | |
539 | &_croak($self, $errmsg); | |
540 | } | |
541 | } | |
542 | } | |
543 | else { | |
544 | return $s->{errormsg} ne ""; | |
545 | } | |
546 | } # end sub error | |
547 | ||
548 | ||
549 | sub fhopen { | |
550 | my ($self, $fh) = @_; | |
551 | my ( | |
552 | $globref, | |
553 | $s, | |
554 | ); | |
555 | ||
556 | ## Convert given filehandle to a typeglob reference, if necessary. | |
557 | $globref = &_qualify_fh($self, $fh); | |
558 | ||
559 | ## Ensure filehandle is already open. | |
560 | return $self->error("fhopen filehandle isn't already open") | |
561 | unless defined($globref) and defined(fileno $globref); | |
562 | ||
563 | ## Ensure we're closed. | |
564 | $self->close; | |
565 | ||
566 | ## Save our private data. | |
567 | $s = *$self->{net_telnet}; | |
568 | ||
569 | ## Switch ourself with the given filehandle. | |
570 | *$self = *$globref; | |
571 | ||
572 | ## Restore our private data. | |
573 | *$self->{net_telnet} = $s; | |
574 | ||
575 | ## Re-initialize ourself. | |
576 | select((select($self), $|=1)[$[]); # don't buffer writes | |
577 | $s = *$self->{net_telnet}; | |
578 | $s->{blksize} = &_optimal_blksize((stat $self)[11]); | |
579 | $s->{buf} = ""; | |
580 | $s->{eofile} = ''; | |
581 | $s->{errormsg} = ""; | |
582 | vec($s->{fdmask}='', fileno($self), 1) = 1; | |
583 | $s->{host} = ""; | |
584 | $s->{last_line} = ""; | |
585 | $s->{last_prompt} = ""; | |
586 | $s->{num_wrote} = 0; | |
587 | $s->{opened} = 1; | |
588 | $s->{pending_errormsg} = ""; | |
589 | $s->{port} = ''; | |
590 | $s->{pushback_buf} = ""; | |
591 | $s->{timedout} = ''; | |
592 | $s->{unsent_opts} = ""; | |
593 | &_reset_options($s->{opts}); | |
594 | ||
595 | 1; | |
596 | } # end sub fhopen | |
597 | ||
598 | ||
599 | sub get { | |
600 | my ($self, %args) = @_; | |
601 | my ( | |
602 | $binmode, | |
603 | $endtime, | |
604 | $errmode, | |
605 | $line, | |
606 | $s, | |
607 | $telnetmode, | |
608 | $timeout, | |
609 | ); | |
610 | local $_; | |
611 | ||
612 | ## Init. | |
613 | $s = *$self->{net_telnet}; | |
614 | $timeout = $s->{time_out}; | |
615 | $s->{timedout} = ''; | |
616 | return if $s->{eofile}; | |
617 | ||
618 | ## Parse the named args. | |
619 | foreach (keys %args) { | |
620 | if (/^-?binmode$/i) { | |
621 | $binmode = $args{$_}; | |
622 | unless (defined $binmode) { | |
623 | $binmode = 0; | |
624 | } | |
625 | } | |
626 | elsif (/^-?errmode$/i) { | |
627 | $errmode = &_parse_errmode($self, $args{$_}); | |
628 | } | |
629 | elsif (/^-?telnetmode$/i) { | |
630 | $telnetmode = $args{$_}; | |
631 | unless (defined $telnetmode) { | |
632 | $telnetmode = 0; | |
633 | } | |
634 | } | |
635 | elsif (/^-?timeout$/i) { | |
636 | $timeout = &_parse_timeout($self, $args{$_}); | |
637 | } | |
638 | else { | |
639 | &_croak($self, "bad named parameter \"$_\" given " . | |
640 | "to " . ref($self) . "::get()"); | |
641 | } | |
642 | } | |
643 | ||
644 | ## If any args given, override corresponding instance data. | |
645 | local $s->{errormode} = $errmode | |
646 | if defined $errmode; | |
647 | local $s->{bin_mode} = $binmode | |
648 | if defined $binmode; | |
649 | local $s->{telnet_mode} = $telnetmode | |
650 | if defined $telnetmode; | |
651 | ||
652 | ## Set wall time when we time out. | |
653 | $endtime = &_endtime($timeout); | |
654 | ||
655 | ## Try to send any waiting option negotiation. | |
656 | if (length $s->{unsent_opts}) { | |
657 | &_flush_opts($self); | |
658 | } | |
659 | ||
660 | ## Try to read just the waiting data using return error mode. | |
661 | { | |
662 | local $s->{errormode} = "return"; | |
663 | $s->{errormsg} = ""; | |
664 | &_fillbuf($self, $s, 0); | |
665 | } | |
666 | ||
667 | ## We're done if we timed-out and timeout value is set to "poll". | |
668 | return $self->error($s->{errormsg}) | |
669 | if ($s->{timedout} and defined($timeout) and $timeout == 0 | |
670 | and !length $s->{buf}); | |
671 | ||
672 | ## We're done if we hit an error other than timing out. | |
673 | if ($s->{errormsg} and !$s->{timedout}) { | |
674 | if (!length $s->{buf}) { | |
675 | return $self->error($s->{errormsg}); | |
676 | } | |
677 | else { # error encountered but there's some data in buffer | |
678 | $s->{pending_errormsg} = $s->{errormsg}; | |
679 | } | |
680 | } | |
681 | ||
682 | ## Clear time-out error from first read. | |
683 | $s->{timedout} = ''; | |
684 | $s->{errormsg} = ""; | |
685 | ||
686 | ## If buffer is still empty, try to read according to user's timeout. | |
687 | if (!length $s->{buf}) { | |
688 | &_fillbuf($self, $s, $endtime) | |
689 | or do { | |
690 | return if $s->{timedout}; | |
691 | ||
692 | ## We've reached end-of-file. | |
693 | $self->close; | |
694 | return; | |
695 | }; | |
696 | } | |
697 | ||
698 | ## Extract chars from buffer. | |
699 | $line = $s->{buf}; | |
700 | $s->{buf} = ""; | |
701 | ||
702 | $line; | |
703 | } # end sub get | |
704 | ||
705 | ||
706 | sub getline { | |
707 | my ($self, %args) = @_; | |
708 | my ( | |
709 | $binmode, | |
710 | $endtime, | |
711 | $errmode, | |
712 | $len, | |
713 | $line, | |
714 | $offset, | |
715 | $pos, | |
716 | $rs, | |
717 | $s, | |
718 | $telnetmode, | |
719 | $timeout, | |
720 | ); | |
721 | local $_; | |
722 | ||
723 | ## Init. | |
724 | $s = *$self->{net_telnet}; | |
725 | $s->{timedout} = ''; | |
726 | return if $s->{eofile}; | |
727 | $rs = $s->{rs}; | |
728 | $timeout = $s->{time_out}; | |
729 | ||
730 | ## Parse the named args. | |
731 | foreach (keys %args) { | |
732 | if (/^-?binmode$/i) { | |
733 | $binmode = $args{$_}; | |
734 | unless (defined $binmode) { | |
735 | $binmode = 0; | |
736 | } | |
737 | } | |
738 | elsif (/^-?errmode$/i) { | |
739 | $errmode = &_parse_errmode($self, $args{$_}); | |
740 | } | |
741 | elsif (/^-?input_record_separator$/i or /^-?rs$/i) { | |
742 | $rs = &_parse_input_record_separator($self, $args{$_}); | |
743 | } | |
744 | elsif (/^-?telnetmode$/i) { | |
745 | $telnetmode = $args{$_}; | |
746 | unless (defined $telnetmode) { | |
747 | $telnetmode = 0; | |
748 | } | |
749 | } | |
750 | elsif (/^-?timeout$/i) { | |
751 | $timeout = &_parse_timeout($self, $args{$_}); | |
752 | } | |
753 | else { | |
754 | &_croak($self, "bad named parameter \"$_\" given " . | |
755 | "to " . ref($self) . "::getline()"); | |
756 | } | |
757 | } | |
758 | ||
759 | ## If any args given, override corresponding instance data. | |
760 | local $s->{bin_mode} = $binmode | |
761 | if defined $binmode; | |
762 | local $s->{errormode} = $errmode | |
763 | if defined $errmode; | |
764 | local $s->{telnet_mode} = $telnetmode | |
765 | if defined $telnetmode; | |
766 | ||
767 | ## Set wall time when we time out. | |
768 | $endtime = &_endtime($timeout); | |
769 | ||
770 | ## Try to send any waiting option negotiation. | |
771 | if (length $s->{unsent_opts}) { | |
772 | &_flush_opts($self); | |
773 | } | |
774 | ||
775 | ## Keep reading into buffer until end-of-line is read. | |
776 | $offset = 0; | |
777 | while (($pos = index($s->{buf}, $rs, $offset)) == -1) { | |
778 | $offset = length $s->{buf}; | |
779 | &_fillbuf($self, $s, $endtime) | |
780 | or do { | |
781 | return if $s->{timedout}; | |
782 | ||
783 | ## We've reached end-of-file. | |
784 | $self->close; | |
785 | if (length $s->{buf}) { | |
786 | return $s->{buf}; | |
787 | } | |
788 | else { | |
789 | return; | |
790 | } | |
791 | }; | |
792 | } | |
793 | ||
794 | ## Extract line from buffer. | |
795 | $len = $pos + length $rs; | |
796 | $line = substr($s->{buf}, 0, $len); | |
797 | substr($s->{buf}, 0, $len) = ""; | |
798 | ||
799 | $line; | |
800 | } # end sub getline | |
801 | ||
802 | ||
803 | sub getlines { | |
804 | my ($self, %args) = @_; | |
805 | my ( | |
806 | $binmode, | |
807 | $errmode, | |
808 | $line, | |
809 | $rs, | |
810 | $s, | |
811 | $telnetmode, | |
812 | $timeout, | |
813 | ); | |
814 | my $all = 1; | |
815 | my @lines = (); | |
816 | local $_; | |
817 | ||
818 | ## Init. | |
819 | $s = *$self->{net_telnet}; | |
820 | $s->{timedout} = ''; | |
821 | return if $s->{eofile}; | |
822 | $timeout = $s->{time_out}; | |
823 | ||
824 | ## Parse the named args. | |
825 | foreach (keys %args) { | |
826 | if (/^-?all$/i) { | |
827 | $all = $args{$_}; | |
828 | unless (defined $all) { | |
829 | $all = ''; | |
830 | } | |
831 | } | |
832 | elsif (/^-?binmode$/i) { | |
833 | $binmode = $args{$_}; | |
834 | unless (defined $binmode) { | |
835 | $binmode = 0; | |
836 | } | |
837 | } | |
838 | elsif (/^-?errmode$/i) { | |
839 | $errmode = &_parse_errmode($self, $args{$_}); | |
840 | } | |
841 | elsif (/^-?input_record_separator$/i or /^-?rs$/i) { | |
842 | $rs = &_parse_input_record_separator($self, $args{$_}); | |
843 | } | |
844 | elsif (/^-?telnetmode$/i) { | |
845 | $telnetmode = $args{$_}; | |
846 | unless (defined $telnetmode) { | |
847 | $telnetmode = 0; | |
848 | } | |
849 | } | |
850 | elsif (/^-?timeout$/i) { | |
851 | $timeout = &_parse_timeout($self, $args{$_}); | |
852 | } | |
853 | else { | |
854 | &_croak($self, "bad named parameter \"$_\" given " . | |
855 | "to " . ref($self) . "::getlines()"); | |
856 | } | |
857 | } | |
858 | ||
859 | ## If any args given, override corresponding instance data. | |
860 | local $s->{bin_mode} = $binmode | |
861 | if defined $binmode; | |
862 | local $s->{errormode} = $errmode | |
863 | if defined $errmode; | |
864 | local $s->{rs} = $rs | |
865 | if defined $rs; | |
866 | local $s->{telnet_mode} = $telnetmode | |
867 | if defined $telnetmode; | |
868 | local $s->{time_out} = &_endtime($timeout); | |
869 | ||
870 | ## User requested only the currently available lines. | |
871 | if (! $all) { | |
872 | return &_next_getlines($self, $s); | |
873 | } | |
874 | ||
875 | ## Read lines until eof or error. | |
876 | while (1) { | |
877 | $line = $self->getline | |
878 | or last; | |
879 | push @lines, $line; | |
880 | } | |
881 | ||
882 | ## Check for error. | |
883 | return if ! $self->eof; | |
884 | ||
885 | @lines; | |
886 | } # end sub getlines | |
887 | ||
888 | ||
889 | sub host { | |
890 | my ($self, $host) = @_; | |
891 | my ( | |
892 | $prev, | |
893 | $s, | |
894 | ); | |
895 | ||
896 | $s = *$self->{net_telnet}; | |
897 | $prev = $s->{host}; | |
898 | ||
899 | if (@_ >= 2) { | |
900 | unless (defined $host) { | |
901 | $host = ""; | |
902 | } | |
903 | ||
904 | $s->{host} = $host; | |
905 | } | |
906 | ||
907 | $prev; | |
908 | } # end sub host | |
909 | ||
910 | ||
911 | sub input_log { | |
912 | my ($self, $name) = @_; | |
913 | my ( | |
914 | $fh, | |
915 | $s, | |
916 | ); | |
917 | ||
918 | $s = *$self->{net_telnet}; | |
919 | $fh = $s->{inputlog}; | |
920 | ||
921 | if (@_ >= 2) { | |
922 | unless (defined $name) { | |
923 | $name = ""; | |
924 | } | |
925 | ||
926 | $fh = &_fname_to_handle($self, $name) | |
927 | or return; | |
928 | $s->{inputlog} = $fh; | |
929 | } | |
930 | ||
931 | $fh; | |
932 | } # end sub input_log | |
933 | ||
934 | ||
935 | sub input_record_separator { | |
936 | my ($self, $rs) = @_; | |
937 | my ( | |
938 | $prev, | |
939 | $s, | |
940 | ); | |
941 | ||
942 | $s = *$self->{net_telnet}; | |
943 | $prev = $s->{rs}; | |
944 | ||
945 | if (@_ >= 2) { | |
946 | $s->{rs} = &_parse_input_record_separator($self, $rs); | |
947 | } | |
948 | ||
949 | $prev; | |
950 | } # end sub input_record_separator | |
951 | ||
952 | ||
953 | sub last_prompt { | |
954 | my ($self, $string) = @_; | |
955 | my ( | |
956 | $prev, | |
957 | $s, | |
958 | ); | |
959 | ||
960 | $s = *$self->{net_telnet}; | |
961 | $prev = $s->{last_prompt}; | |
962 | ||
963 | if (@_ >= 2) { | |
964 | unless (defined $string) { | |
965 | $string = ""; | |
966 | } | |
967 | ||
968 | $s->{last_prompt} = $string; | |
969 | } | |
970 | ||
971 | $prev; | |
972 | } # end sub last_prompt | |
973 | ||
974 | ||
975 | sub lastline { | |
976 | my ($self, $line) = @_; | |
977 | my ( | |
978 | $prev, | |
979 | $s, | |
980 | ); | |
981 | ||
982 | $s = *$self->{net_telnet}; | |
983 | $prev = $s->{last_line}; | |
984 | ||
985 | if (@_ >= 2) { | |
986 | unless (defined $line) { | |
987 | $line = ""; | |
988 | } | |
989 | ||
990 | $s->{last_line} = $line; | |
991 | } | |
992 | ||
993 | $prev; | |
994 | } # end sub lastline | |
995 | ||
996 | ||
997 | sub login { | |
998 | my ($self) = @_; | |
999 | my ( | |
1000 | $errmode, | |
1001 | $error, | |
1002 | $is_passwd_arg, | |
1003 | $is_username_arg, | |
1004 | $lastline, | |
1005 | $match, | |
1006 | $ors, | |
1007 | $passwd, | |
1008 | $prematch, | |
1009 | $prompt, | |
1010 | $s, | |
1011 | $timeout, | |
1012 | $username, | |
1013 | %args, | |
1014 | ); | |
1015 | local $_; | |
1016 | ||
1017 | ## Init. | |
1018 | $self->timed_out(''); | |
1019 | $self->last_prompt(""); | |
1020 | $s = *$self->{net_telnet}; | |
1021 | $timeout = $self->timeout; | |
1022 | $ors = $self->output_record_separator; | |
1023 | $prompt = $self->prompt; | |
1024 | ||
1025 | ## Parse args. | |
1026 | if (@_ == 3) { # just username and passwd given | |
1027 | $username = $_[1]; | |
1028 | $passwd = $_[2]; | |
1029 | ||
1030 | $is_username_arg = 1; | |
1031 | $is_passwd_arg = 1; | |
1032 | } | |
1033 | else { # named args given | |
1034 | ## Get the named args. | |
1035 | (undef, %args) = @_; | |
1036 | ||
1037 | ## Parse the named args. | |
1038 | foreach (keys %args) { | |
1039 | if (/^-?errmode$/i) { | |
1040 | $errmode = &_parse_errmode($self, $args{$_}); | |
1041 | } | |
1042 | elsif (/^-?name$/i) { | |
1043 | $username = $args{$_}; | |
1044 | unless (defined $username) { | |
1045 | $username = ""; | |
1046 | } | |
1047 | ||
1048 | $is_username_arg = 1; | |
1049 | } | |
1050 | elsif (/^-?pass/i) { | |
1051 | $passwd = $args{$_}; | |
1052 | unless (defined $passwd) { | |
1053 | $passwd = ""; | |
1054 | } | |
1055 | ||
1056 | $is_passwd_arg = 1; | |
1057 | } | |
1058 | elsif (/^-?prompt$/i) { | |
1059 | $prompt = &_parse_prompt($self, $args{$_}); | |
1060 | } | |
1061 | elsif (/^-?timeout$/i) { | |
1062 | $timeout = &_parse_timeout($self, $args{$_}); | |
1063 | } | |
1064 | else { | |
1065 | &_croak($self, "bad named parameter \"$_\" given ", | |
1066 | "to " . ref($self) . "::login()"); | |
1067 | } | |
1068 | } | |
1069 | } | |
1070 | ||
1071 | ## Ensure both username and password argument given. | |
1072 | &_croak($self,"Name argument not given to " . ref($self) . "::login()") | |
1073 | unless $is_username_arg; | |
1074 | &_croak($self,"Password argument not given to " . ref($self) . "::login()") | |
1075 | unless $is_passwd_arg; | |
1076 | ||
1077 | ## Override some user settings. | |
1078 | local $s->{errormode} = $errmode | |
1079 | if defined $errmode; | |
1080 | local $s->{time_out} = &_endtime($timeout); | |
1081 | ||
1082 | ## Create a subroutine to generate an error. | |
1083 | $error | |
1084 | = sub { | |
1085 | my ($errmsg) = @_; | |
1086 | ||
1087 | if ($self->timed_out) { | |
1088 | return $self->error($errmsg); | |
1089 | } | |
1090 | elsif ($self->eof) { | |
1091 | ($lastline = $self->lastline) =~ s/\n+//; | |
1092 | return $self->error($errmsg, ": ", $lastline); | |
1093 | } | |
1094 | else { | |
1095 | return $self->error($self->errmsg); | |
1096 | } | |
1097 | }; | |
1098 | ||
1099 | ||
1100 | return $self->error("login failed: filehandle isn't open") | |
1101 | if $self->eof; | |
1102 | ||
1103 | ## Wait for login prompt. | |
1104 | $self->waitfor(Match => '/login[: ]*$/i', | |
1105 | Match => '/username[: ]*$/i', | |
1106 | Errmode => "return") | |
1107 | or do { | |
1108 | return &$error("eof read waiting for login prompt") | |
1109 | if $self->eof; | |
1110 | return &$error("timed-out waiting for login prompt"); | |
1111 | }; | |
1112 | ||
1113 | ## Delay sending response because of bug in Linux login program. | |
1114 | &_sleep(0.01); | |
1115 | ||
1116 | ## Send login name. | |
1117 | $self->put(String => $username . $ors, | |
1118 | Errmode => "return") | |
1119 | or return &$error("login disconnected"); | |
1120 | ||
1121 | ## Wait for password prompt. | |
1122 | $self->waitfor(Match => '/password[: ]*$/i', | |
1123 | Errmode => "return") | |
1124 | or do { | |
1125 | return &$error("eof read waiting for password prompt") | |
1126 | if $self->eof; | |
1127 | return &$error("timed-out waiting for password prompt"); | |
1128 | }; | |
1129 | ||
1130 | ## Delay sending response because of bug in Linux login program. | |
1131 | &_sleep(0.01); | |
1132 | ||
1133 | ## Send password. | |
1134 | $self->put(String => $passwd . $ors, | |
1135 | Errmode => "return") | |
1136 | or return &$error("login disconnected"); | |
1137 | ||
1138 | ## Wait for command prompt or another login prompt. | |
1139 | ($prematch, $match) = $self->waitfor(Match => '/login[: ]*$/i', | |
1140 | Match => '/username[: ]*$/i', | |
1141 | Match => $prompt, | |
1142 | Errmode => "return") | |
1143 | or do { | |
1144 | return &$error("eof read waiting for command prompt") | |
1145 | if $self->eof; | |
1146 | return &$error("timed-out waiting for command prompt"); | |
1147 | }; | |
1148 | ||
1149 | ## It's a bad login if we got another login prompt. | |
1150 | return $self->error("login failed: bad name or password") | |
1151 | if $match =~ /login[: ]*$/i or $match =~ /username[: ]*$/i; | |
1152 | ||
1153 | ## Save the most recently matched command prompt. | |
1154 | $self->last_prompt($match); | |
1155 | ||
1156 | 1; | |
1157 | } # end sub login | |
1158 | ||
1159 | ||
1160 | sub max_buffer_length { | |
1161 | my ($self, $maxbufsize) = @_; | |
1162 | my ( | |
1163 | $prev, | |
1164 | $s, | |
1165 | ); | |
1166 | my $minbufsize = 512; | |
1167 | ||
1168 | $s = *$self->{net_telnet}; | |
1169 | $prev = $s->{maxbufsize}; | |
1170 | ||
1171 | if (@_ >= 2) { | |
1172 | ## Ensure a positive integer value. | |
1173 | unless (defined $maxbufsize | |
1174 | and $maxbufsize =~ /^\d+$/ | |
1175 | and $maxbufsize) | |
1176 | { | |
1177 | &_carp($self, "ignoring bad Max_buffer_length " . | |
1178 | "argument \"$maxbufsize\": it's not a positive integer"); | |
1179 | $maxbufsize = $prev; | |
1180 | } | |
1181 | ||
1182 | ## Adjust up values that are too small. | |
1183 | if ($maxbufsize < $minbufsize) { | |
1184 | $maxbufsize = $minbufsize; | |
1185 | } | |
1186 | ||
1187 | $s->{maxbufsize} = $maxbufsize; | |
1188 | } | |
1189 | ||
1190 | $prev; | |
1191 | } # end sub max_buffer_length | |
1192 | ||
1193 | ||
1194 | ## Make ofs() synonymous with output_field_separator(). | |
1195 | *ofs = \&output_field_separator; | |
1196 | ||
1197 | ||
1198 | sub open { | |
1199 | my ($self) = @_; | |
1200 | my ( | |
1201 | $errmode, | |
1202 | $errno, | |
1203 | $host, | |
1204 | $ip_addr, | |
1205 | $port, | |
1206 | $s, | |
1207 | $timeout, | |
1208 | %args, | |
1209 | ); | |
1210 | local $_; | |
1211 | ||
1212 | ## Init. | |
1213 | $s = *$self->{net_telnet}; | |
1214 | $timeout = $s->{time_out}; | |
1215 | $s->{timedout} = ''; | |
1216 | ||
1217 | if (@_ == 2) { # one positional arg given | |
1218 | $self->host($_[1]); | |
1219 | } | |
1220 | elsif (@_ > 2) { # named args given | |
1221 | ## Get the named args. | |
1222 | (undef, %args) = @_; | |
1223 | ||
1224 | ## Parse the named args. | |
1225 | foreach (keys %args) { | |
1226 | if (/^-?errmode$/i) { | |
1227 | $errmode = &_parse_errmode($self, $args{$_}); | |
1228 | } | |
1229 | elsif (/^-?host$/i) { | |
1230 | $self->host($args{$_}); | |
1231 | } | |
1232 | elsif (/^-?port$/i) { | |
1233 | $self->port($args{$_}) | |
1234 | or return; | |
1235 | } | |
1236 | elsif (/^-?timeout$/i) { | |
1237 | $timeout = &_parse_timeout($self, $args{$_}); | |
1238 | } | |
1239 | else { | |
1240 | &_croak($self, "bad named parameter \"$_\" given ", | |
1241 | "to " . ref($self) . "::open()"); | |
1242 | } | |
1243 | } | |
1244 | } | |
1245 | ||
1246 | ## If any args given, override corresponding instance data. | |
1247 | local $s->{errormode} = $errmode | |
1248 | if defined $errmode; | |
1249 | ||
1250 | ## Get host and port. | |
1251 | $host = $self->host; | |
1252 | $port = $self->port; | |
1253 | ||
1254 | ## Ensure we're already closed. | |
1255 | $self->close; | |
1256 | ||
1257 | ## Connect with or without a timeout. | |
1258 | if (defined($timeout) and &_have_alarm) { # use a timeout | |
1259 | ## Convert possible absolute timeout to relative timeout. | |
1260 | if ($timeout >= $^T) { # it's an absolute time | |
1261 | $timeout = $timeout - time; | |
1262 | } | |
1263 | ||
1264 | ## Ensure a valid timeout value for alarm. | |
1265 | if ($timeout < 1) { | |
1266 | $timeout = 1; | |
1267 | } | |
1268 | $timeout = int($timeout + 1.5); | |
1269 | ||
1270 | ## Connect to server, timing out if it takes too long. | |
1271 | eval { | |
1272 | ## Turn on timer. | |
1273 | local $SIG{"__DIE__"} = "DEFAULT"; | |
1274 | local $SIG{ALRM} = sub { die "timed-out\n" }; | |
1275 | alarm $timeout; | |
1276 | ||
1277 | ## Lookup server's IP address. | |
1278 | $ip_addr = inet_aton $host | |
1279 | or die "unknown remote host: $host\n"; | |
1280 | ||
1281 | ## Create a socket and attach the filehandle to it. | |
1282 | socket $self, AF_INET, SOCK_STREAM, 0 | |
1283 | or die "problem creating socket: $!\n"; | |
1284 | ||
1285 | ## Open connection to server. | |
1286 | connect $self, sockaddr_in($port, $ip_addr) | |
1287 | or die "problem connecting to \"$host\", port $port: $!\n"; | |
1288 | }; | |
1289 | alarm 0; | |
1290 | ||
1291 | ## Check for error. | |
1292 | if ($@ =~ /^timed-out$/) { # time out failure | |
1293 | $s->{timedout} = 1; | |
1294 | $self->close; | |
1295 | if (!$ip_addr) { | |
1296 | return $self->error("unknown remote host: $host: ", | |
1297 | "name lookup timed-out"); | |
1298 | } | |
1299 | else { | |
1300 | return $self->error("problem connecting to \"$host\", ", | |
1301 | "port $port: connect timed-out"); | |
1302 | } | |
1303 | } | |
1304 | elsif ($@) { # hostname lookup or connect failure | |
1305 | $self->close; | |
1306 | chomp $@; | |
1307 | return $self->error($@); | |
1308 | } | |
1309 | } | |
1310 | else { # don't use a timeout | |
1311 | $timeout = undef; | |
1312 | ||
1313 | ## Lookup server's IP address. | |
1314 | $ip_addr = inet_aton $host | |
1315 | or return $self->error("unknown remote host: $host"); | |
1316 | ||
1317 | ## Create a socket and attach the filehandle to it. | |
1318 | socket $self, AF_INET, SOCK_STREAM, 0 | |
1319 | or return $self->error("problem creating socket: $!"); | |
1320 | ||
1321 | ## Open connection to server. | |
1322 | connect $self, sockaddr_in($port, $ip_addr) | |
1323 | or do { | |
1324 | $errno = "$!"; | |
1325 | $self->close; | |
1326 | return $self->error("problem connecting to \"$host\", ", | |
1327 | "port $port: $errno"); | |
1328 | }; | |
1329 | } | |
1330 | ||
1331 | select((select($self), $|=1)[$[]); # don't buffer writes | |
1332 | $s->{blksize} = &_optimal_blksize((stat $self)[11]); | |
1333 | $s->{buf} = ""; | |
1334 | $s->{eofile} = ''; | |
1335 | $s->{errormsg} = ""; | |
1336 | vec($s->{fdmask}='', fileno($self), 1) = 1; | |
1337 | $s->{last_line} = ""; | |
1338 | $s->{num_wrote} = 0; | |
1339 | $s->{opened} = 1; | |
1340 | $s->{pending_errormsg} = ""; | |
1341 | $s->{pushback_buf} = ""; | |
1342 | $s->{timedout} = ''; | |
1343 | $s->{unsent_opts} = ""; | |
1344 | &_reset_options($s->{opts}); | |
1345 | ||
1346 | 1; | |
1347 | } # end sub open | |
1348 | ||
1349 | ||
1350 | sub option_accept { | |
1351 | my ($self, @args) = @_; | |
1352 | my ( | |
1353 | $arg, | |
1354 | $option, | |
1355 | $s, | |
1356 | @opt_args, | |
1357 | ); | |
1358 | local $_; | |
1359 | ||
1360 | ## Init. | |
1361 | $s = *$self->{net_telnet}; | |
1362 | ||
1363 | ## Parse the named args. | |
1364 | while (($_, $arg) = splice @args, 0, 2) { | |
1365 | ## Verify and save arguments. | |
1366 | if (/^-?do$/i) { | |
1367 | ## Make sure a callback is defined. | |
1368 | return $self->error("usage: an option callback must already ", | |
1369 | "be defined when enabling with $_") | |
1370 | unless $s->{opt_cback}; | |
1371 | ||
1372 | $option = &_verify_telopt_arg($self, $arg, $_); | |
1373 | return unless defined $option; | |
1374 | push @opt_args, { option => $option, | |
1375 | is_remote => '', | |
1376 | is_enable => 1, | |
1377 | }; | |
1378 | } | |
1379 | elsif (/^-?dont$/i) { | |
1380 | $option = &_verify_telopt_arg($self, $arg, $_); | |
1381 | return unless defined $option; | |
1382 | push @opt_args, { option => $option, | |
1383 | is_remote => '', | |
1384 | is_enable => '', | |
1385 | }; | |
1386 | } | |
1387 | elsif (/^-?will$/i) { | |
1388 | ## Make sure a callback is defined. | |
1389 | return $self->error("usage: an option callback must already ", | |
1390 | "be defined when enabling with $_") | |
1391 | unless $s->{opt_cback}; | |
1392 | ||
1393 | $option = &_verify_telopt_arg($self, $arg, $_); | |
1394 | return unless defined $option; | |
1395 | push @opt_args, { option => $option, | |
1396 | is_remote => 1, | |
1397 | is_enable => 1, | |
1398 | }; | |
1399 | } | |
1400 | elsif (/^-?wont$/i) { | |
1401 | $option = &_verify_telopt_arg($self, $arg, $_); | |
1402 | return unless defined $option; | |
1403 | push @opt_args, { option => $option, | |
1404 | is_remote => 1, | |
1405 | is_enable => '', | |
1406 | }; | |
1407 | } | |
1408 | else { | |
1409 | return $self->error('usage: $obj->option_accept(' . | |
1410 | '[Do => $telopt,] ', | |
1411 | '[Dont => $telopt,] ', | |
1412 | '[Will => $telopt,] ', | |
1413 | '[Wont => $telopt,]'); | |
1414 | } | |
1415 | } | |
1416 | ||
1417 | ## Set "receive ok" for options specified. | |
1418 | &_opt_accept($self, @opt_args); | |
1419 | } # end sub option_accept | |
1420 | ||
1421 | ||
1422 | sub option_callback { | |
1423 | my ($self, $callback) = @_; | |
1424 | my ( | |
1425 | $prev, | |
1426 | $s, | |
1427 | ); | |
1428 | ||
1429 | $s = *$self->{net_telnet}; | |
1430 | $prev = $s->{opt_cback}; | |
1431 | ||
1432 | if (@_ >= 2) { | |
1433 | unless (defined $callback and ref($callback) eq "CODE") { | |
1434 | &_carp($self, "ignoring Option_callback argument because it's " . | |
1435 | "not a code ref"); | |
1436 | $callback = $prev; | |
1437 | } | |
1438 | ||
1439 | $s->{opt_cback} = $callback; | |
1440 | } | |
1441 | ||
1442 | $prev; | |
1443 | } # end sub option_callback | |
1444 | ||
1445 | ||
1446 | sub option_log { | |
1447 | my ($self, $name) = @_; | |
1448 | my ( | |
1449 | $fh, | |
1450 | $s, | |
1451 | ); | |
1452 | ||
1453 | $s = *$self->{net_telnet}; | |
1454 | $fh = $s->{opt_log}; | |
1455 | ||
1456 | if (@_ >= 2) { | |
1457 | unless (defined $name) { | |
1458 | $name = ""; | |
1459 | } | |
1460 | ||
1461 | $fh = &_fname_to_handle($self, $name) | |
1462 | or return; | |
1463 | $s->{opt_log} = $fh; | |
1464 | } | |
1465 | ||
1466 | $fh; | |
1467 | } # end sub option_log | |
1468 | ||
1469 | ||
1470 | sub option_state { | |
1471 | my ($self, $option) = @_; | |
1472 | my ( | |
1473 | $opt_state, | |
1474 | $s, | |
1475 | %opt_state, | |
1476 | ); | |
1477 | ||
1478 | ## Ensure telnet option is non-negative integer. | |
1479 | $option = &_verify_telopt_arg($self, $option); | |
1480 | return unless defined $option; | |
1481 | ||
1482 | ## Init. | |
1483 | $s = *$self->{net_telnet}; | |
1484 | unless (defined $s->{opts}{$option}) { | |
1485 | &_set_default_option($s, $option); | |
1486 | } | |
1487 | ||
1488 | ## Return hashref to a copy of the values. | |
1489 | $opt_state = $s->{opts}{$option}; | |
1490 | %opt_state = %$opt_state; | |
1491 | \%opt_state; | |
1492 | } # end sub option_state | |
1493 | ||
1494 | ||
1495 | ## Make ors() synonymous with output_record_separator(). | |
1496 | *ors = \&output_record_separator; | |
1497 | ||
1498 | ||
1499 | sub output_field_separator { | |
1500 | my ($self, $ofs) = @_; | |
1501 | my ( | |
1502 | $prev, | |
1503 | $s, | |
1504 | ); | |
1505 | ||
1506 | $s = *$self->{net_telnet}; | |
1507 | $prev = $s->{ofs}; | |
1508 | ||
1509 | if (@_ >= 2) { | |
1510 | unless (defined $ofs) { | |
1511 | $ofs = ""; | |
1512 | } | |
1513 | ||
1514 | $s->{ofs} = $ofs; | |
1515 | } | |
1516 | ||
1517 | $prev; | |
1518 | } # end sub output_field_separator | |
1519 | ||
1520 | ||
1521 | sub output_log { | |
1522 | my ($self, $name) = @_; | |
1523 | my ( | |
1524 | $fh, | |
1525 | $s, | |
1526 | ); | |
1527 | ||
1528 | $s = *$self->{net_telnet}; | |
1529 | $fh = $s->{outputlog}; | |
1530 | ||
1531 | if (@_ >= 2) { | |
1532 | unless (defined $name) { | |
1533 | $name = ""; | |
1534 | } | |
1535 | ||
1536 | $fh = &_fname_to_handle($self, $name) | |
1537 | or return; | |
1538 | $s->{outputlog} = $fh; | |
1539 | } | |
1540 | ||
1541 | $fh; | |
1542 | } # end sub output_log | |
1543 | ||
1544 | ||
1545 | sub output_record_separator { | |
1546 | my ($self, $ors) = @_; | |
1547 | my ( | |
1548 | $prev, | |
1549 | $s, | |
1550 | ); | |
1551 | ||
1552 | $s = *$self->{net_telnet}; | |
1553 | $prev = $s->{ors}; | |
1554 | ||
1555 | if (@_ >= 2) { | |
1556 | unless (defined $ors) { | |
1557 | $ors = ""; | |
1558 | } | |
1559 | ||
1560 | $s->{ors} = $ors; | |
1561 | } | |
1562 | ||
1563 | $prev; | |
1564 | } # end sub output_record_separator | |
1565 | ||
1566 | ||
1567 | sub port { | |
1568 | my ($self, $port) = @_; | |
1569 | my ( | |
1570 | $prev, | |
1571 | $s, | |
1572 | $service, | |
1573 | ); | |
1574 | ||
1575 | $s = *$self->{net_telnet}; | |
1576 | $prev = $s->{port}; | |
1577 | ||
1578 | if (@_ >= 2) { | |
1579 | unless (defined $port) { | |
1580 | $port = ""; | |
1581 | } | |
1582 | ||
1583 | if (!$port) { | |
1584 | &_carp($self, "ignoring bad Port argument \"$port\""); | |
1585 | $port = $prev; | |
1586 | } | |
1587 | elsif ($port !~ /^\d+$/) { # port isn't all digits | |
1588 | $service = $port; | |
1589 | $port = getservbyname($service, "tcp"); | |
1590 | unless ($port) { | |
1591 | &_carp($self, "ignoring bad Port argument \"$service\": " . | |
1592 | "it's an unknown TCP service"); | |
1593 | $port = $prev; | |
1594 | } | |
1595 | } | |
1596 | ||
1597 | $s->{port} = $port; | |
1598 | } | |
1599 | ||
1600 | $prev; | |
1601 | } # end sub port | |
1602 | ||
1603 | ||
1604 | sub print { | |
1605 | my ($self) = shift; | |
1606 | my ( | |
1607 | $buf, | |
1608 | $fh, | |
1609 | $s, | |
1610 | ); | |
1611 | ||
1612 | $s = *$self->{net_telnet}; | |
1613 | $s->{timedout} = ''; | |
1614 | return $self->error("write error: filehandle isn't open") | |
1615 | unless $s->{opened}; | |
1616 | ||
1617 | ## Add field and record separators. | |
1618 | $buf = join($s->{ofs}, @_) . $s->{ors}; | |
1619 | ||
1620 | ## Log the output if requested. | |
1621 | if ($s->{outputlog}) { | |
1622 | &_log_print($s->{outputlog}, $buf); | |
1623 | } | |
1624 | ||
1625 | ## Convert native newlines to CR LF. | |
1626 | if (!$s->{bin_mode}) { | |
1627 | $buf =~ s(\n)(\015\012)g; | |
1628 | } | |
1629 | ||
1630 | ## Escape TELNET IAC and also CR not followed by LF. | |
1631 | if ($s->{telnet_mode}) { | |
1632 | $buf =~ s(\377)(\377\377)g; | |
1633 | &_escape_cr(\$buf); | |
1634 | } | |
1635 | ||
1636 | &_put($self, \$buf, "print"); | |
1637 | } # end sub print | |
1638 | ||
1639 | ||
1640 | sub print_length { | |
1641 | my ($self) = @_; | |
1642 | ||
1643 | *$self->{net_telnet}{num_wrote}; | |
1644 | } # end sub print_length | |
1645 | ||
1646 | ||
1647 | sub prompt { | |
1648 | my ($self, $prompt) = @_; | |
1649 | my ( | |
1650 | $prev, | |
1651 | $s, | |
1652 | ); | |
1653 | ||
1654 | $s = *$self->{net_telnet}; | |
1655 | $prev = $s->{cmd_prompt}; | |
1656 | ||
1657 | ## Parse args. | |
1658 | if (@_ == 2) { | |
1659 | $s->{cmd_prompt} = &_parse_prompt($self, $prompt); | |
1660 | } | |
1661 | ||
1662 | $prev; | |
1663 | } # end sub prompt | |
1664 | ||
1665 | ||
1666 | sub put { | |
1667 | my ($self) = @_; | |
1668 | my ( | |
1669 | $binmode, | |
1670 | $buf, | |
1671 | $errmode, | |
1672 | $is_timeout_arg, | |
1673 | $s, | |
1674 | $telnetmode, | |
1675 | $timeout, | |
1676 | %args, | |
1677 | ); | |
1678 | local $_; | |
1679 | ||
1680 | ## Init. | |
1681 | $s = *$self->{net_telnet}; | |
1682 | $s->{timedout} = ''; | |
1683 | ||
1684 | ## Parse args. | |
1685 | if (@_ == 2) { # one positional arg given | |
1686 | $buf = $_[1]; | |
1687 | } | |
1688 | elsif (@_ > 2) { # named args given | |
1689 | ## Get the named args. | |
1690 | (undef, %args) = @_; | |
1691 | ||
1692 | ## Parse the named args. | |
1693 | foreach (keys %args) { | |
1694 | if (/^-?binmode$/i) { | |
1695 | $binmode = $args{$_}; | |
1696 | unless (defined $binmode) { | |
1697 | $binmode = 0; | |
1698 | } | |
1699 | } | |
1700 | elsif (/^-?errmode$/i) { | |
1701 | $errmode = &_parse_errmode($self, $args{$_}); | |
1702 | } | |
1703 | elsif (/^-?string$/i) { | |
1704 | $buf = $args{$_}; | |
1705 | } | |
1706 | elsif (/^-?telnetmode$/i) { | |
1707 | $telnetmode = $args{$_}; | |
1708 | unless (defined $telnetmode) { | |
1709 | $telnetmode = 0; | |
1710 | } | |
1711 | } | |
1712 | elsif (/^-?timeout$/i) { | |
1713 | $timeout = &_parse_timeout($self, $args{$_}); | |
1714 | $is_timeout_arg = 1; | |
1715 | } | |
1716 | else { | |
1717 | &_croak($self, "bad named parameter \"$_\" given ", | |
1718 | "to " . ref($self) . "::put()"); | |
1719 | } | |
1720 | } | |
1721 | } | |
1722 | ||
1723 | ## If any args given, override corresponding instance data. | |
1724 | local $s->{bin_mode} = $binmode | |
1725 | if defined $binmode; | |
1726 | local $s->{errormode} = $errmode | |
1727 | if defined $errmode; | |
1728 | local $s->{telnet_mode} = $telnetmode | |
1729 | if defined $telnetmode; | |
1730 | local $s->{time_out} = $timeout | |
1731 | if defined $is_timeout_arg; | |
1732 | ||
1733 | ## Check for errors. | |
1734 | return $self->error("write error: filehandle isn't open") | |
1735 | unless $s->{opened}; | |
1736 | ||
1737 | ## Log the output if requested. | |
1738 | if ($s->{outputlog}) { | |
1739 | &_log_print($s->{outputlog}, $buf); | |
1740 | } | |
1741 | ||
1742 | ## Convert native newlines to CR LF. | |
1743 | if (!$s->{bin_mode}) { | |
1744 | $buf =~ s(\n)(\015\012)g; | |
1745 | } | |
1746 | ||
1747 | ## Escape TELNET IAC and also CR not followed by LF. | |
1748 | if ($s->{telnet_mode}) { | |
1749 | $buf =~ s(\377)(\377\377)g; | |
1750 | &_escape_cr(\$buf); | |
1751 | } | |
1752 | ||
1753 | &_put($self, \$buf, "print"); | |
1754 | } # end sub put | |
1755 | ||
1756 | ||
1757 | ## Make rs() synonymous input_record_separator(). | |
1758 | *rs = \&input_record_separator; | |
1759 | ||
1760 | ||
1761 | sub suboption_callback { | |
1762 | my ($self, $callback) = @_; | |
1763 | my ( | |
1764 | $prev, | |
1765 | $s, | |
1766 | ); | |
1767 | ||
1768 | $s = *$self->{net_telnet}; | |
1769 | $prev = $s->{subopt_cback}; | |
1770 | ||
1771 | if (@_ >= 2) { | |
1772 | unless (defined $callback and ref($callback) eq "CODE") { | |
1773 | &_carp($self,"ignoring Suboption_callback argument because it's " . | |
1774 | "not a code ref"); | |
1775 | $callback = $prev; | |
1776 | } | |
1777 | ||
1778 | $s->{subopt_cback} = $callback; | |
1779 | } | |
1780 | ||
1781 | $prev; | |
1782 | } # end sub suboption_callback | |
1783 | ||
1784 | ||
1785 | sub telnetmode { | |
1786 | my ($self, $mode) = @_; | |
1787 | my ( | |
1788 | $prev, | |
1789 | $s, | |
1790 | ); | |
1791 | ||
1792 | $s = *$self->{net_telnet}; | |
1793 | $prev = $s->{telnet_mode}; | |
1794 | ||
1795 | if (@_ >= 2) { | |
1796 | unless (defined $mode) { | |
1797 | $mode = 0; | |
1798 | } | |
1799 | ||
1800 | $s->{telnet_mode} = $mode; | |
1801 | } | |
1802 | ||
1803 | $prev; | |
1804 | } # end sub telnetmode | |
1805 | ||
1806 | ||
1807 | sub timed_out { | |
1808 | my ($self, $value) = @_; | |
1809 | my ( | |
1810 | $prev, | |
1811 | $s, | |
1812 | ); | |
1813 | ||
1814 | $s = *$self->{net_telnet}; | |
1815 | $prev = $s->{timedout}; | |
1816 | ||
1817 | if (@_ >= 2) { | |
1818 | unless (defined $value) { | |
1819 | $value = ""; | |
1820 | } | |
1821 | ||
1822 | $s->{timedout} = $value; | |
1823 | } | |
1824 | ||
1825 | $prev; | |
1826 | } # end sub timed_out | |
1827 | ||
1828 | ||
1829 | sub timeout { | |
1830 | my ($self, $timeout) = @_; | |
1831 | my ( | |
1832 | $prev, | |
1833 | $s, | |
1834 | ); | |
1835 | ||
1836 | $s = *$self->{net_telnet}; | |
1837 | $prev = $s->{time_out}; | |
1838 | ||
1839 | if (@_ >= 2) { | |
1840 | $s->{time_out} = &_parse_timeout($self, $timeout); | |
1841 | } | |
1842 | ||
1843 | $prev; | |
1844 | } # end sub timeout | |
1845 | ||
1846 | ||
1847 | sub waitfor { | |
1848 | my ($self, @args) = @_; | |
1849 | my ( | |
1850 | $arg, | |
1851 | $binmode, | |
1852 | $endtime, | |
1853 | $errmode, | |
1854 | $len, | |
1855 | $match, | |
1856 | $match_op, | |
1857 | $pos, | |
1858 | $prematch, | |
1859 | $s, | |
1860 | $search, | |
1861 | $search_cond, | |
1862 | $telnetmode, | |
1863 | $timeout, | |
1864 | @match_cond, | |
1865 | @match_ops, | |
1866 | @search_cond, | |
1867 | @string_cond, | |
1868 | @warns, | |
1869 | ); | |
1870 | local $_; | |
1871 | ||
1872 | ## Init. | |
1873 | $s = *$self->{net_telnet}; | |
1874 | $s->{timedout} = ''; | |
1875 | return if $s->{eofile}; | |
1876 | return unless @args; | |
1877 | $timeout = $s->{time_out}; | |
1878 | ||
1879 | ## Code template used to build string match conditional. | |
1880 | ## Values between array elements must be supplied later. | |
1881 | @string_cond = | |
1882 | ('if (($pos = index $s->{buf}, ', ') > -1) { | |
1883 | $len = ', '; | |
1884 | $prematch = substr $s->{buf}, 0, $pos; | |
1885 | $match = substr $s->{buf}, $pos, $len; | |
1886 | substr($s->{buf}, 0, $pos + $len) = ""; | |
1887 | last; | |
1888 | }'); | |
1889 | ||
1890 | ## Code template used to build pattern match conditional. | |
1891 | ## Values between array elements must be supplied later. | |
1892 | @match_cond = | |
1893 | ('if ($s->{buf} =~ ', ') { | |
1894 | $prematch = $`; | |
1895 | $match = $&; | |
1896 | substr($s->{buf}, 0, length($`) + length($&)) = ""; | |
1897 | last; | |
1898 | }'); | |
1899 | ||
1900 | ## Parse args. | |
1901 | if (@_ == 2) { # one positional arg given | |
1902 | $arg = $_[1]; | |
1903 | ||
1904 | ## Fill in the blanks in the code template. | |
1905 | push @match_ops, $arg; | |
1906 | push @search_cond, join("", $match_cond[0], $arg, $match_cond[1]); | |
1907 | } | |
1908 | elsif (@_ > 2) { # named args given | |
1909 | ## Parse the named args. | |
1910 | while (($_, $arg) = splice @args, 0, 2) { | |
1911 | if (/^-?binmode$/i) { | |
1912 | $binmode = $arg; | |
1913 | unless (defined $binmode) { | |
1914 | $binmode = 0; | |
1915 | } | |
1916 | } | |
1917 | elsif (/^-?errmode$/i) { | |
1918 | $errmode = &_parse_errmode($self, $arg); | |
1919 | } | |
1920 | elsif (/^-?match$/i) { | |
1921 | ## Fill in the blanks in the code template. | |
1922 | push @match_ops, $arg; | |
1923 | push @search_cond, join("", | |
1924 | $match_cond[0], $arg, $match_cond[1]); | |
1925 | } | |
1926 | elsif (/^-?string$/i) { | |
1927 | ## Fill in the blanks in the code template. | |
1928 | $arg =~ s/'/\\'/g; # quote ticks | |
1929 | push @search_cond, join("", | |
1930 | $string_cond[0], "'$arg'", | |
1931 | $string_cond[1], length($arg), | |
1932 | $string_cond[2]); | |
1933 | } | |
1934 | elsif (/^-?telnetmode$/i) { | |
1935 | $telnetmode = $arg; | |
1936 | unless (defined $telnetmode) { | |
1937 | $telnetmode = 0; | |
1938 | } | |
1939 | } | |
1940 | elsif (/^-?timeout$/i) { | |
1941 | $timeout = &_parse_timeout($self, $arg); | |
1942 | } | |
1943 | else { | |
1944 | &_croak($self, "bad named parameter \"$_\" given " . | |
1945 | "to " . ref($self) . "::waitfor()"); | |
1946 | } | |
1947 | } | |
1948 | } | |
1949 | ||
1950 | ## If any args given, override corresponding instance data. | |
1951 | local $s->{errormode} = $errmode | |
1952 | if defined $errmode; | |
1953 | local $s->{bin_mode} = $binmode | |
1954 | if defined $binmode; | |
1955 | local $s->{telnet_mode} = $telnetmode | |
1956 | if defined $telnetmode; | |
1957 | ||
1958 | ## Check for bad match operator argument. | |
1959 | foreach $match_op (@match_ops) { | |
1960 | return $self->error("missing opening delimiter of match operator ", | |
1961 | "in argument \"$match_op\" given to ", | |
1962 | ref($self) . "::waitfor()") | |
1963 | unless $match_op =~ m(^\s*/) or $match_op =~ m(^\s*m\s*\W); | |
1964 | } | |
1965 | ||
1966 | ## Construct conditional to check for requested string and pattern matches. | |
1967 | ## Turn subsequent "if"s into "elsif". | |
1968 | $search_cond = join "\n\tels", @search_cond; | |
1969 | ||
1970 | ## Construct loop to fill buffer until string/pattern, timeout, or eof. | |
1971 | $search = join "", " | |
1972 | while (1) {\n\t", | |
1973 | $search_cond, ' | |
1974 | &_fillbuf($self, $s, $endtime) | |
1975 | or do { | |
1976 | last if $s->{timedout}; | |
1977 | $self->close; | |
1978 | last; | |
1979 | }; | |
1980 | }'; | |
1981 | ||
1982 | ## Set wall time when we timeout. | |
1983 | $endtime = &_endtime($timeout); | |
1984 | ||
1985 | ## Run the loop. | |
1986 | { | |
1987 | local $^W = 1; | |
1988 | local $SIG{"__WARN__"} = sub { push @warns, @_ }; | |
1989 | local $s->{errormode} = "return"; | |
1990 | $s->{errormsg} = ""; | |
1991 | eval $search; | |
1992 | } | |
1993 | ||
1994 | ## Check for failure. | |
1995 | return $self->error("pattern match timed-out") if $s->{timedout}; | |
1996 | return $self->error($s->{errormsg}) if $s->{errormsg} ne ""; | |
1997 | return $self->error("pattern match read eof") if $s->{eofile}; | |
1998 | ||
1999 | ## Check for Perl syntax errors or warnings. | |
2000 | if ($@ or @warns) { | |
2001 | foreach $match_op (@match_ops) { | |
2002 | &_match_check($self, $match_op) | |
2003 | or return; | |
2004 | } | |
2005 | return $self->error($@) if $@; | |
2006 | return $self->error(@warns) if @warns; | |
2007 | } | |
2008 | ||
2009 | wantarray ? ($prematch, $match) : 1; | |
2010 | } # end sub waitfor | |
2011 | ||
2012 | ||
2013 | ######################## Private Subroutines ######################### | |
2014 | ||
2015 | ||
2016 | sub _append_lineno { | |
2017 | my ($obj, @msgs) = @_; | |
2018 | my ( | |
2019 | $file, | |
2020 | $line, | |
2021 | $pkg, | |
2022 | ); | |
2023 | ||
2024 | ## Find the caller that's not in object's class or one of its base classes. | |
2025 | ($pkg, $file , $line) = &_user_caller($obj); | |
2026 | join("", @msgs, " at ", $file, " line ", $line, "\n"); | |
2027 | } # end sub _append_lineno | |
2028 | ||
2029 | ||
2030 | sub _carp { | |
2031 | warn &_append_lineno(@_); | |
2032 | } # end sub _carp | |
2033 | ||
2034 | ||
2035 | sub _croak { | |
2036 | die &_append_lineno(@_); | |
2037 | } # end sub _croak | |
2038 | ||
2039 | ||
2040 | sub _endtime { | |
2041 | my ($interval) = @_; | |
2042 | ||
2043 | ## Compute wall time when timeout occurs. | |
2044 | if (defined $interval) { | |
2045 | if ($interval >= $^T) { # it's already an absolute time | |
2046 | return $interval; | |
2047 | } | |
2048 | elsif ($interval > 0) { # it's relative to the current time | |
2049 | return int(time + 1.5 + $interval); | |
2050 | } | |
2051 | else { # it's a one time poll | |
2052 | return 0; | |
2053 | } | |
2054 | } | |
2055 | else { # there's no timeout | |
2056 | return undef; | |
2057 | } | |
2058 | } # end sub _endtime | |
2059 | ||
2060 | ||
2061 | sub _escape_cr { | |
2062 | my ($string) = @_; | |
2063 | my ( | |
2064 | $nextchar, | |
2065 | ); | |
2066 | my $pos = 0; | |
2067 | ||
2068 | ## Convert all CR (not followed by LF) to CR NULL. | |
2069 | while (($pos = index($$string, "\015", $pos)) > -1) { | |
2070 | $nextchar = substr $$string, $pos + 1, 1; | |
2071 | ||
2072 | substr($$string, $pos, 1) = "\015\000" | |
2073 | unless $nextchar eq "\012"; | |
2074 | ||
2075 | $pos++; | |
2076 | } | |
2077 | ||
2078 | 1; | |
2079 | } # end sub _escape_cr | |
2080 | ||
2081 | ||
2082 | sub _fillbuf { | |
2083 | my ($self, $s, $endtime) = @_; | |
2084 | my ( | |
2085 | $msg, | |
2086 | $nfound, | |
2087 | $nread, | |
2088 | $pushback_len, | |
2089 | $read_pos, | |
2090 | $ready, | |
2091 | $timed_out, | |
2092 | $timeout, | |
2093 | $unparsed_pos, | |
2094 | ); | |
2095 | ||
2096 | ## If error from last read not yet reported then do it now. | |
2097 | if ($s->{pending_errormsg}) { | |
2098 | $msg = $s->{pending_errormsg}; | |
2099 | $s->{pending_errormsg} = ""; | |
2100 | return $self->error($msg); | |
2101 | } | |
2102 | ||
2103 | return unless $s->{opened}; | |
2104 | ||
2105 | while (1) { | |
2106 | ## Maximum buffer size exceeded? | |
2107 | return $self->error("maximum input buffer length exceeded: ", | |
2108 | $s->{maxbufsize}, " bytes") | |
2109 | unless length($s->{buf}) <= $s->{maxbufsize}; | |
2110 | ||
2111 | ## Determine how long to wait for input ready. | |
2112 | ($timed_out, $timeout) = &_timeout_interval($endtime); | |
2113 | if ($timed_out) { | |
2114 | $s->{timedout} = 1; | |
2115 | return $self->error("read timed-out"); | |
2116 | } | |
2117 | ||
2118 | ## Wait for input ready. | |
2119 | $nfound = select $ready=$s->{fdmask}, "", "", $timeout; | |
2120 | ||
2121 | ## Handle any errors while waiting. | |
2122 | if (!defined $nfound or $nfound <= 0) { # input not ready | |
2123 | if (defined $nfound and $nfound == 0) { # timed-out | |
2124 | $s->{timedout} = 1; | |
2125 | return $self->error("read timed-out"); | |
2126 | } | |
2127 | else { # error waiting for input ready | |
2128 | next if $! =~ /^interrupted/i; | |
2129 | ||
2130 | $s->{opened} = ''; | |
2131 | return $self->error("read error: $!"); | |
2132 | } | |
2133 | } | |
2134 | ||
2135 | ## Append to buffer any partially processed telnet or CR sequence. | |
2136 | $pushback_len = length $s->{pushback_buf}; | |
2137 | if ($pushback_len) { | |
2138 | $s->{buf} .= $s->{pushback_buf}; | |
2139 | $s->{pushback_buf} = ""; | |
2140 | } | |
2141 | ||
2142 | ## Read the waiting data. | |
2143 | $read_pos = length $s->{buf}; | |
2144 | $unparsed_pos = $read_pos - $pushback_len; | |
2145 | $nread = sysread $self, $s->{buf}, $s->{blksize}, $read_pos; | |
2146 | ||
2147 | ## Handle any read errors. | |
2148 | if (!defined $nread) { # read failed | |
2149 | next if $! =~ /^interrupted/i; # restart interrupted syscall | |
2150 | ||
2151 | $s->{opened} = ''; | |
2152 | return $self->error("read error: $!"); | |
2153 | } | |
2154 | ||
2155 | ## Handle eof. | |
2156 | if ($nread == 0) { # eof read | |
2157 | $s->{opened} = ''; | |
2158 | return; | |
2159 | } | |
2160 | ||
2161 | ## Display network traffic if requested. | |
2162 | if ($s->{dumplog}) { | |
2163 | &_log_dump('<', $s->{dumplog}, \$s->{buf}, $read_pos); | |
2164 | } | |
2165 | ||
2166 | ## Process any telnet commands in the data stream. | |
2167 | if ($s->{telnet_mode} and index($s->{buf},"\377",$unparsed_pos) > -1) { | |
2168 | &_interpret_tcmd($self, $s, $unparsed_pos); | |
2169 | } | |
2170 | ||
2171 | ## Process any carriage-return sequences in the data stream. | |
2172 | &_interpret_cr($s, $unparsed_pos); | |
2173 | ||
2174 | ## Read again if all chars read were consumed as telnet cmds. | |
2175 | next if $unparsed_pos >= length $s->{buf}; | |
2176 | ||
2177 | ## Log the input if requested. | |
2178 | if ($s->{inputlog}) { | |
2179 | &_log_print($s->{inputlog}, substr($s->{buf}, $unparsed_pos)); | |
2180 | } | |
2181 | ||
2182 | ## Save the last line read. | |
2183 | &_save_lastline($s); | |
2184 | ||
2185 | ## We've successfully read some data into the buffer. | |
2186 | last; | |
2187 | } # end while(1) | |
2188 | ||
2189 | 1; | |
2190 | } # end sub _fillbuf | |
2191 | ||
2192 | ||
2193 | sub _flush_opts { | |
2194 | my ($self) = @_; | |
2195 | my ( | |
2196 | $option_chars, | |
2197 | ); | |
2198 | my $s = *$self->{net_telnet}; | |
2199 | ||
2200 | ## Get option and clear the output buf. | |
2201 | $option_chars = $s->{unsent_opts}; | |
2202 | $s->{unsent_opts} = ""; | |
2203 | ||
2204 | ## Try to send options without waiting. | |
2205 | { | |
2206 | local $s->{errormode} = "return"; | |
2207 | local $s->{time_out} = 0; | |
2208 | &_put($self, \$option_chars, "telnet option negotiation") | |
2209 | or do { | |
2210 | ## Save chars not printed for later. | |
2211 | substr($option_chars, 0, $self->print_length) = ""; | |
2212 | $s->{unsent_opts} .= $option_chars; | |
2213 | }; | |
2214 | } | |
2215 | ||
2216 | 1; | |
2217 | } # end sub _flush_opts | |
2218 | ||
2219 | ||
2220 | sub _fname_to_handle { | |
2221 | my ($self, $fh) = @_; | |
2222 | my ( | |
2223 | $filename, | |
2224 | ); | |
2225 | ||
2226 | ## Ensure valid input. | |
2227 | return "" | |
2228 | unless defined $fh and (ref $fh or length $fh); | |
2229 | ||
2230 | ## Open a new filehandle if input is a filename. | |
2231 | no strict "refs"; | |
2232 | if (!ref($fh) and !defined(fileno $fh)) { # fh is a filename | |
2233 | $filename = $fh; | |
2234 | $fh = &_new_handle(); | |
2235 | CORE::open $fh, "> $filename" | |
2236 | or return $self->error("problem creating $filename: $!"); | |
2237 | } | |
2238 | ||
2239 | select((select($fh), $|=1)[$[]); # don't buffer writes | |
2240 | $fh; | |
2241 | } # end sub _fname_to_handle | |
2242 | ||
2243 | ||
2244 | sub _have_alarm { | |
2245 | eval { | |
2246 | local $SIG{"__DIE__"} = "DEFAULT"; | |
2247 | local $SIG{ALRM} = sub { die }; | |
2248 | alarm 0; | |
2249 | }; | |
2250 | ||
2251 | ! $@; | |
2252 | } # end sub _have_alarm | |
2253 | ||
2254 | ||
2255 | sub _interpret_cr { | |
2256 | my ($s, $pos) = @_; | |
2257 | my ( | |
2258 | $nextchar, | |
2259 | ); | |
2260 | ||
2261 | while (($pos = index($s->{buf}, "\015", $pos)) > -1) { | |
2262 | $nextchar = substr($s->{buf}, $pos + 1, 1); | |
2263 | if ($nextchar eq "\0") { | |
2264 | ## Convert CR NULL to CR when in telnet mode. | |
2265 | if ($s->{telnet_mode}) { | |
2266 | substr($s->{buf}, $pos + 1, 1) = ""; | |
2267 | } | |
2268 | } | |
2269 | elsif ($nextchar eq "\012") { | |
2270 | ## Convert CR LF to newline when not in binary mode. | |
2271 | if (!$s->{bin_mode}) { | |
2272 | substr($s->{buf}, $pos, 2) = "\n"; | |
2273 | } | |
2274 | } | |
2275 | elsif (!length($nextchar) and ($s->{telnet_mode} or !$s->{bin_mode})) { | |
2276 | ## Save CR in alt buffer for possible CR LF or CR NULL conversion. | |
2277 | $s->{pushback_buf} .= "\015"; | |
2278 | chop $s->{buf}; | |
2279 | } | |
2280 | ||
2281 | $pos++; | |
2282 | } | |
2283 | ||
2284 | 1; | |
2285 | } # end sub _interpret_cr | |
2286 | ||
2287 | ||
2288 | sub _interpret_tcmd { | |
2289 | my ($self, $s, $offset) = @_; | |
2290 | my ( | |
2291 | $callback, | |
2292 | $endpos, | |
2293 | $nextchar, | |
2294 | $option, | |
2295 | $parameters, | |
2296 | $pos, | |
2297 | $subcmd, | |
2298 | ); | |
2299 | local $_; | |
2300 | ||
2301 | ## Parse telnet commands in the data stream. | |
2302 | $pos = $offset; | |
2303 | while (($pos = index $s->{buf}, "\377", $pos) > -1) { # unprocessed IAC | |
2304 | $nextchar = substr $s->{buf}, $pos + 1, 1; | |
2305 | ||
2306 | ## Save command if it's only partially read. | |
2307 | if (!length $nextchar) { | |
2308 | $s->{pushback_buf} .= "\377"; | |
2309 | chop $s->{buf}; | |
2310 | last; | |
2311 | } | |
2312 | ||
2313 | if ($nextchar eq "\377") { # IAC is escaping "\377" char | |
2314 | ## Remove escape char from data stream. | |
2315 | substr($s->{buf}, $pos, 1) = ""; | |
2316 | $pos++; | |
2317 | } | |
2318 | elsif ($nextchar eq "\375" or $nextchar eq "\373" or | |
2319 | $nextchar eq "\374" or $nextchar eq "\376") { # opt negotiation | |
2320 | $option = substr $s->{buf}, $pos + 2, 1; | |
2321 | ||
2322 | ## Save command if it's only partially read. | |
2323 | if (!length $option) { | |
2324 | $s->{pushback_buf} .= "\377" . $nextchar; | |
2325 | chop $s->{buf}; | |
2326 | chop $s->{buf}; | |
2327 | last; | |
2328 | } | |
2329 | ||
2330 | ## Remove command from data stream. | |
2331 | substr($s->{buf}, $pos, 3) = ""; | |
2332 | ||
2333 | ## Handle option negotiation. | |
2334 | &_negotiate_recv($self, $s, $nextchar, ord($option), $pos); | |
2335 | } | |
2336 | elsif ($nextchar eq "\372") { # start of subnegotiation parameters | |
2337 | ## Save command if it's only partially read. | |
2338 | $endpos = index $s->{buf}, "\360", $pos; | |
2339 | if ($endpos == -1) { | |
2340 | $s->{pushback_buf} .= substr $s->{buf}, $pos; | |
2341 | substr($s->{buf}, $pos) = ""; | |
2342 | last; | |
2343 | } | |
2344 | ||
2345 | ## Remove subnegotiation cmd from buffer. | |
2346 | $subcmd = substr($s->{buf}, $pos, $endpos - $pos + 1); | |
2347 | substr($s->{buf}, $pos, $endpos - $pos + 1) = ""; | |
2348 | ||
2349 | ## Invoke subnegotiation callback. | |
2350 | if ($s->{subopt_cback} and length($subcmd) >= 5) { | |
2351 | $option = unpack "C", substr($subcmd, 2, 1); | |
2352 | if (length($subcmd) >= 6) { | |
2353 | $parameters = substr $subcmd, 3, length($subcmd) - 5; | |
2354 | } | |
2355 | else { | |
2356 | $parameters = ""; | |
2357 | } | |
2358 | ||
2359 | $callback = $s->{subopt_cback}; | |
2360 | &$callback($self, $option, $parameters); | |
2361 | } | |
2362 | } | |
2363 | else { # various two char telnet commands | |
2364 | ## Ignore and remove command from data stream. | |
2365 | substr($s->{buf}, $pos, 2) = ""; | |
2366 | } | |
2367 | } | |
2368 | ||
2369 | ## Try to send any waiting option negotiation. | |
2370 | if (length $s->{unsent_opts}) { | |
2371 | &_flush_opts($self); | |
2372 | } | |
2373 | ||
2374 | 1; | |
2375 | } # end sub _interpret_tcmd | |
2376 | ||
2377 | ||
2378 | sub _io_socket_include { | |
2379 | local $SIG{"__DIE__"} = "DEFAULT"; | |
2380 | eval "require IO::Socket"; | |
2381 | } # end sub io_socket_include | |
2382 | ||
2383 | ||
2384 | sub _log_dump { | |
2385 | my ($direction, $fh, $data, $offset, $len) = @_; | |
2386 | my ( | |
2387 | $addr, | |
2388 | $hexvals, | |
2389 | $line, | |
2390 | ); | |
2391 | ||
2392 | $addr = 0; | |
2393 | $len = length($$data) - $offset | |
2394 | if !defined $len; | |
2395 | return 1 if $len <= 0; | |
2396 | ||
2397 | ## Print data in dump format. | |
2398 | while ($len > 0) { | |
2399 | ## Convert up to the next 16 chars to hex, padding w/ spaces. | |
2400 | if ($len >= 16) { | |
2401 | $line = substr $$data, $offset, 16; | |
2402 | } | |
2403 | else { | |
2404 | $line = substr $$data, $offset, $len; | |
2405 | } | |
2406 | $hexvals = unpack("H*", $line); | |
2407 | $hexvals .= ' ' x (32 - length $hexvals); | |
2408 | ||
2409 | ## Place in 16 columns, each containing two hex digits. | |
2410 | $hexvals = sprintf("%s %s %s %s " x 4, | |
2411 | unpack("a2" x 16, $hexvals)); | |
2412 | ||
2413 | ## For the ASCII column, change unprintable chars to a period. | |
2414 | $line =~ s/[\000-\037,\177-\237]/./g; | |
2415 | ||
2416 | ## Print the line in dump format. | |
2417 | &_log_print($fh, sprintf("%s 0x%5.5lx: %s%s\n", | |
2418 | $direction, $addr, $hexvals, $line)); | |
2419 | ||
2420 | $addr += 16; | |
2421 | $offset += 16; | |
2422 | $len -= 16; | |
2423 | } | |
2424 | ||
2425 | &_log_print($fh, "\n"); | |
2426 | ||
2427 | 1; | |
2428 | } # end sub _log_dump | |
2429 | ||
2430 | ||
2431 | sub _log_option { | |
2432 | my ($fh, $direction, $request, $option) = @_; | |
2433 | my ( | |
2434 | $name, | |
2435 | ); | |
2436 | ||
2437 | if ($option >= 0 and $option <= $#Telopts) { | |
2438 | $name = $Telopts[$option]; | |
2439 | } | |
2440 | else { | |
2441 | $name = $option; | |
2442 | } | |
2443 | ||
2444 | &_log_print($fh, "$direction $request $name\n"); | |
2445 | } # end sub _log_option | |
2446 | ||
2447 | ||
2448 | sub _log_print { | |
2449 | my ($fh, $buf) = @_; | |
2450 | local $\ = ''; | |
2451 | ||
2452 | if (ref($fh) and ref($fh) ne "GLOB") { # fh is blessed ref | |
2453 | $fh->print($buf); | |
2454 | } | |
2455 | else { # fh isn't blessed ref | |
2456 | print $fh $buf; | |
2457 | } | |
2458 | } # end sub _log_print | |
2459 | ||
2460 | ||
2461 | sub _match_check { | |
2462 | my ($self, $code) = @_; | |
2463 | my $error; | |
2464 | my @warns = (); | |
2465 | ||
2466 | ## Use eval to check for syntax errors or warnings. | |
2467 | { | |
2468 | local $SIG{"__DIE__"} = "DEFAULT"; | |
2469 | local $SIG{"__WARN__"} = sub { push @warns, @_ }; | |
2470 | local $^W = 1; | |
2471 | local $_ = ''; | |
2472 | eval "\$_ =~ $code;"; | |
2473 | } | |
2474 | if ($@) { | |
2475 | ## Remove useless lines numbers from message. | |
2476 | ($error = $@) =~ s/ at \(eval \d+\) line \d+.?//; | |
2477 | chomp $error; | |
2478 | return $self->error("bad match operator: $error"); | |
2479 | } | |
2480 | elsif (@warns) { | |
2481 | ## Remove useless lines numbers from message. | |
2482 | ($error = shift @warns) =~ s/ at \(eval \d+\) line \d+.?//; | |
2483 | $error =~ s/ while "strict subs" in use//; | |
2484 | chomp $error; | |
2485 | return $self->error("bad match operator: $error"); | |
2486 | } | |
2487 | ||
2488 | 1; | |
2489 | } # end sub _match_check | |
2490 | ||
2491 | ||
2492 | sub _negotiate_callback { | |
2493 | my ($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_; | |
2494 | my ( | |
2495 | $callback, | |
2496 | $s, | |
2497 | ); | |
2498 | local $_; | |
2499 | ||
2500 | ## Keep track of remote echo. | |
2501 | if ($is_remote and $opt == &TELOPT_ECHO) { # received WILL or WONT ECHO | |
2502 | $s = *$self->{net_telnet}; | |
2503 | ||
2504 | if ($is_enabled and !$was_enabled) { # received WILL ECHO | |
2505 | $s->{remote_echo} = 1; | |
2506 | } | |
2507 | elsif (!$is_enabled and $was_enabled) { # received WONT ECHO | |
2508 | $s->{remote_echo} = ''; | |
2509 | } | |
2510 | } | |
2511 | ||
2512 | ## Invoke callback, if there is one. | |
2513 | $callback = $self->option_callback; | |
2514 | if ($callback) { | |
2515 | &$callback($self, $opt, $is_remote, | |
2516 | $is_enabled, $was_enabled, $opt_bufpos); | |
2517 | } | |
2518 | ||
2519 | 1; | |
2520 | } # end sub _negotiate_callback | |
2521 | ||
2522 | ||
2523 | sub _negotiate_recv { | |
2524 | my ($self, $s, $opt_request, $opt, $opt_bufpos) = @_; | |
2525 | ||
2526 | ## Ensure data structure exists for this option. | |
2527 | unless (defined $s->{opts}{$opt}) { | |
2528 | &_set_default_option($s, $opt); | |
2529 | } | |
2530 | ||
2531 | ## Process the option. | |
2532 | if ($opt_request eq "\376") { # DONT | |
2533 | &_negotiate_recv_disable($self, $s, $opt, "dont", $opt_bufpos, | |
2534 | $s->{opts}{$opt}{local_enable_ok}, | |
2535 | \$s->{opts}{$opt}{local_enabled}, | |
2536 | \$s->{opts}{$opt}{local_state}); | |
2537 | } | |
2538 | elsif ($opt_request eq "\375") { # DO | |
2539 | &_negotiate_recv_enable($self, $s, $opt, "do", $opt_bufpos, | |
2540 | $s->{opts}{$opt}{local_enable_ok}, | |
2541 | \$s->{opts}{$opt}{local_enabled}, | |
2542 | \$s->{opts}{$opt}{local_state}); | |
2543 | } | |
2544 | elsif ($opt_request eq "\374") { # WONT | |
2545 | &_negotiate_recv_disable($self, $s, $opt, "wont", $opt_bufpos, | |
2546 | $s->{opts}{$opt}{remote_enable_ok}, | |
2547 | \$s->{opts}{$opt}{remote_enabled}, | |
2548 | \$s->{opts}{$opt}{remote_state}); | |
2549 | } | |
2550 | elsif ($opt_request eq "\373") { # WILL | |
2551 | &_negotiate_recv_enable($self, $s, $opt, "will", $opt_bufpos, | |
2552 | $s->{opts}{$opt}{remote_enable_ok}, | |
2553 | \$s->{opts}{$opt}{remote_enabled}, | |
2554 | \$s->{opts}{$opt}{remote_state}); | |
2555 | } | |
2556 | else { # internal error | |
2557 | die; | |
2558 | } | |
2559 | ||
2560 | 1; | |
2561 | } # end sub _negotiate_recv | |
2562 | ||
2563 | ||
2564 | sub _negotiate_recv_disable { | |
2565 | my ($self, $s, $opt, $opt_request, | |
2566 | $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; | |
2567 | my ( | |
2568 | $ack, | |
2569 | $disable_cmd, | |
2570 | $enable_cmd, | |
2571 | $is_remote, | |
2572 | $nak, | |
2573 | $was_enabled, | |
2574 | ); | |
2575 | ||
2576 | ## What do we use to request enable/disable or respond with ack/nak. | |
2577 | if ($opt_request eq "wont") { | |
2578 | $enable_cmd = "\377\375" . pack("C", $opt); # do command | |
2579 | $disable_cmd = "\377\376" . pack("C", $opt); # dont command | |
2580 | $is_remote = 1; | |
2581 | $ack = "DO"; | |
2582 | $nak = "DONT"; | |
2583 | ||
2584 | &_log_option($s->{opt_log}, "RCVD", "WONT", $opt) | |
2585 | if $s->{opt_log}; | |
2586 | } | |
2587 | elsif ($opt_request eq "dont") { | |
2588 | $enable_cmd = "\377\373" . pack("C", $opt); # will command | |
2589 | $disable_cmd = "\377\374" . pack("C", $opt); # wont command | |
2590 | $is_remote = ''; | |
2591 | $ack = "WILL"; | |
2592 | $nak = "WONT"; | |
2593 | ||
2594 | &_log_option($s->{opt_log}, "RCVD", "DONT", $opt) | |
2595 | if $s->{opt_log}; | |
2596 | } | |
2597 | else { # internal error | |
2598 | die; | |
2599 | } | |
2600 | ||
2601 | ## Respond to WONT or DONT based on the current negotiation state. | |
2602 | if ($$state eq "no") { # state is already disabled | |
2603 | } | |
2604 | elsif ($$state eq "yes") { # they're initiating disable | |
2605 | $$is_enabled = ''; | |
2606 | $$state = "no"; | |
2607 | ||
2608 | ## Send positive acknowledgment. | |
2609 | $s->{unsent_opts} .= $disable_cmd; | |
2610 | &_log_option($s->{opt_log}, "SENT", $nak, $opt) | |
2611 | if $s->{opt_log}; | |
2612 | ||
2613 | ## Invoke callbacks. | |
2614 | &_negotiate_callback($self, $opt, $is_remote, | |
2615 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2616 | } | |
2617 | elsif ($$state eq "wantno") { # they sent positive ack | |
2618 | $$is_enabled = ''; | |
2619 | $$state = "no"; | |
2620 | ||
2621 | ## Invoke callback. | |
2622 | &_negotiate_callback($self, $opt, $is_remote, | |
2623 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2624 | } | |
2625 | elsif ($$state eq "wantno opposite") { # pos ack but we changed our mind | |
2626 | ## Indicate disabled but now we want to enable. | |
2627 | $$is_enabled = ''; | |
2628 | $$state = "wantyes"; | |
2629 | ||
2630 | ## Send queued request. | |
2631 | $s->{unsent_opts} .= $enable_cmd; | |
2632 | &_log_option($s->{opt_log}, "SENT", $ack, $opt) | |
2633 | if $s->{opt_log}; | |
2634 | ||
2635 | ## Invoke callback. | |
2636 | &_negotiate_callback($self, $opt, $is_remote, | |
2637 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2638 | } | |
2639 | elsif ($$state eq "wantyes") { # they sent negative ack | |
2640 | $$is_enabled = ''; | |
2641 | $$state = "no"; | |
2642 | ||
2643 | ## Invoke callback. | |
2644 | &_negotiate_callback($self, $opt, $is_remote, | |
2645 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2646 | } | |
2647 | elsif ($$state eq "wantyes opposite") { # nak but we changed our mind | |
2648 | $$is_enabled = ''; | |
2649 | $$state = "no"; | |
2650 | ||
2651 | ## Invoke callback. | |
2652 | &_negotiate_callback($self, $opt, $is_remote, | |
2653 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2654 | } | |
2655 | } # end sub _negotiate_recv_disable | |
2656 | ||
2657 | ||
2658 | sub _negotiate_recv_enable { | |
2659 | my ($self, $s, $opt, $opt_request, | |
2660 | $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; | |
2661 | my ( | |
2662 | $ack, | |
2663 | $disable_cmd, | |
2664 | $enable_cmd, | |
2665 | $is_remote, | |
2666 | $nak, | |
2667 | $was_enabled, | |
2668 | ); | |
2669 | ||
2670 | ## What we use to send enable/disable request or send ack/nak response. | |
2671 | if ($opt_request eq "will") { | |
2672 | $enable_cmd = "\377\375" . pack("C", $opt); # do command | |
2673 | $disable_cmd = "\377\376" . pack("C", $opt); # dont command | |
2674 | $is_remote = 1; | |
2675 | $ack = "DO"; | |
2676 | $nak = "DONT"; | |
2677 | ||
2678 | &_log_option($s->{opt_log}, "RCVD", "WILL", $opt) | |
2679 | if $s->{opt_log}; | |
2680 | } | |
2681 | elsif ($opt_request eq "do") { | |
2682 | $enable_cmd = "\377\373" . pack("C", $opt); # will command | |
2683 | $disable_cmd = "\377\374" . pack("C", $opt); # wont command | |
2684 | $is_remote = ''; | |
2685 | $ack = "WILL"; | |
2686 | $nak = "WONT"; | |
2687 | ||
2688 | &_log_option($s->{opt_log}, "RCVD", "DO", $opt) | |
2689 | if $s->{opt_log}; | |
2690 | } | |
2691 | else { # internal error | |
2692 | die; | |
2693 | } | |
2694 | ||
2695 | ## Save current enabled state. | |
2696 | $was_enabled = $$is_enabled; | |
2697 | ||
2698 | ## Respond to WILL or DO based on the current negotiation state. | |
2699 | if ($$state eq "no") { # they're initiating enable | |
2700 | if ($enable_ok) { # we agree they/us should enable | |
2701 | $$is_enabled = 1; | |
2702 | $$state = "yes"; | |
2703 | ||
2704 | ## Send positive acknowledgment. | |
2705 | $s->{unsent_opts} .= $enable_cmd; | |
2706 | &_log_option($s->{opt_log}, "SENT", $ack, $opt) | |
2707 | if $s->{opt_log}; | |
2708 | ||
2709 | ## Invoke callbacks. | |
2710 | &_negotiate_callback($self, $opt, $is_remote, | |
2711 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2712 | } | |
2713 | else { # we disagree they/us should enable | |
2714 | ## Send negative acknowledgment. | |
2715 | $s->{unsent_opts} .= $disable_cmd; | |
2716 | &_log_option($s->{opt_log}, "SENT", $nak, $opt) | |
2717 | if $s->{opt_log}; | |
2718 | } | |
2719 | } | |
2720 | elsif ($$state eq "yes") { # state is already enabled | |
2721 | } | |
2722 | elsif ($$state eq "wantno") { # error: our disable req answered by enable | |
2723 | $$is_enabled = ''; | |
2724 | $$state = "no"; | |
2725 | ||
2726 | ## Invoke callbacks. | |
2727 | &_negotiate_callback($self, $opt, $is_remote, | |
2728 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2729 | } | |
2730 | elsif ($$state eq "wantno opposite") { # err: disable req answerd by enable | |
2731 | $$is_enabled = 1; | |
2732 | $$state = "yes"; | |
2733 | ||
2734 | ## Invoke callbacks. | |
2735 | &_negotiate_callback($self, $opt, $is_remote, | |
2736 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2737 | } | |
2738 | elsif ($$state eq "wantyes") { # they sent pos ack | |
2739 | $$is_enabled = 1; | |
2740 | $$state = "yes"; | |
2741 | ||
2742 | ## Invoke callback. | |
2743 | &_negotiate_callback($self, $opt, $is_remote, | |
2744 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2745 | } | |
2746 | elsif ($$state eq "wantyes opposite") { # pos ack but we changed our mind | |
2747 | ## Indicate enabled but now we want to disable. | |
2748 | $$is_enabled = 1; | |
2749 | $$state = "wantno"; | |
2750 | ||
2751 | ## Inform other side we changed our mind. | |
2752 | $s->{unsent_opts} .= $disable_cmd; | |
2753 | &_log_option($s->{opt_log}, "SENT", $nak, $opt) | |
2754 | if $s->{opt_log}; | |
2755 | ||
2756 | ## Invoke callback. | |
2757 | &_negotiate_callback($self, $opt, $is_remote, | |
2758 | $$is_enabled, $was_enabled, $opt_bufpos); | |
2759 | } | |
2760 | ||
2761 | 1; | |
2762 | } # end sub _negotiate_recv_enable | |
2763 | ||
2764 | ||
2765 | sub _new_handle { | |
2766 | if ($INC{"IO/Handle.pm"}) { | |
2767 | return IO::Handle->new; | |
2768 | } | |
2769 | else { | |
2770 | require FileHandle; | |
2771 | return FileHandle->new; | |
2772 | } | |
2773 | } # end sub _new_handle | |
2774 | ||
2775 | ||
2776 | sub _next_getlines { | |
2777 | my ($self, $s) = @_; | |
2778 | my ( | |
2779 | $len, | |
2780 | $line, | |
2781 | $pos, | |
2782 | @lines, | |
2783 | ); | |
2784 | ||
2785 | ## Fill buffer and get first line. | |
2786 | $line = $self->getline | |
2787 | or return; | |
2788 | push @lines, $line; | |
2789 | ||
2790 | ## Extract subsequent lines from buffer. | |
2791 | while (($pos = index($s->{buf}, $s->{rs})) != -1) { | |
2792 | $len = $pos + length $s->{rs}; | |
2793 | push @lines, substr($s->{buf}, 0, $len); | |
2794 | substr($s->{buf}, 0, $len) = ""; | |
2795 | } | |
2796 | ||
2797 | @lines; | |
2798 | } # end sub _next_getlines | |
2799 | ||
2800 | ||
2801 | sub _opt_accept { | |
2802 | my ($self, @args) = @_; | |
2803 | my ( | |
2804 | $arg, | |
2805 | $option, | |
2806 | $s, | |
2807 | ); | |
2808 | ||
2809 | ## Init. | |
2810 | $s = *$self->{net_telnet}; | |
2811 | ||
2812 | foreach $arg (@args) { | |
2813 | ## Ensure data structure defined for this option. | |
2814 | $option = $arg->{option}; | |
2815 | if (!defined $s->{opts}{$option}) { | |
2816 | &_set_default_option($s, $option); | |
2817 | } | |
2818 | ||
2819 | ## Save whether we'll accept or reject this option. | |
2820 | if ($arg->{is_remote}) { | |
2821 | $s->{opts}{$option}{remote_enable_ok} = $arg->{is_enable}; | |
2822 | } | |
2823 | else { | |
2824 | $s->{opts}{$option}{local_enable_ok} = $arg->{is_enable}; | |
2825 | } | |
2826 | } | |
2827 | ||
2828 | 1; | |
2829 | } # end sub _opt_accept | |
2830 | ||
2831 | ||
2832 | sub _optimal_blksize { | |
2833 | my ($blksize) = @_; | |
2834 | local $^W = ''; # avoid non-numeric warning for ms-windows blksize of "" | |
2835 | ||
2836 | ## Use default when block size is invalid. | |
2837 | return 8192 | |
2838 | unless defined $blksize and $blksize >= 1 and $blksize <= 1_048_576; | |
2839 | ||
2840 | $blksize; | |
2841 | } # end sub _optimal_blksize | |
2842 | ||
2843 | ||
2844 | sub _parse_cmd_remove_mode { | |
2845 | my ($self, $mode) = @_; | |
2846 | ||
2847 | if (!defined $mode) { | |
2848 | $mode = 0; | |
2849 | } | |
2850 | elsif ($mode =~ /^\s*auto\s*$/i) { | |
2851 | $mode = "auto"; | |
2852 | } | |
2853 | elsif ($mode !~ /^\d+$/) { | |
2854 | &_carp($self, "ignoring bad Cmd_remove_mode " . | |
2855 | "argument \"$mode\": it's not \"auto\" or a " . | |
2856 | "non-negative integer"); | |
2857 | $mode = *$self->{net_telnet}{cmd_rm_mode}; | |
2858 | } | |
2859 | ||
2860 | $mode; | |
2861 | } # end sub _parse_cmd_remove_mode | |
2862 | ||
2863 | ||
2864 | sub _parse_errmode { | |
2865 | my ($self, $errmode) = @_; | |
2866 | ||
2867 | ## Set the error mode. | |
2868 | if (!defined $errmode) { | |
2869 | &_carp($self, "ignoring undefined Errmode argument"); | |
2870 | $errmode = *$self->{net_telnet}{errormode}; | |
2871 | } | |
2872 | elsif ($errmode =~ /^\s*return\s*$/i) { | |
2873 | $errmode = "return"; | |
2874 | } | |
2875 | elsif ($errmode =~ /^\s*die\s*$/i) { | |
2876 | $errmode = "die"; | |
2877 | } | |
2878 | elsif (ref($errmode) eq "CODE") { | |
2879 | } | |
2880 | elsif (ref($errmode) eq "ARRAY") { | |
2881 | unless (ref($errmode->[0]) eq "CODE") { | |
2882 | &_carp($self, "ignoring bad Errmode argument: " . | |
2883 | "first list item isn't a code ref"); | |
2884 | $errmode = *$self->{net_telnet}{errormode}; | |
2885 | } | |
2886 | } | |
2887 | else { | |
2888 | &_carp($self, "ignoring bad Errmode argument \"$errmode\""); | |
2889 | $errmode = *$self->{net_telnet}{errormode}; | |
2890 | } | |
2891 | ||
2892 | $errmode; | |
2893 | } # end sub _parse_errmode | |
2894 | ||
2895 | ||
2896 | sub _parse_input_record_separator { | |
2897 | my ($self, $rs) = @_; | |
2898 | ||
2899 | unless (defined $rs and length $rs) { | |
2900 | &_carp($self, "ignoring null Input_record_separator argument"); | |
2901 | $rs = *$self->{net_telnet}{rs}; | |
2902 | } | |
2903 | ||
2904 | $rs; | |
2905 | } # end sub _parse_input_record_separator | |
2906 | ||
2907 | ||
2908 | sub _parse_prompt { | |
2909 | my ($self, $prompt) = @_; | |
2910 | ||
2911 | unless (defined $prompt) { | |
2912 | $prompt = ""; | |
2913 | } | |
2914 | ||
2915 | unless ($prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W)) { | |
2916 | &_carp($self, "ignoring bad Prompt argument \"$prompt\": " . | |
2917 | "missing opening delimiter of match operator"); | |
2918 | $prompt = *$self->{net_telnet}{cmd_prompt}; | |
2919 | } | |
2920 | ||
2921 | $prompt; | |
2922 | } # end sub _parse_prompt | |
2923 | ||
2924 | ||
2925 | sub _parse_timeout { | |
2926 | my ($self, $timeout) = @_; | |
2927 | ||
2928 | ## Ensure valid timeout. | |
2929 | if (defined $timeout) { | |
2930 | ## Test for non-numeric or negative values. | |
2931 | eval { | |
2932 | local $SIG{"__DIE__"} = "DEFAULT"; | |
2933 | local $SIG{"__WARN__"} = sub { die "non-numeric\n" }; | |
2934 | local $^W = 1; | |
2935 | $timeout *= 1; | |
2936 | }; | |
2937 | if ($@) { # timeout arg is non-numeric | |
2938 | &_carp($self, | |
2939 | "ignoring non-numeric Timeout argument \"$timeout\""); | |
2940 | $timeout = *$self->{net_telnet}{time_out}; | |
2941 | } | |
2942 | elsif ($timeout < 0) { # timeout arg is negative | |
2943 | &_carp($self, "ignoring negative Timeout argument \"$timeout\""); | |
2944 | $timeout = *$self->{net_telnet}{time_out}; | |
2945 | } | |
2946 | } | |
2947 | ||
2948 | $timeout; | |
2949 | } # end sub _parse_timeout | |
2950 | ||
2951 | ||
2952 | sub _put { | |
2953 | my ($self, $buf, $subname) = @_; | |
2954 | my ( | |
2955 | $endtime, | |
2956 | $len, | |
2957 | $nfound, | |
2958 | $nwrote, | |
2959 | $offset, | |
2960 | $ready, | |
2961 | $s, | |
2962 | $timed_out, | |
2963 | $timeout, | |
2964 | $zero_wrote_count, | |
2965 | ); | |
2966 | ||
2967 | ## Init. | |
2968 | $s = *$self->{net_telnet}; | |
2969 | $s->{num_wrote} = 0; | |
2970 | $zero_wrote_count = 0; | |
2971 | $offset = 0; | |
2972 | $len = length $$buf; | |
2973 | $endtime = &_endtime($s->{time_out}); | |
2974 | ||
2975 | return $self->error("write error: filehandle isn't open") | |
2976 | unless $s->{opened}; | |
2977 | ||
2978 | ## Try to send any waiting option negotiation. | |
2979 | if (length $s->{unsent_opts}) { | |
2980 | &_flush_opts($self); | |
2981 | } | |
2982 | ||
2983 | ## Write until all data blocks written. | |
2984 | while ($len) { | |
2985 | ## Determine how long to wait for output ready. | |
2986 | ($timed_out, $timeout) = &_timeout_interval($endtime); | |
2987 | if ($timed_out) { | |
2988 | $s->{timedout} = 1; | |
2989 | return $self->error("$subname timed-out"); | |
2990 | } | |
2991 | ||
2992 | ## Wait for output ready. | |
2993 | $nfound = select "", $ready=$s->{fdmask}, "", $timeout; | |
2994 | ||
2995 | ## Handle any errors while waiting. | |
2996 | if (!defined $nfound or $nfound <= 0) { # output not ready | |
2997 | if (defined $nfound and $nfound == 0) { # timed-out | |
2998 | $s->{timedout} = 1; | |
2999 | return $self->error("$subname timed-out"); | |
3000 | } | |
3001 | else { # error waiting for output ready | |
3002 | next if $! =~ /^interrupted/i; | |
3003 | ||
3004 | $s->{opened} = ''; | |
3005 | return $self->error("write error: $!"); | |
3006 | } | |
3007 | } | |
3008 | ||
3009 | ## Write the data. | |
3010 | $nwrote = syswrite $self, $$buf, $len, $offset; | |
3011 | ||
3012 | ## Handle any write errors. | |
3013 | if (!defined $nwrote) { # write failed | |
3014 | next if $! =~ /^interrupted/i; # restart interrupted syscall | |
3015 | ||
3016 | $s->{opened} = ''; | |
3017 | return $self->error("write error: $!"); | |
3018 | } | |
3019 | elsif ($nwrote == 0) { # zero chars written | |
3020 | ## Try ten more times to write the data. | |
3021 | if ($zero_wrote_count++ <= 10) { | |
3022 | &_sleep(0.01); | |
3023 | next; | |
3024 | } | |
3025 | ||
3026 | $s->{opened} = ''; | |
3027 | return $self->error("write error: zero length write: $!"); | |
3028 | } | |
3029 | ||
3030 | ## Display network traffic if requested. | |
3031 | if ($s->{dumplog}) { | |
3032 | &_log_dump('>', $s->{dumplog}, $buf, $offset, $nwrote); | |
3033 | } | |
3034 | ||
3035 | ## Increment. | |
3036 | $s->{num_wrote} += $nwrote; | |
3037 | $offset += $nwrote; | |
3038 | $len -= $nwrote; | |
3039 | } | |
3040 | ||
3041 | 1; | |
3042 | } # end sub _put | |
3043 | ||
3044 | ||
3045 | sub _qualify_fh { | |
3046 | my ($obj, $name) = @_; | |
3047 | my ( | |
3048 | $user_class, | |
3049 | ); | |
3050 | local $_; | |
3051 | ||
3052 | ## Get user's package name. | |
3053 | ($user_class) = &_user_caller($obj); | |
3054 | ||
3055 | ## Ensure name is qualified with a package name. | |
3056 | $name = qualify($name, $user_class); | |
3057 | ||
3058 | ## If it's not already, make it a typeglob ref. | |
3059 | if (!ref $name) { | |
3060 | no strict; | |
3061 | local $^W = 0; | |
3062 | ||
3063 | $name =~ s/^\*+//; | |
3064 | $name = eval "\\*$name"; | |
3065 | return unless ref $name; | |
3066 | } | |
3067 | ||
3068 | $name; | |
3069 | } # end sub _qualify_fh | |
3070 | ||
3071 | ||
3072 | sub _reset_options { | |
3073 | my ($opts) = @_; | |
3074 | my ( | |
3075 | $opt, | |
3076 | ); | |
3077 | ||
3078 | foreach $opt (keys %$opts) { | |
3079 | $opts->{$opt}{remote_enabled} = ''; | |
3080 | $opts->{$opt}{remote_state} = "no"; | |
3081 | $opts->{$opt}{local_enabled} = ''; | |
3082 | $opts->{$opt}{local_state} = "no"; | |
3083 | } | |
3084 | ||
3085 | 1; | |
3086 | } # end sub _reset_options | |
3087 | ||
3088 | ||
3089 | sub _save_lastline { | |
3090 | my ($s) = @_; | |
3091 | my ( | |
3092 | $firstpos, | |
3093 | $lastpos, | |
3094 | $len_w_sep, | |
3095 | $len_wo_sep, | |
3096 | $offset, | |
3097 | ); | |
3098 | my $rs = "\n"; | |
3099 | ||
3100 | if (($lastpos = rindex $s->{buf}, $rs) > -1) { # eol found | |
3101 | while (1) { | |
3102 | ## Find beginning of line. | |
3103 | $firstpos = rindex $s->{buf}, $rs, $lastpos - 1; | |
3104 | if ($firstpos == -1) { | |
3105 | $offset = 0; | |
3106 | } | |
3107 | else { | |
3108 | $offset = $firstpos + length $rs; | |
3109 | } | |
3110 | ||
3111 | ## Determine length of line with and without separator. | |
3112 | $len_wo_sep = $lastpos - $offset; | |
3113 | $len_w_sep = $len_wo_sep + length $rs; | |
3114 | ||
3115 | ## Save line if it's not blank. | |
3116 | if (substr($s->{buf}, $offset, $len_wo_sep) | |
3117 | !~ /^\s*$/) | |
3118 | { | |
3119 | $s->{last_line} = substr($s->{buf}, | |
3120 | $offset, | |
3121 | $len_w_sep); | |
3122 | last; | |
3123 | } | |
3124 | ||
3125 | last if $firstpos == -1; | |
3126 | ||
3127 | $lastpos = $firstpos; | |
3128 | } | |
3129 | } | |
3130 | ||
3131 | 1; | |
3132 | } # end sub _save_lastline | |
3133 | ||
3134 | ||
3135 | sub _set_default_option { | |
3136 | my ($s, $option) = @_; | |
3137 | ||
3138 | $s->{opts}{$option} = { | |
3139 | remote_enabled => '', | |
3140 | remote_state => "no", | |
3141 | remote_enable_ok => '', | |
3142 | local_enabled => '', | |
3143 | local_state => "no", | |
3144 | local_enable_ok => '', | |
3145 | }; | |
3146 | } # end sub _set_default_option | |
3147 | ||
3148 | ||
3149 | sub _sleep { | |
3150 | my ($secs) = @_; | |
3151 | my $bitmask = ""; | |
3152 | local *SOCK; | |
3153 | ||
3154 | socket SOCK, AF_INET, SOCK_STREAM, 0; | |
3155 | vec($bitmask, fileno(SOCK), 1) = 1; | |
3156 | select $bitmask, "", "", $secs; | |
3157 | CORE::close SOCK; | |
3158 | ||
3159 | 1; | |
3160 | } # end sub _sleep | |
3161 | ||
3162 | ||
3163 | sub _timeout_interval { | |
3164 | my ($endtime) = @_; | |
3165 | my ( | |
3166 | $timeout, | |
3167 | ); | |
3168 | ||
3169 | ## Return timed-out boolean and timeout interval. | |
3170 | if (defined $endtime) { | |
3171 | ## Is it a one-time poll. | |
3172 | return ('', 0) if $endtime == 0; | |
3173 | ||
3174 | ## Calculate the timeout interval. | |
3175 | $timeout = $endtime - time; | |
3176 | ||
3177 | ## Did we already timeout. | |
3178 | return (1, 0) unless $timeout > 0; | |
3179 | ||
3180 | return ('', $timeout); | |
3181 | } | |
3182 | else { # there is no timeout | |
3183 | return ('', undef); | |
3184 | } | |
3185 | } # end sub _timeout_interval | |
3186 | ||
3187 | ||
3188 | sub _user_caller { | |
3189 | my ($obj) = @_; | |
3190 | my ( | |
3191 | $class, | |
3192 | $curr_pkg, | |
3193 | $file, | |
3194 | $i, | |
3195 | $line, | |
3196 | $pkg, | |
3197 | %isa, | |
3198 | @isa, | |
3199 | ); | |
3200 | local $_; | |
3201 | ||
3202 | ## Create a boolean hash to test for isa. Make sure current | |
3203 | ## package and the object's class are members. | |
3204 | $class = ref $obj; | |
3205 | @isa = eval "\@${class}::ISA"; | |
3206 | push @isa, $class; | |
3207 | ($curr_pkg) = caller 1; | |
3208 | push @isa, $curr_pkg; | |
3209 | %isa = map { $_ => 1 } @isa; | |
3210 | ||
3211 | ## Search back in call frames for a package that's not in isa. | |
3212 | $i = 1; | |
3213 | while (($pkg, $file, $line) = caller ++$i) { | |
3214 | next if $isa{$pkg}; | |
3215 | ||
3216 | return ($pkg, $file, $line); | |
3217 | } | |
3218 | ||
3219 | ## If not found, choose outer most call frame. | |
3220 | ($pkg, $file, $line) = caller --$i; | |
3221 | return ($pkg, $file, $line); | |
3222 | } # end sub _user_caller | |
3223 | ||
3224 | ||
3225 | sub _verify_telopt_arg { | |
3226 | my ($self, $option, $argname) = @_; | |
3227 | ||
3228 | ## If provided, use argument name in error message. | |
3229 | if (defined $argname) { | |
3230 | $argname = "for arg $argname"; | |
3231 | } | |
3232 | else { | |
3233 | $argname = ""; | |
3234 | } | |
3235 | ||
3236 | ## Ensure telnet option is a non-negative integer. | |
3237 | eval { | |
3238 | local $SIG{"__DIE__"} = "DEFAULT"; | |
3239 | local $SIG{"__WARN__"} = sub { die "non-numeric\n" }; | |
3240 | local $^W = 1; | |
3241 | $option = abs(int $option); | |
3242 | }; | |
3243 | return $self->error("bad telnet option $argname: non-numeric") | |
3244 | if $@; | |
3245 | ||
3246 | return $self->error("bad telnet option $argname: option > 255") | |
3247 | unless $option <= 255; | |
3248 | ||
3249 | $option; | |
3250 | } # end sub _verify_telopt_arg | |
3251 | ||
3252 | ||
3253 | ######################## Exported Constants ########################## | |
3254 | ||
3255 | ||
3256 | sub TELNET_IAC () {255}; # interpret as command: | |
3257 | sub TELNET_DONT () {254}; # you are not to use option | |
3258 | sub TELNET_DO () {253}; # please, you use option | |
3259 | sub TELNET_WONT () {252}; # I won't use option | |
3260 | sub TELNET_WILL () {251}; # I will use option | |
3261 | sub TELNET_SB () {250}; # interpret as subnegotiation | |
3262 | sub TELNET_GA () {249}; # you may reverse the line | |
3263 | sub TELNET_EL () {248}; # erase the current line | |
3264 | sub TELNET_EC () {247}; # erase the current character | |
3265 | sub TELNET_AYT () {246}; # are you there | |
3266 | sub TELNET_AO () {245}; # abort output--but let prog finish | |
3267 | sub TELNET_IP () {244}; # interrupt process--permanently | |
3268 | sub TELNET_BREAK () {243}; # break | |
3269 | sub TELNET_DM () {242}; # data mark--for connect. cleaning | |
3270 | sub TELNET_NOP () {241}; # nop | |
3271 | sub TELNET_SE () {240}; # end sub negotiation | |
3272 | sub TELNET_EOR () {239}; # end of record (transparent mode) | |
3273 | sub TELNET_ABORT () {238}; # Abort process | |
3274 | sub TELNET_SUSP () {237}; # Suspend process | |
3275 | sub TELNET_EOF () {236}; # End of file | |
3276 | sub TELNET_SYNCH () {242}; # for telfunc calls | |
3277 | ||
3278 | sub TELOPT_BINARY () {0}; # Binary Transmission | |
3279 | sub TELOPT_ECHO () {1}; # Echo | |
3280 | sub TELOPT_RCP () {2}; # Reconnection | |
3281 | sub TELOPT_SGA () {3}; # Suppress Go Ahead | |
3282 | sub TELOPT_NAMS () {4}; # Approx Message Size Negotiation | |
3283 | sub TELOPT_STATUS () {5}; # Status | |
3284 | sub TELOPT_TM () {6}; # Timing Mark | |
3285 | sub TELOPT_RCTE () {7}; # Remote Controlled Trans and Echo | |
3286 | sub TELOPT_NAOL () {8}; # Output Line Width | |
3287 | sub TELOPT_NAOP () {9}; # Output Page Size | |
3288 | sub TELOPT_NAOCRD () {10}; # Output Carriage-Return Disposition | |
3289 | sub TELOPT_NAOHTS () {11}; # Output Horizontal Tab Stops | |
3290 | sub TELOPT_NAOHTD () {12}; # Output Horizontal Tab Disposition | |
3291 | sub TELOPT_NAOFFD () {13}; # Output Formfeed Disposition | |
3292 | sub TELOPT_NAOVTS () {14}; # Output Vertical Tabstops | |
3293 | sub TELOPT_NAOVTD () {15}; # Output Vertical Tab Disposition | |
3294 | sub TELOPT_NAOLFD () {16}; # Output Linefeed Disposition | |
3295 | sub TELOPT_XASCII () {17}; # Extended ASCII | |
3296 | sub TELOPT_LOGOUT () {18}; # Logout | |
3297 | sub TELOPT_BM () {19}; # Byte Macro | |
3298 | sub TELOPT_DET () {20}; # Data Entry Terminal | |
3299 | sub TELOPT_SUPDUP () {21}; # SUPDUP | |
3300 | sub TELOPT_SUPDUPOUTPUT () {22}; # SUPDUP Output | |
3301 | sub TELOPT_SNDLOC () {23}; # Send Location | |
3302 | sub TELOPT_TTYPE () {24}; # Terminal Type | |
3303 | sub TELOPT_EOR () {25}; # End of Record | |
3304 | sub TELOPT_TUID () {26}; # TACACS User Identification | |
3305 | sub TELOPT_OUTMRK () {27}; # Output Marking | |
3306 | sub TELOPT_TTYLOC () {28}; # Terminal Location Number | |
3307 | sub TELOPT_3270REGIME () {29}; # Telnet 3270 Regime | |
3308 | sub TELOPT_X3PAD () {30}; # X.3 PAD | |
3309 | sub TELOPT_NAWS () {31}; # Negotiate About Window Size | |
3310 | sub TELOPT_TSPEED () {32}; # Terminal Speed | |
3311 | sub TELOPT_LFLOW () {33}; # Remote Flow Control | |
3312 | sub TELOPT_LINEMODE () {34}; # Linemode | |
3313 | sub TELOPT_XDISPLOC () {35}; # X Display Location | |
3314 | sub TELOPT_OLD_ENVIRON () {36}; # Environment Option | |
3315 | sub TELOPT_AUTHENTICATION () {37}; # Authentication Option | |
3316 | sub TELOPT_ENCRYPT () {38}; # Encryption Option | |
3317 | sub TELOPT_NEW_ENVIRON () {39}; # New Environment Option | |
3318 | sub TELOPT_EXOPL () {255}; # Extended-Options-List | |
3319 | ||
3320 | ||
3321 | 1; | |
3322 | __END__; | |
3323 | ||
3324 | ||
3325 | ######################## User Documentation ########################## | |
3326 | ||
3327 | ||
3328 | ## To format the following documentation into a more readable format, | |
3329 | ## use one of these programs: perldoc; pod2man; pod2html; pod2text. | |
3330 | ## For example, to nicely format this documentation for printing, you | |
3331 | ## may use pod2man and groff to convert to postscript: | |
3332 | ## pod2man Net/Telnet.pm | groff -man -Tps > Net::Telnet.ps | |
3333 | ||
3334 | =head1 NAME | |
3335 | ||
3336 | Net::Telnet - interact with TELNET port or other TCP ports | |
3337 | ||
3338 | =head1 SYNOPSIS | |
3339 | ||
3340 | C<use Net::Telnet ();> | |
3341 | ||
3342 | see METHODS section below | |
3343 | ||
3344 | =head1 DESCRIPTION | |
3345 | ||
3346 | Net::Telnet allows you to make client connections to a TCP port and do | |
3347 | network I/O, especially to a port using the TELNET protocol. Simple | |
3348 | I/O methods such as print, get, and getline are provided. More | |
3349 | sophisticated interactive features are provided because connecting to | |
3350 | a TELNET port ultimately means communicating with a program designed | |
3351 | for human interaction. These interactive features include the ability | |
3352 | to specify a time-out and to wait for patterns to appear in the input | |
3353 | stream, such as the prompt from a shell. | |
3354 | ||
3355 | Other reasons to use this module than strictly with a TELNET port are: | |
3356 | ||
3357 | =over 2 | |
3358 | ||
3359 | =item * | |
3360 | ||
3361 | You're not familiar with sockets and you want a simple way to make | |
3362 | client connections to TCP services. | |
3363 | ||
3364 | =item * | |
3365 | ||
3366 | You want to be able to specify your own time-out while connecting, | |
3367 | reading, or writing. | |
3368 | ||
3369 | =item * | |
3370 | ||
3371 | You're communicating with an interactive program at the other end of | |
3372 | some socket or pipe and you want to wait for certain patterns to | |
3373 | appear. | |
3374 | ||
3375 | =back | |
3376 | ||
3377 | Here's an example that prints who's logged-on to the remote host | |
3378 | sparky. In addition to a username and password, you must also know | |
3379 | the user's shell prompt, which for this example is C<bash$> | |
3380 | ||
3381 | use Net::Telnet (); | |
3382 | $t = new Net::Telnet (Timeout => 10, | |
3383 | Prompt => '/bash\$ $/'); | |
3384 | $t->open("sparky"); | |
3385 | $t->login($username, $passwd); | |
3386 | @lines = $t->cmd("who"); | |
3387 | print @lines; | |
3388 | ||
3389 | More examples are in the B<EXAMPLES> section below. | |
3390 | ||
3391 | Usage questions should be directed to the Usenet newsgroup | |
3392 | comp.lang.perl.modules. | |
3393 | ||
3394 | Contact me, Jay Rogers <jay@rgrs.com>, if you find any bugs or have | |
3395 | suggestions for improvement. | |
3396 | ||
3397 | =head2 What To Know Before Using | |
3398 | ||
3399 | =over 2 | |
3400 | ||
3401 | =item * | |
3402 | ||
3403 | All output is flushed while all input is buffered. Each object | |
3404 | contains its own input buffer. | |
3405 | ||
3406 | =item * | |
3407 | ||
3408 | The output record separator for C<print()> and C<cmd()> is set to | |
3409 | C<"\n"> by default, so that you don't have to append all your commands | |
3410 | with a newline. To avoid printing a trailing C<"\n"> use C<put()> or | |
3411 | set the I<output_record_separator> to C<"">. | |
3412 | ||
3413 | =item * | |
3414 | ||
3415 | The methods C<login()> and C<cmd()> use the I<prompt> setting in the | |
3416 | object to determine when a login or remote command is complete. Those | |
3417 | methods will fail with a time-out if you don't set the prompt | |
3418 | correctly. | |
3419 | ||
3420 | =item * | |
3421 | ||
3422 | Use a combination of C<print()> and C<waitfor()> as an alternative to | |
3423 | C<login()> or C<cmd()> when they don't do what you want. | |
3424 | ||
3425 | =item * | |
3426 | ||
3427 | Errors such as timing-out are handled according to the error mode | |
3428 | action. The default action is to print an error message to standard | |
3429 | error and have the program die. See the C<errmode()> method for more | |
3430 | information. | |
3431 | ||
3432 | =item * | |
3433 | ||
3434 | When constructing the match operator argument for C<prompt()> or | |
3435 | C<waitfor()>, always use single quotes instead of double quotes to | |
3436 | avoid unexpected backslash interpretation (e.g. C<'/bash\$ $/'>). If | |
3437 | you're constructing a DOS like file path, you'll need to use four | |
3438 | backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>). | |
3439 | ||
3440 | Of course don't forget about regexp metacharacters like C<.>, C<[>, or | |
3441 | C<$>. You'll only need a single backslash to quote them. The anchor | |
3442 | metacharacters C<^> and C<$> refer to positions in the input buffer. | |
3443 | To avoid matching characters read that look like a prompt, it's a good | |
3444 | idea to end your prompt pattern with the C<$> anchor. That way the | |
3445 | prompt will only match if it's the last thing read. | |
3446 | ||
3447 | =item * | |
3448 | ||
3449 | In the input stream, each sequence of I<carriage return> and I<line | |
3450 | feed> (i.e. C<"\015\012"> or CR LF) is converted to C<"\n">. In the | |
3451 | output stream, each occurrence of C<"\n"> is converted to a sequence | |
3452 | of CR LF. See C<binmode()> to change the behavior. TCP protocols | |
3453 | typically use the ASCII sequence, carriage return and line feed to | |
3454 | designate a newline. | |
3455 | ||
3456 | =item * | |
3457 | ||
3458 | Timing-out while making a connection is disabled for machines that | |
3459 | don't support the C<alarm()> function. Most notably these include | |
3460 | MS-Windows machines. | |
3461 | ||
3462 | =item * | |
3463 | ||
3464 | You'll need to be running at least Perl version 5.002 to use this | |
3465 | module. This module does not require any libraries that don't already | |
3466 | come with a standard Perl distribution. | |
3467 | ||
3468 | If you have the IO:: libraries installed (they come standard with | |
3469 | perl5.004 and later) then IO::Socket::INET is used as a base class, | |
3470 | otherwise FileHandle is used. | |
3471 | ||
3472 | =item * | |
3473 | ||
3474 | Contact me, Jay Rogers <jay@rgrs.com>, if you find any bugs or have | |
3475 | suggestions for improvement. | |
3476 | ||
3477 | =back | |
3478 | ||
3479 | =head2 Debugging | |
3480 | ||
3481 | The typical usage bug causes a time-out error because you've made | |
3482 | incorrect assumptions about what the remote side actually sends. The | |
3483 | easiest way to reconcile what the remote side sends with your | |
3484 | expectations is to use C<input_log()> or C<dump_log()>. | |
3485 | ||
3486 | C<dump_log()> allows you to see the data being sent from the remote | |
3487 | side before any translation is done, while C<input_log()> shows you | |
3488 | the results after translation. The translation includes converting | |
3489 | end of line characters, removing and responding to TELNET protocol | |
3490 | commands in the data stream. | |
3491 | ||
3492 | =head2 Style of Named Parameters | |
3493 | ||
3494 | Two different styles of named parameters are supported. This document | |
3495 | only shows the IO:: style: | |
3496 | ||
3497 | Net::Telnet->new(Timeout => 20); | |
3498 | ||
3499 | however the dash-option style is also allowed: | |
3500 | ||
3501 | Net::Telnet->new(-timeout => 20); | |
3502 | ||
3503 | =head2 Connecting to a Remote MS-Windows Machine | |
3504 | ||
3505 | By default MS-Windows doesn't come with a TELNET server. However | |
3506 | third party TELNET servers are available. Unfortunately many of these | |
3507 | servers falsely claim to be a TELNET server. This is especially true | |
3508 | of the so-called "Microsoft Telnet Server" that comes installed with | |
3509 | some newer versions MS-Windows. | |
3510 | ||
3511 | When a TELNET server first accepts a connection, it must use the ASCII | |
3512 | control characters carriage-return and line-feed to start a new line | |
3513 | (see RFC854). A server like the "Microsoft Telnet Server" that | |
3514 | doesn't do this, isn't a TELNET server. These servers send ANSI | |
3515 | terminal escape sequences to position to a column on a subsequent line | |
3516 | and to even position while writing characters that are adjacent to | |
3517 | each other. Worse, when sending output these servers resend | |
3518 | previously sent command output in a misguided attempt to display an | |
3519 | entire terminal screen. | |
3520 | ||
3521 | Connecting Net::Telnet to one of these false TELNET servers makes your | |
3522 | job of parsing command output very difficult. It's better to replace | |
3523 | a false TELNET server with a real TELNET server. The better TELNET | |
3524 | servers for MS-Windows allow you to avoid the ANSI escapes by turning | |
3525 | off something some of them call I<console mode>. | |
3526 | ||
3527 | ||
3528 | =head1 METHODS | |
3529 | ||
3530 | In the calling sequences below, square brackets B<[]> represent | |
3531 | optional parameters. | |
3532 | ||
3533 | =over 4 | |
3534 | ||
3535 | =item B<new> - create a new Net::Telnet object | |
3536 | ||
3537 | $obj = new Net::Telnet ([$host]); | |
3538 | ||
3539 | $obj = new Net::Telnet ([Binmode => $mode,] | |
3540 | [Cmd_remove_mode => $mode,] | |
3541 | [Dump_Log => $filename,] | |
3542 | [Errmode => $errmode,] | |
3543 | [Fhopen => $filehandle,] | |
3544 | [Host => $host,] | |
3545 | [Input_log => $file,] | |
3546 | [Input_record_separator => $chars,] | |
3547 | [Option_log => $file,] | |
3548 | [Ors => $chars,] | |
3549 | [Output_log => $file,] | |
3550 | [Output_record_separator => $chars,] | |
3551 | [Port => $port,] | |
3552 | [Prompt => $matchop,] | |
3553 | [Rs => $chars,] | |
3554 | [Telnetmode => $mode,] | |
3555 | [Timeout => $secs,]); | |
3556 | ||
3557 | This is the constructor for Net::Telnet objects. A new object is | |
3558 | returned on success, the error mode action is performed on failure - | |
3559 | see C<errmode()>. The optional arguments are short-cuts to methods of | |
3560 | the same name. | |
3561 | ||
3562 | If the I<$host> argument is given then the object is opened by | |
3563 | connecting to TCP I<$port> on I<$host>. Also see C<open()>. The new | |
3564 | object returned is given the following defaults in the absence of | |
3565 | corresponding named parameters: | |
3566 | ||
3567 | =over 4 | |
3568 | ||
3569 | =item | |
3570 | ||
3571 | The default I<Host> is C<"localhost"> | |
3572 | ||
3573 | =item | |
3574 | ||
3575 | The default I<Port> is C<23> | |
3576 | ||
3577 | =item | |
3578 | ||
3579 | The default I<Prompt> is C<'/[\$%#E<gt>] $/'> | |
3580 | ||
3581 | =item | |
3582 | ||
3583 | The default I<Timeout> is C<10> | |
3584 | ||
3585 | =item | |
3586 | ||
3587 | The default I<Errmode> is C<"die"> | |
3588 | ||
3589 | =item | |
3590 | ||
3591 | The default I<Output_record_separator> is C<"\n">. Note that I<Ors> | |
3592 | is synonymous with I<Output_record_separator>. | |
3593 | ||
3594 | =item | |
3595 | ||
3596 | The default I<Input_record_separator> is C<"\n">. Note that I<Rs> is | |
3597 | synonymous with I<Input_record_separator>. | |
3598 | ||
3599 | =item | |
3600 | ||
3601 | The default I<Binmode> is C<0>, which means do newline translation. | |
3602 | ||
3603 | =item | |
3604 | ||
3605 | The default I<Telnetmode> is C<1>, which means respond to TELNET | |
3606 | commands in the data stream. | |
3607 | ||
3608 | =item | |
3609 | ||
3610 | The default I<Cmd_remove_mode> is C<"auto"> | |
3611 | ||
3612 | =item | |
3613 | ||
3614 | The defaults for I<Dump_log>, I<Input_log>, I<Option_log>, and | |
3615 | I<Output_log> are C<"">, which means that logging is turned-off. | |
3616 | ||
3617 | =back | |
3618 | ||
3619 | =back | |
3620 | ||
3621 | ||
3622 | =over 4 | |
3623 | ||
3624 | =item B<binmode> - toggle newline translation | |
3625 | ||
3626 | $mode = $obj->binmode; | |
3627 | ||
3628 | $prev = $obj->binmode($mode); | |
3629 | ||
3630 | This method controls whether or not sequences of carriage returns and | |
3631 | line feeds (CR LF or more specifically C<"\015\012">) are translated. | |
3632 | By default they are translated (i.e. binmode is C<0>). | |
3633 | ||
3634 | If no argument is given, the current mode is returned. | |
3635 | ||
3636 | If I<$mode> is C<1> then binmode is I<on> and newline translation is | |
3637 | not done. | |
3638 | ||
3639 | If I<$mode> is C<0> then binmode is I<off> and newline translation is | |
3640 | done. In the input stream, each sequence of CR LF is converted to | |
3641 | C<"\n"> and in the output stream, each occurrence of C<"\n"> is | |
3642 | converted to a sequence of CR LF. | |
3643 | ||
3644 | Note that input is always buffered. Changing binmode doesn't effect | |
3645 | what's already been read into the buffer. Output is not buffered and | |
3646 | changing binmode will have an immediate effect. | |
3647 | ||
3648 | =back | |
3649 | ||
3650 | ||
3651 | =over 4 | |
3652 | ||
3653 | =item B<break> - send TELNET break character | |
3654 | ||
3655 | $ok = $obj->break; | |
3656 | ||
3657 | This method sends the TELNET break character. This character is | |
3658 | provided because it's a signal outside the ASCII character set which | |
3659 | is currently given local meaning within many systems. It's intended | |
3660 | to indicate that the Break Key or the Attention Key was hit. | |
3661 | ||
3662 | This method returns C<1> on success, or performs the error mode action | |
3663 | on failure. | |
3664 | ||
3665 | =back | |
3666 | ||
3667 | ||
3668 | =over 4 | |
3669 | ||
3670 | =item B<buffer> - scalar reference to object's input buffer | |
3671 | ||
3672 | $ref = $obj->buffer; | |
3673 | ||
3674 | This method returns a scalar reference to the input buffer for | |
3675 | I<$obj>. Data in the input buffer is data that has been read from the | |
3676 | remote side but has yet to be read by the user. Modifications to the | |
3677 | input buffer are returned by a subsequent read. | |
3678 | ||
3679 | =back | |
3680 | ||
3681 | ||
3682 | =over 4 | |
3683 | ||
3684 | =item B<buffer_empty> - discard all data in object's input buffer | |
3685 | ||
3686 | $obj->buffer_empty; | |
3687 | ||
3688 | This method removes all data in the input buffer for I<$obj>. | |
3689 | ||
3690 | =back | |
3691 | ||
3692 | ||
3693 | =over 4 | |
3694 | ||
3695 | =item B<close> - close object | |
3696 | ||
3697 | $ok = $obj->close; | |
3698 | ||
3699 | This method closes the socket, file, or pipe associated with the | |
3700 | object. It always returns a value of C<1>. | |
3701 | ||
3702 | =back | |
3703 | ||
3704 | ||
3705 | =over 4 | |
3706 | ||
3707 | =item B<cmd> - issue command and retrieve output | |
3708 | ||
3709 | $ok = $obj->cmd($string); | |
3710 | $ok = $obj->cmd(String => $string, | |
3711 | [Output => $ref,] | |
3712 | [Cmd_remove_mode => $mode,] | |
3713 | [Errmode => $mode,] | |
3714 | [Input_record_separator => $chars,] | |
3715 | [Ors => $chars,] | |
3716 | [Output_record_separator => $chars,] | |
3717 | [Prompt => $match,] | |
3718 | [Rs => $chars,] | |
3719 | [Timeout => $secs,]); | |
3720 | ||
3721 | @output = $obj->cmd($string); | |
3722 | @output = $obj->cmd(String => $string, | |
3723 | [Output => $ref,] | |
3724 | [Cmd_remove_mode => $mode,] | |
3725 | [Errmode => $mode,] | |
3726 | [Input_record_separator => $chars,] | |
3727 | [Ors => $chars,] | |
3728 | [Output_record_separator => $chars,] | |
3729 | [Prompt => $match,] | |
3730 | [Rs => $chars,] | |
3731 | [Timeout => $secs,]); | |
3732 | ||
3733 | This method sends the command I<$string>, and reads the characters | |
3734 | sent back by the command up until and including the matching prompt. | |
3735 | It's assumed that the program to which you're sending is some kind of | |
3736 | command prompting interpreter such as a shell. | |
3737 | ||
3738 | The command I<$string> is automatically appended with the | |
3739 | output_record_separator, By default that's C<"\n">. This is similar | |
3740 | to someone typing a command and hitting the return key. Set the | |
3741 | output_record_separator to change this behavior. | |
3742 | ||
3743 | In a scalar context, the characters read from the remote side are | |
3744 | discarded and C<1> is returned on success. On time-out, eof, or other | |
3745 | failures, the error mode action is performed. See C<errmode()>. | |
3746 | ||
3747 | In a list context, just the output generated by the command is | |
3748 | returned, one line per element. In other words, all the characters in | |
3749 | between the echoed back command string and the prompt are returned. | |
3750 | If the command happens to return no output, a list containing one | |
3751 | element, the empty string is returned. This is so the list will | |
3752 | indicate true in a boolean context. On time-out, eof, or other | |
3753 | failures, the error mode action is performed. See C<errmode()>. | |
3754 | ||
3755 | The characters that matched the prompt may be retrieved using | |
3756 | C<last_prompt()>. | |
3757 | ||
3758 | Many command interpreters echo back the command sent. In most | |
3759 | situations, this method removes the first line returned from the | |
3760 | remote side (i.e. the echoed back command). See C<cmd_remove_mode()> | |
3761 | for more control over this feature. | |
3762 | ||
3763 | Use C<dump_log()> to debug when this method keeps timing-out and you | |
3764 | don't think it should. | |
3765 | ||
3766 | Consider using a combination of C<print()> and C<waitfor()> as an | |
3767 | alternative to this method when it doesn't do what you want, e.g. the | |
3768 | command you send prompts for input. | |
3769 | ||
3770 | The I<Output> named parameter provides an alternative method of | |
3771 | receiving command output. If you pass a scalar reference, all the | |
3772 | output (even if it contains multiple lines) is returned in the | |
3773 | referenced scalar. If you pass an array or hash reference, the lines | |
3774 | of output are returned in the referenced array or hash. You can use | |
3775 | C<input_record_separator()> to change the notion of what separates a | |
3776 | line. | |
3777 | ||
3778 | Optional named parameters are provided to override the current | |
3779 | settings of cmd_remove_mode, errmode, input_record_separator, ors, | |
3780 | output_record_separator, prompt, rs, and timeout. Rs is synonymous | |
3781 | with input_record_separator and ors is synonymous with | |
3782 | output_record_separator. | |
3783 | ||
3784 | =back | |
3785 | ||
3786 | ||
3787 | =over 4 | |
3788 | ||
3789 | =item B<cmd_remove_mode> - toggle removal of echoed commands | |
3790 | ||
3791 | $mode = $obj->cmd_remove_mode; | |
3792 | ||
3793 | $prev = $obj->cmd_remove_mode($mode); | |
3794 | ||
3795 | This method controls how to deal with echoed back commands in the | |
3796 | output returned by cmd(). Typically, when you send a command to the | |
3797 | remote side, the first line of output returned is the command echoed | |
3798 | back. Use this mode to remove the first line of output normally | |
3799 | returned by cmd(). | |
3800 | ||
3801 | If no argument is given, the current mode is returned. | |
3802 | ||
3803 | If I<$mode> is C<0> then the command output returned from cmd() has no | |
3804 | lines removed. If I<$mode> is a positive integer, then the first | |
3805 | I<$mode> lines of command output are stripped. | |
3806 | ||
3807 | By default, I<$mode> is set to C<"auto">. Auto means that whether or | |
3808 | not the first line of command output is stripped, depends on whether | |
3809 | or not the remote side offered to echo. By default, Net::Telnet | |
3810 | always accepts an offer to echo by the remote side. You can change | |
3811 | the default to reject such an offer using C<option_accept()>. | |
3812 | ||
3813 | A warning is printed to STDERR when attempting to set this attribute | |
3814 | to something that's not C<"auto"> or a non-negative integer. | |
3815 | ||
3816 | =back | |
3817 | ||
3818 | ||
3819 | =over 4 | |
3820 | ||
3821 | =item B<dump_log> - log all I/O in dump format | |
3822 | ||
3823 | $fh = $obj->dump_log; | |
3824 | ||
3825 | $fh = $obj->dump_log($fh); | |
3826 | ||
3827 | $fh = $obj->dump_log($filename); | |
3828 | ||
3829 | This method starts or stops dump format logging of all the object's | |
3830 | input and output. The dump format shows the blocks read and written | |
3831 | in a hexadecimal and printable character format. This method is | |
3832 | useful when debugging, however you might want to first try | |
3833 | C<input_log()> as it's more readable. | |
3834 | ||
3835 | If no argument is given, the current log filehandle is returned. An | |
3836 | empty string indicates logging is off. | |
3837 | ||
3838 | To stop logging, use an empty string as an argument. | |
3839 | ||
3840 | If an open filehandle is given, it is used for logging and returned. | |
3841 | Otherwise, the argument is assumed to be the name of a file, the file | |
3842 | is opened and a filehandle to it is returned. If the file can't be | |
3843 | opened for writing, the error mode action is performed. | |
3844 | ||
3845 | =back | |
3846 | ||
3847 | ||
3848 | =over 4 | |
3849 | ||
3850 | =item B<eof> - end of file indicator | |
3851 | ||
3852 | $eof = $obj->eof; | |
3853 | ||
3854 | This method returns C<1> if end of file has been read, otherwise it | |
3855 | returns an empty string. Because the input is buffered this isn't the | |
3856 | same thing as I<$obj> has closed. In other words I<$obj> can be | |
3857 | closed but there still can be stuff in the buffer to be read. Under | |
3858 | this condition you can still read but you won't be able to write. | |
3859 | ||
3860 | =back | |
3861 | ||
3862 | ||
3863 | =over 4 | |
3864 | ||
3865 | =item B<errmode> - define action to be performed on error | |
3866 | ||
3867 | $mode = $obj->errmode; | |
3868 | ||
3869 | $prev = $obj->errmode($mode); | |
3870 | ||
3871 | This method gets or sets the action used when errors are encountered | |
3872 | using the object. The first calling sequence returns the current | |
3873 | error mode. The second calling sequence sets it to I<$mode> and | |
3874 | returns the previous mode. Valid values for I<$mode> are C<"die"> | |
3875 | (the default), C<"return">, a I<coderef>, or an I<arrayref>. | |
3876 | ||
3877 | When mode is C<"die"> and an error is encountered using the object, | |
3878 | then an error message is printed to standard error and the program | |
3879 | dies. | |
3880 | ||
3881 | When mode is C<"return"> then the method generating the error places | |
3882 | an error message in the object and returns an undefined value in a | |
3883 | scalar context and an empty list in list context. The error message | |
3884 | may be obtained using C<errmsg()>. | |
3885 | ||
3886 | When mode is a I<coderef>, then when an error is encountered | |
3887 | I<coderef> is called with the error message as its first argument. | |
3888 | Using this mode you may have your own subroutine handle errors. If | |
3889 | I<coderef> itself returns then the method generating the error returns | |
3890 | undefined or an empty list depending on context. | |
3891 | ||
3892 | When mode is an I<arrayref>, the first element of the array must be a | |
3893 | I<coderef>. Any elements that follow are the arguments to I<coderef>. | |
3894 | When an error is encountered, the I<coderef> is called with its | |
3895 | arguments. Using this mode you may have your own subroutine handle | |
3896 | errors. If the I<coderef> itself returns then the method generating | |
3897 | the error returns undefined or an empty list depending on context. | |
3898 | ||
3899 | A warning is printed to STDERR when attempting to set this attribute | |
3900 | to something that's not C<"die">, C<"return">, a I<coderef>, or an | |
3901 | I<arrayref> whose first element isn't a I<coderef>. | |
3902 | ||
3903 | =back | |
3904 | ||
3905 | ||
3906 | =over 4 | |
3907 | ||
3908 | =item B<errmsg> - most recent error message | |
3909 | ||
3910 | $msg = $obj->errmsg; | |
3911 | ||
3912 | $prev = $obj->errmsg(@msgs); | |
3913 | ||
3914 | The first calling sequence returns the error message associated with | |
3915 | the object. The empty string is returned if no error has been | |
3916 | encountered yet. The second calling sequence sets the error message | |
3917 | for the object to the concatenation of I<@msgs> and returns the | |
3918 | previous error message. Normally, error messages are set internally | |
3919 | by a method when an error is encountered. | |
3920 | ||
3921 | =back | |
3922 | ||
3923 | ||
3924 | =over 4 | |
3925 | ||
3926 | =item B<error> - perform the error mode action | |
3927 | ||
3928 | $obj->error(@msgs); | |
3929 | ||
3930 | This method concatenates I<@msgs> into a string and places it in the | |
3931 | object as the error message. Also see C<errmsg()>. It then performs | |
3932 | the error mode action. Also see C<errmode()>. | |
3933 | ||
3934 | If the error mode doesn't cause the program to die, then an undefined | |
3935 | value or an empty list is returned depending on the context. | |
3936 | ||
3937 | This method is primarily used by this class or a sub-class to perform | |
3938 | the user requested action when an error is encountered. | |
3939 | ||
3940 | =back | |
3941 | ||
3942 | ||
3943 | =over 4 | |
3944 | ||
3945 | =item B<fhopen> - use already open filehandle for I/O | |
3946 | ||
3947 | $ok = $obj->fhopen($fh); | |
3948 | ||
3949 | This method associates the open filehandle I<$fh> with I<$obj> for | |
3950 | further I/O. Filehandle I<$fh> must already be opened. | |
3951 | ||
3952 | Suppose you want to use the features of this module to do I/O to | |
3953 | something other than a TCP port, for example STDIN or a filehandle | |
3954 | opened to read from a process. Instead of opening the object for I/O | |
3955 | to a TCP port by using C<open()> or C<new()>, call this method | |
3956 | instead. | |
3957 | ||
3958 | The value C<1> is returned success, the error mode action is performed | |
3959 | on failure. | |
3960 | ||
3961 | =back | |
3962 | ||
3963 | ||
3964 | =over 4 | |
3965 | ||
3966 | =item B<get> - read block of data | |
3967 | ||
3968 | $data = $obj->get([Binmode => $mode,] | |
3969 | [Errmode => $errmode,] | |
3970 | [Telnetmode => $mode,] | |
3971 | [Timeout => $secs,]); | |
3972 | ||
3973 | This method reads a block of data from the object and returns it along | |
3974 | with any buffered data. If no buffered data is available to return, | |
3975 | it will wait for data to read using the timeout specified in the | |
3976 | object. You can override that timeout using I<$secs>. Also see | |
3977 | C<timeout()>. If buffered data is available to return, it also checks | |
3978 | for a block of data that can be immediately read. | |
3979 | ||
3980 | On eof an undefined value is returned. On time-out or other failures, | |
3981 | the error mode action is performed. To distinguish between eof or an | |
3982 | error occurring when the error mode is not set to C<"die">, use | |
3983 | C<eof()>. | |
3984 | ||
3985 | Optional named parameters are provided to override the current | |
3986 | settings of binmode, errmode, telnetmode, and timeout. | |
3987 | ||
3988 | =back | |
3989 | ||
3990 | ||
3991 | =over 4 | |
3992 | ||
3993 | =item B<getline> - read next line | |
3994 | ||
3995 | $line = $obj->getline([Binmode => $mode,] | |
3996 | [Errmode => $errmode,] | |
3997 | [Input_record_separator => $chars,] | |
3998 | [Rs => $chars,] | |
3999 | [Telnetmode => $mode,] | |
4000 | [Timeout => $secs,]); | |
4001 | ||
4002 | This method reads and returns the next line of data from the object. | |
4003 | You can use C<input_record_separator()> to change the notion of what | |
4004 | separates a line. The default is C<"\n">. If a line isn't | |
4005 | immediately available, this method blocks waiting for a line or a | |
4006 | time-out. | |
4007 | ||
4008 | On eof an undefined value is returned. On time-out or other failures, | |
4009 | the error mode action is performed. To distinguish between eof or an | |
4010 | error occurring when the error mode is not set to C<"die">, use | |
4011 | C<eof()>. | |
4012 | ||
4013 | Optional named parameters are provided to override the current | |
4014 | settings of binmode, errmode, input_record_separator, rs, telnetmode, | |
4015 | and timeout. Rs is synonymous with input_record_separator. | |
4016 | ||
4017 | =back | |
4018 | ||
4019 | ||
4020 | =over 4 | |
4021 | ||
4022 | =item B<getlines> - read next lines | |
4023 | ||
4024 | @lines = $obj->getlines([Binmode => $mode,] | |
4025 | [Errmode => $errmode,] | |
4026 | [Input_record_separator => $chars,] | |
4027 | [Rs => $chars,] | |
4028 | [Telnetmode => $mode,] | |
4029 | [Timeout => $secs,] | |
4030 | [All => $boolean,]); | |
4031 | ||
4032 | This method reads and returns all the lines of data from the object | |
4033 | until end of file is read. You can use C<input_record_separator()> to | |
4034 | change the notion of what separates a line. The default is C<"\n">. | |
4035 | A time-out error occurs if all the lines can't be read within the | |
4036 | time-out interval. See C<timeout()>. | |
4037 | ||
4038 | The behavior of this method was changed in version 3.03. Prior to | |
4039 | version 3.03 this method returned just the lines available from the | |
4040 | next read. To get that old behavior, use the optional named parameter | |
4041 | I<All> and set I<$boolean> to C<""> or C<0>. | |
4042 | ||
4043 | If only eof is read then an empty list is returned. On time-out or | |
4044 | other failures, the error mode action is performed. Use C<eof()> to | |
4045 | distinguish between reading only eof or an error occurring when the | |
4046 | error mode is not set to C<"die">. | |
4047 | ||
4048 | Optional named parameters are provided to override the current | |
4049 | settings of binmode, errmode, input_record_separator, rs, telnetmode, | |
4050 | and timeout. Rs is synonymous with input_record_separator. | |
4051 | ||
4052 | =back | |
4053 | ||
4054 | ||
4055 | =over 4 | |
4056 | ||
4057 | =item B<host> - name of remote host | |
4058 | ||
4059 | $host = $obj->host; | |
4060 | ||
4061 | $prev = $obj->host($host); | |
4062 | ||
4063 | This method designates the remote host for C<open()>. With no | |
4064 | argument it returns the current host name set in the object. With an | |
4065 | argument it sets the current host name to I<$host> and returns the | |
4066 | previous host name. You may indicate the remote host using either a | |
4067 | hostname or an IP address. | |
4068 | ||
4069 | The default value is C<"localhost">. It may also be set by C<open()> | |
4070 | or C<new()>. | |
4071 | ||
4072 | =back | |
4073 | ||
4074 | ||
4075 | =over 4 | |
4076 | ||
4077 | =item B<input_log> - log all input | |
4078 | ||
4079 | $fh = $obj->input_log; | |
4080 | ||
4081 | $fh = $obj->input_log($fh); | |
4082 | ||
4083 | $fh = $obj->input_log($filename); | |
4084 | ||
4085 | This method starts or stops logging of input. This is useful when | |
4086 | debugging. Also see C<dump_log()>. Because most command interpreters | |
4087 | echo back commands received, it's likely all your output will also be | |
4088 | in this log. Note that input logging occurs after newline | |
4089 | translation. See C<binmode()> for details on newline translation. | |
4090 | ||
4091 | If no argument is given, the log filehandle is returned. An empty | |
4092 | string indicates logging is off. | |
4093 | ||
4094 | To stop logging, use an empty string as an argument. | |
4095 | ||
4096 | If an open filehandle is given, it is used for logging and returned. | |
4097 | Otherwise, the argument is assumed to be the name of a file, the file | |
4098 | is opened for logging and a filehandle to it is returned. If the file | |
4099 | can't be opened for writing, the error mode action is performed. | |
4100 | ||
4101 | =back | |
4102 | ||
4103 | ||
4104 | =over 4 | |
4105 | ||
4106 | =item B<input_record_separator> - input line delimiter | |
4107 | ||
4108 | $chars = $obj->input_record_separator; | |
4109 | ||
4110 | $prev = $obj->input_record_separator($chars); | |
4111 | ||
4112 | This method designates the line delimiter for input. It's used with | |
4113 | C<getline()>, C<getlines()>, and C<cmd()> to determine lines in the | |
4114 | input. | |
4115 | ||
4116 | With no argument this method returns the current input record | |
4117 | separator set in the object. With an argument it sets the input | |
4118 | record separator to I<$chars> and returns the previous value. Note | |
4119 | that I<$chars> must have length. | |
4120 | ||
4121 | A warning is printed to STDERR when attempting to set this attribute | |
4122 | to a string with no length. | |
4123 | ||
4124 | =back | |
4125 | ||
4126 | ||
4127 | =over 4 | |
4128 | ||
4129 | =item B<last_prompt> - last prompt read | |
4130 | ||
4131 | $string = $obj->last_prompt; | |
4132 | ||
4133 | $prev = $obj->last_prompt($string); | |
4134 | ||
4135 | With no argument this method returns the last prompt read by cmd() or | |
4136 | login(). See C<prompt()>. With an argument it sets the last prompt | |
4137 | read to I<$string> and returns the previous value. Normally, only | |
4138 | internal methods set the last prompt. | |
4139 | ||
4140 | =back | |
4141 | ||
4142 | ||
4143 | =over 4 | |
4144 | ||
4145 | =item B<lastline> - last line read | |
4146 | ||
4147 | $line = $obj->lastline; | |
4148 | ||
4149 | $prev = $obj->lastline($line); | |
4150 | ||
4151 | This method retrieves the last line read from the object. This may be | |
4152 | a useful error message when the remote side abnormally closes the | |
4153 | connection. Typically the remote side will print an error message | |
4154 | before closing. | |
4155 | ||
4156 | With no argument this method returns the last line read from the | |
4157 | object. With an argument it sets the last line read to I<$line> and | |
4158 | returns the previous value. Normally, only internal methods set the | |
4159 | last line. | |
4160 | ||
4161 | =back | |
4162 | ||
4163 | ||
4164 | =over 4 | |
4165 | ||
4166 | =item B<login> - perform standard login | |
4167 | ||
4168 | $ok = $obj->login($username, $password); | |
4169 | ||
4170 | $ok = $obj->login(Name => $username, | |
4171 | Password => $password, | |
4172 | [Errmode => $mode,] | |
4173 | [Prompt => $match,] | |
4174 | [Timeout => $secs,]); | |
4175 | ||
4176 | This method performs a standard login by waiting for a login prompt | |
4177 | and responding with I<$username>, then waiting for the password prompt | |
4178 | and responding with I<$password>, and then waiting for the command | |
4179 | interpreter prompt. If any of those prompts sent by the remote side | |
4180 | don't match what's expected, this method will time-out, unless timeout | |
4181 | is turned off. | |
4182 | ||
4183 | Login prompt must match either of these case insensitive patterns: | |
4184 | ||
4185 | /login[: ]*$/i | |
4186 | /username[: ]*$/i | |
4187 | ||
4188 | Password prompt must match this case insensitive pattern: | |
4189 | ||
4190 | /password[: ]*$/i | |
4191 | ||
4192 | The command interpreter prompt must match the current setting of | |
4193 | prompt. See C<prompt()>. | |
4194 | ||
4195 | Use C<dump_log()> to debug when this method keeps timing-out and you | |
4196 | don't think it should. | |
4197 | ||
4198 | Consider using a combination of C<print()> and C<waitfor()> as an | |
4199 | alternative to this method when it doesn't do what you want, e.g. the | |
4200 | remote host doesn't prompt for a username. | |
4201 | ||
4202 | On success, C<1> is returned. On time out, eof, or other failures, | |
4203 | the error mode action is performed. See C<errmode()>. | |
4204 | ||
4205 | Optional named parameters are provided to override the current | |
4206 | settings of errmode, prompt, and timeout. | |
4207 | ||
4208 | =back | |
4209 | ||
4210 | ||
4211 | =over 4 | |
4212 | ||
4213 | =item B<max_buffer_length> - maximum size of input buffer | |
4214 | ||
4215 | $len = $obj->max_buffer_length; | |
4216 | ||
4217 | $prev = $obj->max_buffer_length($len); | |
4218 | ||
4219 | This method designates the maximum size of the input buffer. An error | |
4220 | is generated when a read causes the buffer to exceed this limit. The | |
4221 | default value is 1,048,576 bytes (1MB). The input buffer can grow | |
4222 | much larger than the block size when you continuously read using | |
4223 | C<getline()> or C<waitfor()> and the data stream contains no newlines | |
4224 | or matching waitfor patterns. | |
4225 | ||
4226 | With no argument, this method returns the current maximum buffer | |
4227 | length set in the object. With an argument it sets the maximum buffer | |
4228 | length to I<$len> and returns the previous value. Values of I<$len> | |
4229 | smaller than 512 will be adjusted to 512. | |
4230 | ||
4231 | A warning is printed to STDERR when attempting to set this attribute | |
4232 | to something that isn't a positive integer. | |
4233 | ||
4234 | =back | |
4235 | ||
4236 | ||
4237 | =over 4 | |
4238 | ||
4239 | =item B<ofs> - field separator for print | |
4240 | ||
4241 | $chars = $obj->ofs | |
4242 | ||
4243 | $prev = $obj->ofs($chars); | |
4244 | ||
4245 | This method is synonymous with C<output_field_separator()>. | |
4246 | ||
4247 | =back | |
4248 | ||
4249 | ||
4250 | =over 4 | |
4251 | ||
4252 | =item B<open> - connect to port on remote host | |
4253 | ||
4254 | $ok = $obj->open($host); | |
4255 | ||
4256 | $ok = $obj->open([Host => $host,] | |
4257 | [Port => $port,] | |
4258 | [Errmode => $mode,] | |
4259 | [Timeout => $secs,]); | |
4260 | ||
4261 | This method opens a TCP connection to I<$port> on I<$host>. If either | |
4262 | argument is missing then the current value of C<host()> or C<port()> | |
4263 | is used. Optional named parameters are provided to override the | |
4264 | current setting of errmode and timeout. | |
4265 | ||
4266 | On success C<1> is returned. On time-out or other connection | |
4267 | failures, the error mode action is performed. See C<errmode()>. | |
4268 | ||
4269 | Time-outs don't work for this method on machines that don't implement | |
4270 | SIGALRM - most notably MS-Windows machines. For those machines, an | |
4271 | error is returned when the system reaches its own time-out while | |
4272 | trying to connect. | |
4273 | ||
4274 | A side effect of this method is to reset the alarm interval associated | |
4275 | with SIGALRM. | |
4276 | ||
4277 | =back | |
4278 | ||
4279 | ||
4280 | =over 4 | |
4281 | ||
4282 | =item B<option_accept> - indicate willingness to accept a TELNET option | |
4283 | ||
4284 | $fh = $obj->option_accept([Do => $telopt,] | |
4285 | [Dont => $telopt,] | |
4286 | [Will => $telopt,] | |
4287 | [Wont => $telopt,]); | |
4288 | ||
4289 | This method is used to indicate whether to accept or reject an offer | |
4290 | to enable a TELNET option made by the remote side. If you're using | |
4291 | I<Do> or I<Will> to indicate a willingness to enable, then a | |
4292 | notification callback must have already been defined by a prior call | |
4293 | to C<option_callback()>. See C<option_callback()> for details on | |
4294 | receiving enable/disable notification of a TELNET option. | |
4295 | ||
4296 | You can give multiple I<Do>, I<Dont>, I<Will>, or I<Wont> arguments | |
4297 | for different TELNET options in the same call to this method. | |
4298 | ||
4299 | The following example describes the meaning of the named parameters. | |
4300 | A TELNET option, such as C<TELOPT_ECHO> used below, is an integer | |
4301 | constant that you can import from Net::Telnet. See the source in file | |
4302 | Telnet.pm for the complete list. | |
4303 | ||
4304 | =over 4 | |
4305 | ||
4306 | =item | |
4307 | ||
4308 | I<Do> => C<TELOPT_ECHO> | |
4309 | ||
4310 | =over 4 | |
4311 | ||
4312 | =item | |
4313 | ||
4314 | we'll accept an offer to enable the echo option on the local side | |
4315 | ||
4316 | =back | |
4317 | ||
4318 | =item | |
4319 | ||
4320 | I<Dont> => C<TELOPT_ECHO> | |
4321 | ||
4322 | =over 4 | |
4323 | ||
4324 | =item | |
4325 | ||
4326 | we'll reject an offer to enable the echo option on the local side | |
4327 | ||
4328 | =back | |
4329 | ||
4330 | =item | |
4331 | ||
4332 | I<Will> => C<TELOPT_ECHO> | |
4333 | ||
4334 | =over 4 | |
4335 | ||
4336 | =item | |
4337 | ||
4338 | we'll accept an offer to enable the echo option on the remote side | |
4339 | ||
4340 | =back | |
4341 | ||
4342 | =item | |
4343 | ||
4344 | I<Wont> => C<TELOPT_ECHO> | |
4345 | ||
4346 | =over 4 | |
4347 | ||
4348 | =item | |
4349 | ||
4350 | we'll reject an offer to enable the echo option on the remote side | |
4351 | ||
4352 | =back | |
4353 | ||
4354 | =back | |
4355 | ||
4356 | =item | |
4357 | ||
4358 | Use C<option_send()> to send a request to the remote side to enable or | |
4359 | disable a particular TELNET option. | |
4360 | ||
4361 | =back | |
4362 | ||
4363 | ||
4364 | =over 4 | |
4365 | ||
4366 | =item B<option_callback> - define the option negotiation callback | |
4367 | ||
4368 | $coderef = $obj->option_callback; | |
4369 | ||
4370 | $prev = $obj->option_callback($coderef); | |
4371 | ||
4372 | This method defines the callback subroutine that's called when a | |
4373 | TELNET option is enabled or disabled. Once defined, the | |
4374 | I<option_callback> may not be undefined. However, calling this method | |
4375 | with a different I<$coderef> changes it. | |
4376 | ||
4377 | A warning is printed to STDERR when attempting to set this attribute | |
4378 | to something that isn't a coderef. | |
4379 | ||
4380 | Here are the circumstances that invoke I<$coderef>: | |
4381 | ||
4382 | =over 4 | |
4383 | ||
4384 | =item | |
4385 | ||
4386 | An option becomes enabled because the remote side requested an enable | |
4387 | and C<option_accept()> had been used to arrange that it be accepted. | |
4388 | ||
4389 | =item | |
4390 | ||
4391 | The remote side arbitrarily decides to disable an option that is | |
4392 | currently enabled. Note that Net::Telnet always accepts a request to | |
4393 | disable from the remote side. | |
4394 | ||
4395 | =item | |
4396 | ||
4397 | C<option_send()> was used to send a request to enable or disable an | |
4398 | option and the response from the remote side has just been received. | |
4399 | Note, that if a request to enable is rejected then I<$coderef> is | |
4400 | still invoked even though the option didn't change. | |
4401 | ||
4402 | =back | |
4403 | ||
4404 | =item | |
4405 | ||
4406 | Here are the arguments passed to I<&$coderef>: | |
4407 | ||
4408 | &$coderef($obj, $option, $is_remote, | |
4409 | $is_enabled, $was_enabled, $buf_position); | |
4410 | ||
4411 | =over 4 | |
4412 | ||
4413 | =item | |
4414 | ||
4415 | 1. I<$obj> is the Net::Telnet object | |
4416 | ||
4417 | =item | |
4418 | ||
4419 | 2. I<$option> is the TELNET option. Net::Telnet exports constants | |
4420 | for the various TELNET options which just equate to an integer. | |
4421 | ||
4422 | =item | |
4423 | ||
4424 | 3. I<$is_remote> is a boolean indicating for which side the option | |
4425 | applies. | |
4426 | ||
4427 | =item | |
4428 | ||
4429 | 4. I<$is_enabled> is a boolean indicating the option is enabled or | |
4430 | disabled | |
4431 | ||
4432 | =item | |
4433 | ||
4434 | 5. I<$was_enabled> is a boolean indicating the option was previously | |
4435 | enabled or disabled | |
4436 | ||
4437 | =item | |
4438 | ||
4439 | 6. I<$buf_position> is an integer indicating the position in the | |
4440 | object's input buffer where the option takes effect. See C<buffer()> | |
4441 | to access the object's input buffer. | |
4442 | ||
4443 | =back | |
4444 | ||
4445 | =back | |
4446 | ||
4447 | ||
4448 | =over 4 | |
4449 | ||
4450 | =item B<option_log> - log all TELNET options sent or received | |
4451 | ||
4452 | $fh = $obj->option_log; | |
4453 | ||
4454 | $fh = $obj->option_log($fh); | |
4455 | ||
4456 | $fh = $obj->option_log($filename); | |
4457 | ||
4458 | This method starts or stops logging of all TELNET options being sent | |
4459 | or received. This is useful for debugging when you send options via | |
4460 | C<option_send()> or you arrange to accept option requests from the | |
4461 | remote side via C<option_accept()>. Also see C<dump_log()>. | |
4462 | ||
4463 | If no argument is given, the log filehandle is returned. An empty | |
4464 | string indicates logging is off. | |
4465 | ||
4466 | To stop logging, use an empty string as an argument. | |
4467 | ||
4468 | If an open filehandle is given, it is used for logging and returned. | |
4469 | Otherwise, the argument is assumed to be the name of a file, the file | |
4470 | is opened for logging and a filehandle to it is returned. If the file | |
4471 | can't be opened for writing, the error mode action is performed. | |
4472 | ||
4473 | =back | |
4474 | ||
4475 | ||
4476 | =over 4 | |
4477 | ||
4478 | =item B<option_send> - send TELNET option negotiation request | |
4479 | ||
4480 | $ok = $obj->option_send([Do => $telopt,] | |
4481 | [Dont => $telopt,] | |
4482 | [Will => $telopt,] | |
4483 | [Wont => $telopt,] | |
4484 | [Async => $boolean,]); | |
4485 | ||
4486 | This method is not yet implemented. Look for it in a future version. | |
4487 | ||
4488 | =back | |
4489 | ||
4490 | ||
4491 | =over 4 | |
4492 | ||
4493 | =item B<option_state> - get current state of a TELNET option | |
4494 | ||
4495 | $hashref = $obj->option_state($telopt); | |
4496 | ||
4497 | This method returns a hashref containing a copy of the current state | |
4498 | of TELNET option I<$telopt>. | |
4499 | ||
4500 | Here are the values returned in the hash: | |
4501 | ||
4502 | =over 4 | |
4503 | ||
4504 | =item | |
4505 | ||
4506 | I<$hashref>->{remote_enabled} | |
4507 | ||
4508 | =over 4 | |
4509 | ||
4510 | =item | |
4511 | ||
4512 | boolean that indicates if the option is enabled on the remote side. | |
4513 | ||
4514 | =back | |
4515 | ||
4516 | =item | |
4517 | ||
4518 | I<$hashref>->{remote_enable_ok} | |
4519 | ||
4520 | =over 4 | |
4521 | ||
4522 | =item | |
4523 | ||
4524 | boolean that indicates if it's ok to accept an offer to enable this | |
4525 | option on the remote side. | |
4526 | ||
4527 | =back | |
4528 | ||
4529 | =item | |
4530 | ||
4531 | I<$hashref>->{remote_state} | |
4532 | ||
4533 | =over 4 | |
4534 | ||
4535 | =item | |
4536 | ||
4537 | string used to hold the internal state of option negotiation for this | |
4538 | option on the remote side. | |
4539 | ||
4540 | =back | |
4541 | ||
4542 | =item | |
4543 | ||
4544 | I<$hashref>->{local_enabled} | |
4545 | ||
4546 | =over 4 | |
4547 | ||
4548 | =item | |
4549 | ||
4550 | boolean that indicates if the option is enabled on the local side. | |
4551 | ||
4552 | =back | |
4553 | ||
4554 | =item | |
4555 | ||
4556 | I<$hashref>->{local_enable_ok} | |
4557 | ||
4558 | =over 4 | |
4559 | ||
4560 | =item | |
4561 | ||
4562 | boolean that indicates if it's ok to accept an offer to enable this | |
4563 | option on the local side. | |
4564 | ||
4565 | =back | |
4566 | ||
4567 | =item | |
4568 | ||
4569 | I<$hashref>->{local_state} | |
4570 | ||
4571 | =over 4 | |
4572 | ||
4573 | =item | |
4574 | ||
4575 | string used to hold the internal state of option negotiation for this | |
4576 | option on the local side. | |
4577 | ||
4578 | =back | |
4579 | ||
4580 | =back | |
4581 | ||
4582 | =back | |
4583 | ||
4584 | ||
4585 | =over 4 | |
4586 | ||
4587 | =item B<ors> - output line delimiter | |
4588 | ||
4589 | $chars = $obj->ors; | |
4590 | ||
4591 | $prev = $obj->ors($chars); | |
4592 | ||
4593 | This method is synonymous with C<output_record_separator()>. | |
4594 | ||
4595 | =back | |
4596 | ||
4597 | ||
4598 | =over 4 | |
4599 | ||
4600 | =item B<output_field_separator> - field separator for print | |
4601 | ||
4602 | $chars = $obj->output_field_separator; | |
4603 | ||
4604 | $prev = $obj->output_field_separator($chars); | |
4605 | ||
4606 | This method designates the output field separator for C<print()>. | |
4607 | Ordinarily the print method simply prints out the comma separated | |
4608 | fields you specify. Set this to specify what's printed between | |
4609 | fields. | |
4610 | ||
4611 | With no argument this method returns the current output field | |
4612 | separator set in the object. With an argument it sets the output | |
4613 | field separator to I<$chars> and returns the previous value. | |
4614 | ||
4615 | By default it's set to an empty string. | |
4616 | ||
4617 | =back | |
4618 | ||
4619 | ||
4620 | =over 4 | |
4621 | ||
4622 | =item B<output_log> - log all output | |
4623 | ||
4624 | $fh = $obj->output_log; | |
4625 | ||
4626 | $fh = $obj->output_log($fh); | |
4627 | ||
4628 | $fh = $obj->output_log($filename); | |
4629 | ||
4630 | This method starts or stops logging of output. This is useful when | |
4631 | debugging. Also see C<dump_log()>. Because most command interpreters | |
4632 | echo back commands received, it's likely all your output would also be | |
4633 | in an input log. See C<input_log()>. Note that output logging occurs | |
4634 | before newline translation. See C<binmode()> for details on newline | |
4635 | translation. | |
4636 | ||
4637 | If no argument is given, the log filehandle is returned. An empty | |
4638 | string indicates logging is off. | |
4639 | ||
4640 | To stop logging, use an empty string as an argument. | |
4641 | ||
4642 | If an open filehandle is given, it is used for logging and returned. | |
4643 | Otherwise, the argument is assumed to be the name of a file, the file | |
4644 | is opened for logging and a filehandle to it is returned. If the file | |
4645 | can't be opened for writing, the error mode action is performed. | |
4646 | ||
4647 | =back | |
4648 | ||
4649 | ||
4650 | =over 4 | |
4651 | ||
4652 | =item B<output_record_separator> - output line delimiter | |
4653 | ||
4654 | $chars = $obj->output_record_separator; | |
4655 | ||
4656 | $prev = $obj->output_record_separator($chars); | |
4657 | ||
4658 | This method designates the output line delimiter for C<print()> and | |
4659 | C<cmd()>. Set this to specify what's printed at the end of C<print()> | |
4660 | and C<cmd()>. | |
4661 | ||
4662 | The output record separator is set to C<"\n"> by default, so there's | |
4663 | no need to append all your commands with a newline. To avoid printing | |
4664 | the output_record_separator use C<put()> or set the | |
4665 | output_record_separator to an empty string. | |
4666 | ||
4667 | With no argument this method returns the current output record | |
4668 | separator set in the object. With an argument it sets the output | |
4669 | record separator to I<$chars> and returns the previous value. | |
4670 | ||
4671 | =back | |
4672 | ||
4673 | ||
4674 | =over 4 | |
4675 | ||
4676 | =item B<port> - remote port | |
4677 | ||
4678 | $port = $obj->port; | |
4679 | ||
4680 | $prev = $obj->port($port); | |
4681 | ||
4682 | This method designates the remote TCP port. With no argument this | |
4683 | method returns the current port number. With an argument it sets the | |
4684 | current port number to I<$port> and returns the previous port. If | |
4685 | I<$port> is a TCP service name, then it's first converted to a port | |
4686 | number using the perl function C<getservbyname()>. | |
4687 | ||
4688 | The default value is C<23>. It may also be set by C<open()> or | |
4689 | C<new()>. | |
4690 | ||
4691 | A warning is printed to STDERR when attempting to set this attribute | |
4692 | to something that's not a positive integer or a valid TCP service | |
4693 | name. | |
4694 | ||
4695 | =back | |
4696 | ||
4697 | ||
4698 | =over 4 | |
4699 | ||
4700 | =item B<print> - write to object | |
4701 | ||
4702 | $ok = $obj->print(@list); | |
4703 | ||
4704 | This method writes I<@list> followed by the I<output_record_separator> | |
4705 | to the open object and returns C<1> if all data was successfully | |
4706 | written. On time-out or other failures, the error mode action is | |
4707 | performed. See C<errmode()>. | |
4708 | ||
4709 | By default, the C<output_record_separator()> is set to C<"\n"> so all | |
4710 | your commands automatically end with a newline. In most cases your | |
4711 | output is being read by a command interpreter which won't accept a | |
4712 | command until newline is read. This is similar to someone typing a | |
4713 | command and hitting the return key. To avoid printing a trailing | |
4714 | C<"\n"> use C<put()> instead or set the output_record_separator to an | |
4715 | empty string. | |
4716 | ||
4717 | On failure, it's possible that some data was written. If you choose | |
4718 | to try and recover from a print timing-out, use C<print_length()> to | |
4719 | determine how much was written before the error occurred. | |
4720 | ||
4721 | You may also use the output field separator to print a string between | |
4722 | the list elements. See C<output_field_separator()>. | |
4723 | ||
4724 | =back | |
4725 | ||
4726 | ||
4727 | =over 4 | |
4728 | ||
4729 | =item B<print_length> - number of bytes written by print | |
4730 | ||
4731 | $num = $obj->print_length; | |
4732 | ||
4733 | This returns the number of bytes successfully written by the most | |
4734 | recent C<print()> or C<put()>. | |
4735 | ||
4736 | =back | |
4737 | ||
4738 | ||
4739 | =over 4 | |
4740 | ||
4741 | =item B<prompt> - pattern to match a prompt | |
4742 | ||
4743 | $matchop = $obj->prompt; | |
4744 | ||
4745 | $prev = $obj->prompt($matchop); | |
4746 | ||
4747 | This method sets the pattern used to find a prompt in the input | |
4748 | stream. It must be a string representing a valid perl pattern match | |
4749 | operator. The methods C<login()> and C<cmd()> try to read until | |
4750 | matching the prompt. They will fail with a time-out error if the | |
4751 | pattern you've chosen doesn't match what the remote side sends. | |
4752 | ||
4753 | With no argument this method returns the prompt set in the object. | |
4754 | With an argument it sets the prompt to I<$matchop> and returns the | |
4755 | previous value. | |
4756 | ||
4757 | The default prompt is C<'/[\$%#E<gt>] $/'> | |
4758 | ||
4759 | Always use single quotes, instead of double quotes, to construct | |
4760 | I<$matchop> (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like | |
4761 | file path, you'll need to use four backslashes to represent one | |
4762 | (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>). | |
4763 | ||
4764 | Of course don't forget about regexp metacharacters like C<.>, C<[>, or | |
4765 | C<$>. You'll only need a single backslash to quote them. The anchor | |
4766 | metacharacters C<^> and C<$> refer to positions in the input buffer. | |
4767 | ||
4768 | A warning is printed to STDERR when attempting to set this attribute | |
4769 | with a match operator missing its opening delimiter. | |
4770 | ||
4771 | =back | |
4772 | ||
4773 | ||
4774 | =over 4 | |
4775 | ||
4776 | =item B<put> - write to object | |
4777 | ||
4778 | $ok = $obj->put($string); | |
4779 | ||
4780 | $ok = $obj->put(String => $string, | |
4781 | [Binmode => $mode,] | |
4782 | [Errmode => $errmode,] | |
4783 | [Telnetmode => $mode,] | |
4784 | [Timeout => $secs,]); | |
4785 | ||
4786 | This method writes I<$string> to the opened object and returns C<1> if | |
4787 | all data was successfully written. This method is like C<print()> | |
4788 | except that it doesn't write the trailing output_record_separator | |
4789 | ("\n" by default). On time-out or other failures, the error mode | |
4790 | action is performed. See C<errmode()>. | |
4791 | ||
4792 | On failure, it's possible that some data was written. If you choose | |
4793 | to try and recover from a put timing-out, use C<print_length()> to | |
4794 | determine how much was written before the error occurred. | |
4795 | ||
4796 | Optional named parameters are provided to override the current | |
4797 | settings of binmode, errmode, telnetmode, and timeout. | |
4798 | ||
4799 | =back | |
4800 | ||
4801 | ||
4802 | =over 4 | |
4803 | ||
4804 | =item B<rs> - input line delimiter | |
4805 | ||
4806 | $chars = $obj->rs; | |
4807 | ||
4808 | $prev = $obj->rs($chars); | |
4809 | ||
4810 | This method is synonymous with C<input_record_separator()>. | |
4811 | ||
4812 | =back | |
4813 | ||
4814 | ||
4815 | =over 4 | |
4816 | ||
4817 | =item B<telnetmode> - turn off/on telnet command interpretation | |
4818 | ||
4819 | $mode = $obj->telnetmode; | |
4820 | ||
4821 | $prev = $obj->telnetmode($mode); | |
4822 | ||
4823 | This method controls whether or not TELNET commands in the data stream | |
4824 | are recognized and handled. The TELNET protocol uses certain | |
4825 | character sequences sent in the data stream to control the session. | |
4826 | If the port you're connecting to isn't using the TELNET protocol, then | |
4827 | you should turn this mode off. The default is I<on>. | |
4828 | ||
4829 | If no argument is given, the current mode is returned. | |
4830 | ||
4831 | If I<$mode> is C<0> then telnet mode is off. If I<$mode> is C<1> then | |
4832 | telnet mode is on. | |
4833 | ||
4834 | =back | |
4835 | ||
4836 | ||
4837 | =over 4 | |
4838 | ||
4839 | =item B<timed_out> - time-out indicator | |
4840 | ||
4841 | $boolean = $obj->timed_out; | |
4842 | ||
4843 | $prev = $obj->timed_out($boolean); | |
4844 | ||
4845 | This method indicates if a previous read, write, or open method | |
4846 | timed-out. Remember that timing-out is itself an error. To be able | |
4847 | to invoke C<timed_out()> after a time-out error, you'd have to change | |
4848 | the default error mode to something other than C<"die">. See | |
4849 | C<errmode()>. | |
4850 | ||
4851 | With no argument this method returns C<1> if the previous method | |
4852 | timed-out. With an argument it sets the indicator. Normally, only | |
4853 | internal methods set this indicator. | |
4854 | ||
4855 | =back | |
4856 | ||
4857 | ||
4858 | =over 4 | |
4859 | ||
4860 | =item B<timeout> - I/O time-out interval | |
4861 | ||
4862 | $secs = $obj->timeout; | |
4863 | ||
4864 | $prev = $obj->timeout($secs); | |
4865 | ||
4866 | This method sets the timeout interval that's used when performing I/O | |
4867 | or connecting to a port. When a method doesn't complete within the | |
4868 | timeout interval then it's an error and the error mode action is | |
4869 | performed. | |
4870 | ||
4871 | A timeout may be expressed as a relative or absolute value. If | |
4872 | I<$secs> is greater than or equal to the time the program started, as | |
4873 | determined by $^T, then it's an absolute time value for when time-out | |
4874 | occurs. The perl function C<time()> may be used to obtain an absolute | |
4875 | time value. For a relative time-out value less than $^T, time-out | |
4876 | happens I<$secs> from when the method begins. | |
4877 | ||
4878 | If I<$secs> is C<0> then time-out occurs if the data cannot be | |
4879 | immediately read or written. Use the undefined value to turn off | |
4880 | timing-out completely. | |
4881 | ||
4882 | With no argument this method returns the timeout set in the object. | |
4883 | With an argument it sets the timeout to I<$secs> and returns the | |
4884 | previous value. The default timeout value is C<10> seconds. | |
4885 | ||
4886 | A warning is printed to STDERR when attempting to set this attribute | |
4887 | to something that's not an C<undef> or a non-negative integer. | |
4888 | ||
4889 | =back | |
4890 | ||
4891 | ||
4892 | =over 4 | |
4893 | ||
4894 | =item B<waitfor> - wait for pattern in the input | |
4895 | ||
4896 | $ok = $obj->waitfor($matchop); | |
4897 | $ok = $obj->waitfor([Match => $matchop,] | |
4898 | [String => $string,] | |
4899 | [Binmode => $mode,] | |
4900 | [Errmode => $errmode,] | |
4901 | [Telnetmode => $mode,] | |
4902 | [Timeout => $secs,]); | |
4903 | ||
4904 | ($prematch, $match) = $obj->waitfor($matchop); | |
4905 | ($prematch, $match) = $obj->waitfor([Match => $matchop,] | |
4906 | [String => $string,] | |
4907 | [Binmode => $mode,] | |
4908 | [Errmode => $errmode,] | |
4909 | [Telnetmode => $mode,] | |
4910 | [Timeout => $secs,]); | |
4911 | ||
4912 | This method reads until a pattern match or string is found in the | |
4913 | input stream. All the characters before and including the match are | |
4914 | removed from the input stream. | |
4915 | ||
4916 | In a list context the characters before the match and the matched | |
4917 | characters are returned in I<$prematch> and I<$match>. In a scalar | |
4918 | context, the matched characters and all characters before it are | |
4919 | discarded and C<1> is returned on success. On time-out, eof, or other | |
4920 | failures, for both list and scalar context, the error mode action is | |
4921 | performed. See C<errmode()>. | |
4922 | ||
4923 | You can specify more than one pattern or string by simply providing | |
4924 | multiple I<Match> and/or I<String> named parameters. A I<$matchop> | |
4925 | must be a string representing a valid Perl pattern match operator. | |
4926 | The I<$string> is just a substring to find in the input stream. | |
4927 | ||
4928 | Use C<dump_log()> to debug when this method keeps timing-out and you | |
4929 | don't think it should. | |
4930 | ||
4931 | An optional named parameter is provided to override the current | |
4932 | setting of timeout. | |
4933 | ||
4934 | To avoid unexpected backslash interpretation, always use single quotes | |
4935 | instead of double quotes to construct a match operator argument for | |
4936 | C<prompt()> and C<waitfor()> (e.g. C<'/bash\$ $/'>). If you're | |
4937 | constructing a DOS like file path, you'll need to use four backslashes | |
4938 | to represent one (e.g. C<'/c:\\\\users\\\\billE<gt>$/i'>). | |
4939 | ||
4940 | Of course don't forget about regexp metacharacters like C<.>, C<[>, or | |
4941 | C<$>. You'll only need a single backslash to quote them. The anchor | |
4942 | metacharacters C<^> and C<$> refer to positions in the input buffer. | |
4943 | ||
4944 | Optional named parameters are provided to override the current | |
4945 | settings of binmode, errmode, telnetmode, and timeout. | |
4946 | ||
4947 | =back | |
4948 | ||
4949 | ||
4950 | =head1 SEE ALSO | |
4951 | ||
4952 | =over 2 | |
4953 | ||
4954 | =item RFC 854 | |
4955 | ||
4956 | S<TELNET Protocol Specification> | |
4957 | ||
4958 | S<ftp://ftp.isi.edu/in-notes/rfc854.txt> | |
4959 | ||
4960 | =item RFC 1143 | |
4961 | ||
4962 | S<Q Method of Implementing TELNET Option Negotiation> | |
4963 | ||
4964 | S<ftp://ftp.isi.edu/in-notes/rfc1143.txt> | |
4965 | ||
4966 | =item TELNET Option Assignments | |
4967 | ||
4968 | S<http://www.iana.org/assignments/telnet-options> | |
4969 | ||
4970 | =back | |
4971 | ||
4972 | ||
4973 | =head1 EXAMPLES | |
4974 | ||
4975 | This example gets the current weather forecast for Brainerd, Minnesota. | |
4976 | ||
4977 | my ($forecast, $t); | |
4978 | ||
4979 | use Net::Telnet (); | |
4980 | $t = new Net::Telnet; | |
4981 | $t->open("rainmaker.wunderground.com"); | |
4982 | ||
4983 | ## Wait for first prompt and "hit return". | |
4984 | $t->waitfor('/continue:.*$/'); | |
4985 | $t->print(""); | |
4986 | ||
4987 | ## Wait for second prompt and respond with city code. | |
4988 | $t->waitfor('/city code.*$/'); | |
4989 | $t->print("BRD"); | |
4990 | ||
4991 | ## Read and print the first page of forecast. | |
4992 | ($forecast) = $t->waitfor('/[ \t]+press return to continue/i'); | |
4993 | print $forecast; | |
4994 | ||
4995 | exit; | |
4996 | ||
4997 | ||
4998 | This example checks a POP server to see if you have mail. | |
4999 | ||
5000 | my ($hostname, $line, $passwd, $pop, $username); | |
5001 | ||
5002 | $hostname = "your_destination_host_here"; | |
5003 | $username = "your_username_here"; | |
5004 | $passwd = "your_password_here"; | |
5005 | ||
5006 | use Net::Telnet (); | |
5007 | $pop = new Net::Telnet (Telnetmode => 0); | |
5008 | $pop->open(Host => $hostname, | |
5009 | Port => 110); | |
5010 | ||
5011 | ||
5012 | ## Read connection message. | |
5013 | $line = $pop->getline; | |
5014 | die $line unless $line =~ /^\+OK/; | |
5015 | ||
5016 | ## Send user name. | |
5017 | $pop->print("user $username"); | |
5018 | $line = $pop->getline; | |
5019 | die $line unless $line =~ /^\+OK/; | |
5020 | ||
5021 | ## Send password. | |
5022 | $pop->print("pass $passwd"); | |
5023 | $line = $pop->getline; | |
5024 | die $line unless $line =~ /^\+OK/; | |
5025 | ||
5026 | ## Request status of messages. | |
5027 | $pop->print("list"); | |
5028 | $line = $pop->getline; | |
5029 | print $line; | |
5030 | ||
5031 | exit; | |
5032 | ||
5033 | ||
5034 | Here's an example that uses the ssh program to connect to a remote | |
5035 | host. Because the ssh program reads and writes to its controlling | |
5036 | terminal, the IO::Pty module is used to create a new pseudo terminal | |
5037 | for use by ssh. A new Net::Telnet object is then created to read and | |
5038 | write to that pseudo terminal. To use the code below, substitute | |
5039 | "changeme" with the actual host, user, password, and command prompt. | |
5040 | ||
5041 | ## Main program. | |
5042 | { | |
5043 | my ($pty, $ssh, @lines); | |
5044 | my $host = "changeme"; | |
5045 | my $user = "changeme"; | |
5046 | my $password = "changeme"; | |
5047 | my $prompt = '/changeme:~> $/'; | |
5048 | ||
5049 | ## Start ssh program. | |
5050 | $pty = &spawn("ssh", "-l", $user, $host); # spawn() defined below | |
5051 | ||
5052 | ## Create a Net::Telnet object to perform I/O on ssh's tty. | |
5053 | use Net::Telnet; | |
5054 | $ssh = new Net::Telnet (-fhopen => $pty, | |
5055 | -prompt => $prompt, | |
5056 | -telnetmode => 0, | |
5057 | -cmd_remove_mode => 1, | |
5058 | -output_record_separator => "\r"); | |
5059 | ||
5060 | ## Login to remote host. | |
5061 | $ssh->waitfor(-match => '/password: ?$/i', | |
5062 | -errmode => "return") | |
5063 | or die "problem connecting to host: ", $ssh->lastline; | |
5064 | $ssh->print($password); | |
5065 | $ssh->waitfor(-match => $ssh->prompt, | |
5066 | -errmode => "return") | |
5067 | or die "login failed: ", $ssh->lastline; | |
5068 | ||
5069 | ## Send command, get and print its output. | |
5070 | @lines = $ssh->cmd("who"); | |
5071 | print @lines; | |
5072 | ||
5073 | exit; | |
5074 | } # end main program | |
5075 | ||
5076 | sub spawn { | |
5077 | my(@cmd) = @_; | |
5078 | my($pid, $pty, $tty, $tty_fd); | |
5079 | ||
5080 | ## Create a new pseudo terminal. | |
5081 | use IO::Pty (); | |
5082 | $pty = new IO::Pty | |
5083 | or die $!; | |
5084 | ||
5085 | ## Execute the program in another process. | |
5086 | unless ($pid = fork) { # child process | |
5087 | die "problem spawning program: $!\n" unless defined $pid; | |
5088 | ||
5089 | ## Disassociate process from existing controlling terminal. | |
5090 | use POSIX (); | |
5091 | POSIX::setsid | |
5092 | or die "setsid failed: $!"; | |
5093 | ||
5094 | ## Associate process with a new controlling terminal. | |
5095 | $tty = $pty->slave; | |
5096 | $tty_fd = $tty->fileno; | |
5097 | close $pty; | |
5098 | ||
5099 | ## Make stdio use the new controlling terminal. | |
5100 | open STDIN, "<&$tty_fd" or die $!; | |
5101 | open STDOUT, ">&$tty_fd" or die $!; | |
5102 | open STDERR, ">&STDOUT" or die $!; | |
5103 | close $tty; | |
5104 | ||
5105 | ## Execute requested program. | |
5106 | exec @cmd | |
5107 | or die "problem executing $cmd[0]\n"; | |
5108 | } # end child process | |
5109 | ||
5110 | $pty; | |
5111 | } # end sub spawn | |
5112 | ||
5113 | ||
5114 | Here's an example that changes a user's login password. Because the | |
5115 | passwd program always prompts for passwords on its controlling | |
5116 | terminal, the IO::Pty module is used to create a new pseudo terminal | |
5117 | for use by passwd. A new Net::Telnet object is then created to read | |
5118 | and write to that pseudo terminal. To use the code below, substitute | |
5119 | "changeme" with the actual old and new passwords. | |
5120 | ||
5121 | my ($pty, $passwd); | |
5122 | my $oldpw = "changeme"; | |
5123 | my $newpw = "changeme"; | |
5124 | ||
5125 | ## Start passwd program. | |
5126 | $pty = &spawn("passwd"); # spawn() defined above | |
5127 | ||
5128 | ## Create a Net::Telnet object to perform I/O on passwd's tty. | |
5129 | use Net::Telnet; | |
5130 | $passwd = new Net::Telnet (-fhopen => $pty, | |
5131 | -timeout => 2, | |
5132 | -output_record_separator => "\r", | |
5133 | -telnetmode => 0, | |
5134 | -cmd_remove_mode => 1); | |
5135 | $passwd->errmode("return"); | |
5136 | ||
5137 | ## Send existing password. | |
5138 | $passwd->waitfor('/password: ?$/i') | |
5139 | or die "no old password prompt: ", $passwd->lastline; | |
5140 | $passwd->print($oldpw); | |
5141 | ||
5142 | ## Send new password. | |
5143 | $passwd->waitfor('/new password: ?$/i') | |
5144 | or die "bad old password: ", $passwd->lastline; | |
5145 | $passwd->print($newpw); | |
5146 | ||
5147 | ## Send new password verification. | |
5148 | $passwd->waitfor('/new password: ?$/i') | |
5149 | or die "bad new password: ", $passwd->lastline; | |
5150 | $passwd->print($newpw); | |
5151 | ||
5152 | ## Display success or failure. | |
5153 | $passwd->waitfor('/changed/') | |
5154 | or die "bad new password: ", $passwd->lastline; | |
5155 | print $passwd->lastline; | |
5156 | ||
5157 | $passwd->close; | |
5158 | exit; | |
5159 | ||
5160 | ||
5161 | Here's an example you can use to down load a file of any type. The | |
5162 | file is read from the remote host's standard output using cat. To | |
5163 | prevent any output processing, the remote host's standard output is | |
5164 | put in raw mode using the Bourne shell. The Bourne shell is used | |
5165 | because some shells, notably tcsh, prevent changing tty modes. Upon | |
5166 | completion, FTP style statistics are printed to stderr. | |
5167 | ||
5168 | my ($block, $filename, $host, $hostname, $k_per_sec, $line, | |
5169 | $num_read, $passwd, $prevblock, $prompt, $size, $size_bsd, | |
5170 | $size_sysv, $start_time, $total_time, $username); | |
5171 | ||
5172 | $hostname = "your_destination_host_here"; | |
5173 | $username = "your_username_here"; | |
5174 | $passwd = "your_password_here"; | |
5175 | $filename = "your_download_file_here"; | |
5176 | ||
5177 | ## Connect and login. | |
5178 | use Net::Telnet (); | |
5179 | $host = new Net::Telnet (Timeout => 30, | |
5180 | Prompt => '/[%#>] $/'); | |
5181 | $host->open($hostname); | |
5182 | $host->login($username, $passwd); | |
5183 | ||
5184 | ## Make sure prompt won't match anything in send data. | |
5185 | $prompt = "_funkyPrompt_"; | |
5186 | $host->prompt("/$prompt\$/"); | |
5187 | $host->cmd("set prompt = '$prompt'"); | |
5188 | ||
5189 | ## Get size of file. | |
5190 | ($line) = $host->cmd("/bin/ls -l $filename"); | |
5191 | ($size_bsd, $size_sysv) = (split ' ', $line)[3,4]; | |
5192 | if ($size_sysv =~ /^\d+$/) { | |
5193 | $size = $size_sysv; | |
5194 | } | |
5195 | elsif ($size_bsd =~ /^\d+$/) { | |
5196 | $size = $size_bsd; | |
5197 | } | |
5198 | else { | |
5199 | die "$filename: no such file on $hostname"; | |
5200 | } | |
5201 | ||
5202 | ## Start sending the file. | |
5203 | binmode STDOUT; | |
5204 | $host->binmode(1); | |
5205 | $host->print("/bin/sh -c 'stty raw; cat $filename'"); | |
5206 | $host->getline; # discard echoed back line | |
5207 | ||
5208 | ## Read file a block at a time. | |
5209 | $num_read = 0; | |
5210 | $prevblock = ""; | |
5211 | $start_time = time; | |
5212 | while (($block = $host->get) and ($block !~ /$prompt$/o)) { | |
5213 | if (length $block >= length $prompt) { | |
5214 | print $prevblock; | |
5215 | $num_read += length $prevblock; | |
5216 | $prevblock = $block; | |
5217 | } | |
5218 | else { | |
5219 | $prevblock .= $block; | |
5220 | } | |
5221 | ||
5222 | } | |
5223 | $host->close; | |
5224 | ||
5225 | ## Print last block without trailing prompt. | |
5226 | $prevblock .= $block; | |
5227 | $prevblock =~ s/$prompt$//; | |
5228 | print $prevblock; | |
5229 | $num_read += length $prevblock; | |
5230 | die "error: expected size $size, received size $num_read\n" | |
5231 | unless $num_read == $size; | |
5232 | ||
5233 | ## Print totals. | |
5234 | $total_time = (time - $start_time) || 1; | |
5235 | $k_per_sec = ($size / 1024) / $total_time; | |
5236 | $k_per_sec = sprintf "%3.1f", $k_per_sec; | |
5237 | warn("$num_read bytes received in $total_time seconds ", | |
5238 | "($k_per_sec Kbytes/s)\n"); | |
5239 | ||
5240 | exit; | |
5241 | ||
5242 | ||
5243 | =head1 AUTHOR | |
5244 | ||
5245 | Jay Rogers <jay@rgrs.com> | |
5246 | ||
5247 | ||
5248 | =head1 COPYRIGHT | |
5249 | ||
5250 | Copyright 1997, 2000, 2002 by Jay Rogers. All rights reserved. | |
5251 | This program is free software; you can redistribute it and/or | |
5252 | modify it under the same terms as Perl itself. |