File Coverage

blib/lib/Pick/TCL.pm
Criterion Covered Total %
statement 55 286 19.2
branch 17 158 10.7
condition 1 12 8.3
subroutine 11 23 47.8
pod 10 10 100.0
total 94 489 19.2


line stmt bran cond sub pod time code
1             package Pick::TCL;
2              
3 3     3   76811 use 5.006;
  3         14  
  3         132  
4 3     3   18 use strict;
  3         5  
  3         100  
5 3     3   15 use warnings;
  3         11  
  3         86  
6 3     3   18 use Carp;
  3         20  
  3         224  
7 3     3   2726 use Errno;
  3         4267  
  3         137  
8 3     3   4854 use IO::Select;
  3         5668  
  3         176  
9 3     3   3254 use IO::Socket;
  3         87064  
  3         18  
10 3     3   2274 use Socket;
  3         8  
  3         3694  
11              
12             =head1 NAME
13              
14             Pick::TCL - class to run commands in a Pick TCL shell
15              
16             =head1 VERSION
17              
18             Version 0.06
19              
20             =cut
21              
22             ###################
23             # PACKAGE GLOBALS #
24             ###################
25              
26             our $VERSION = '0.06';
27             our %_mods;
28              
29             #########################
30             # OPTIONAL DEPENDENCIES #
31             #########################
32              
33             BEGIN
34             {
35 3     3   10 %_mods = ();
36 3 50       5 if (eval { require IPC::Run; })
  3         4910  
37             {
38 3         166898 $_mods{'local'} = 'IPC::Run';
39             }
40 3 50       17 if (eval { require Net::OpenSSH; })
  3         12661  
41             {
42 0         0 $_mods{'remote'} = 'Net::OpenSSH';
43             }
44             }
45              
46             if (scalar(keys %_mods) == 0)
47             {
48             croak "Pick::TCL requires either IPC::Run or Net::OpenSSH";
49             }
50              
51             =head1 SYNOPSIS
52              
53             use Pick::TCL;
54              
55             # Establish connection
56             my $ap = Pick::TCL->new(%options);
57            
58             # Execute commands
59             my $output = $ap->exec('TCL.COMMAND PARAMS (OPTIONS)');
60             my $unsanitised = $ap->execraw('TCL.COMMAND PARAMS (OPTIONS)');
61              
62             # Spawn, check & retrieve output of long-running commands
63             $ap->spawn('TCL.COMMAND PARAMS (OPTIONS)')} = 1;
64             # ...
65             do_something_with($ap->output) if $ap->is_ready;
66              
67             # Clean up
68             $ap->logout();
69              
70             =head1 DESCRIPTION
71              
72             C provides a class to run arbitrary B (that's
73             I, not the "other" TCL) commands in a
74             local or remote Pick or Pick-like environment, either synchronously
75             (blocking until execution has completed) or asynchronously.
76              
77             =over 4
78              
79             =item Local connections
80              
81             require either L or L to be installed and usable.
82              
83             =item Remote connections
84              
85             require L to be installed and usable.
86              
87             =back
88              
89             Note that C will croak() if used when neither L
90             nor L are usable.
91              
92             =cut
93              
94             ###################
95             # Private methods #
96             ###################
97              
98             # Get an ssh link. Returns 1 on success. On failure returns undef
99             # and sets $!
100             sub _bring_up_ssh
101             {
102 0     0   0 my $self = shift;
103              
104             # Build connection string
105 0         0 my %options = %{$$self{'_OPTIONS'}};
  0         0  
106 0 0       0 my $cs = defined($options{'SSHUSER'}) ? $options{'SSHUSER'} : "";
107 0 0       0 $cs .= ':'.$options{'SSHPASS'} if defined($options{'SSHPASS'});
108 0 0       0 $cs .= '@' unless $cs eq '';
109 0         0 $cs .= $options{'HOST'};
110 0 0       0 $cs .= ':'.$options{'PORT'} if defined($options{'PORT'});
111              
112             # Survive in Taint mode
113 0         0 local %ENV;
114 0         0 $ENV{'PATH'} = "";
115            
116             # Find ssh binary
117 0 0       0 unless (defined($options{'SSHCMD'}))
118             {
119 0         0 my $cmd = '';
120 0         0 foreach my $c (qw[/usr/local/bin/ssh /usr/bin/ssh /bin/ssh])
121             {
122 0 0       0 next unless -x $c;
123 0         0 $cmd = $c;
124 0         0 last;
125             }
126 0 0       0 croak "Pick::TCL: can't find ssh" unless $cmd;
127 0         0 $$self{'_OPTIONS'}->{'SSHCMD'} = $cmd;
128             }
129              
130             # Bring up link
131 0 0       0 croak "Pick::TCL: No usable module found for remote connections"
132             unless $_mods{'remote'};
133 0         0 my $ssh = undef;
134 0         0 $ssh = Net::OpenSSH->new($cs, ssh_cmd => $$self{'_OPTIONS'}->{'SSHCMD'},
135             master_stderr_discard => 1,
136             timeout => $$self{'_OPTIONS'}->{'TIMEOUT'}, kill_ssh_on_timeout => 1,
137             default_ssh_opts => [ '-oConnectionAttempts=0' ] );
138 0         0 my $e = $ssh->error;
139 0 0       0 if ($e)
140             {
141 0         0 carp "Pick::TCL: Failed to bring up ssh link: $e";
142 0         0 $! = &Errno::ETIMEDOUT;
143 0         0 return undef;
144             }
145 0         0 $$self{'_SSH'} = \$ssh;
146 0         0 return 1;
147             }
148              
149             # Tear down & re-establish an ssh link
150             sub _reconnect_ssh
151             {
152 0     0   0 my $self = shift;
153 0 0       0 if (ref($$self{'_SSH'}))
154             {
155 0         0 ${$$self{'_SSH'}}->DESTROY;
  0         0  
156             }
157 0         0 delete($$self{'_SSH'});
158 0         0 return $self->_bring_up_ssh();
159             }
160              
161             # Generate user logon sequence
162             sub _mklogon
163             {
164 0     0   0 my $self = shift;
165 0         0 my $logon = '';
166 0         0 foreach my $k (qw/USER PASS MD MDPASS/)
167             {
168 0 0       0 next unless defined($$self{'_OPTIONS'}->{$k});
169 0         0 $logon .= $$self{'_OPTIONS'}->{$k} . "\n";
170             }
171 0         0 return $logon;
172             }
173              
174             # Build Pick command
175             sub _mkpickcmd
176             {
177 0     0   0 my $self = shift;
178 0         0 my $tclcmd = shift;
179 0         0 my @args;
180 0         0 push @args, $$self{'_OPTIONS'}->{'PICKBIN'};
181 0         0 push @args, $$self{'_OPTIONS'}->{'OPTVM'};
182 0         0 push @args, $$self{'_OPTIONS'}->{'VM'};
183 0         0 push @args, $$self{'_OPTIONS'}->{'OPTSILENT'};
184 0         0 push @args, $$self{'_OPTIONS'}->{'OPTDATA'};
185 0         0 push @args, $self->_mklogon . $tclcmd . "\r";
186 0         0 return @args;
187             }
188              
189             =head1 CLASS METHODS
190              
191             =head2 new(%options)
192              
193             Returns a new C object on success (or C
194             on failure). C<%options> is optional and if present may contain
195             any combination of the following keys:
196              
197             =over 4
198              
199             =item HOST
200              
201             The hostname of the Pick host. If specified, all calls to Pick
202             will be made via a L link to the host of the
203             supplied name; if not specified, Pick is presumed to be running
204             on the local host and L is not used
205             (unless L is missing and C is not specified, in
206             which case C will be set implicitly to C).
207              
208             =item PORT
209              
210             Only valid if C is also set. Specifies the TCP port on
211             which to connect to sshd(8) on C. Defaults to 22.
212              
213             =item SSHUSER
214              
215             Only valid if C is also given. Specifies the Unix username
216             to supply to the remote sshd(8) on C. Defaults to the
217             current local username.
218              
219             =item SSHPASS
220              
221             Only valid if C is also given. Specifies that password
222             authentication should be used, with the given Unix password.
223             If C is given but C is not, public key
224             authentication is used instead of password authentication.
225              
226             =item SSHCMD
227              
228             Only valid if C is also given. Specifies the full path
229             to the ssh(1) binary (in case L cannot find
230             it). If not specified, only F,
231             F and F (in that order) are tried.
232              
233             =item TIMEOUT
234              
235             Only valid if C is also given. Specifies the maximum
236             number of seconds for which to wait for a response from a
237             remote Pick system.
238              
239             =item VM
240              
241             The name of the Pick virtual machine to which to connect.
242             Defaults to C.
243              
244             =item USER
245              
246             The user name with which to log on to C. Defaults
247             to the value of C (or to the current Unix username
248             if C is not given).
249              
250             =item PASS
251              
252             The password with which to log on to C, if required.
253              
254             =item MD
255              
256             The Pick I to log onto, if required.
257              
258             =item MDPASS
259              
260             Only valid if C is also given. The password for C,
261             if required.
262              
263             =item PICKBIN
264              
265             The full path to the Pick binary on C. Defaults
266             to F.
267              
268             =item OPTVM
269              
270             The switch to pass to C indicating that the
271             next parameter is a VM / config-file name. Defaults to
272             C<-n>.
273              
274             =item OPTSILENT
275              
276             The switch to pass to C in order to suppress
277             logon and logoff messages. Defaults to C<-s>.
278              
279             =item OPTDATA
280              
281             The switch to pass to C indicating that the
282             next parameter contains "stacked" data for input to
283             the Pick session. Defaults to C<-d>.
284              
285             =back
286              
287             All keys are optional, with the caveats that if C,
288             C, C and/or C are specified,
289             for those options to take effect C must also be
290             specified; and likewise C has no effect without
291             C.
292              
293             =head3 Note:
294              
295             new() does not actually try to log on to C -- where
296             Pick is local, the C<%options> are merely stored in the
297             C object for later use; on the other hand if
298             C is set (i.e. Pick is remote), new() will establish
299             a L link to C or croak() trying.
300              
301             =cut
302              
303             sub new
304             {
305 2     2 1 29 my $class = shift;
306 2 50       8 if (ref($class))
307             {
308             # Reset existing login
309 0         0 $class->logout();
310 0         0 $class = ref($class);
311             }
312 2         7 my $self = {};
313              
314             # Check/set options
315 2 50       14 croak "Pick::TCL constructor options must be a balanced hash"
316             unless scalar(@_) % 2 == 0;
317 2         6 my %options = @_;
318 2 50       12 $options{'VM'} = 'pick0' unless defined($options{'VM'});
319 2 50       9 unless (defined($options{'USER'}))
320             {
321             # Default Pick username to remote Unix username if set
322 2         6 my $u = $options{'SSHUSER'};
323             # Otherwise local username
324 2 50       8 $u = eval { getpwuid($<); } unless defined($u);
  2         2086  
325             # Handle platforms without a working getpwuid()
326 2 50       17 $u = getlogin() unless defined($u);
327             }
328 2 50       11 $options{'PICKBIN'} = '/usr/bin/ap' unless defined($options{'PICKBIN'});
329 2 50       10 $options{'OPTDATA'} = '-d' unless defined($options{'OPTDATA'});
330 2 50       8 $options{'OPTSILENT'} = '-s' unless defined($options{'OPTSILENT'});
331 2 50       9 $options{'OPTVM'} = '-n' unless defined($options{'OPTVM'});
332 2 50       9 if (defined($options{'TIMEOUT'}))
333             {
334 0         0 $options{'TIMEOUT'} = 0 + $options{'TIMEOUT'};
335             } else {
336 2         5 $options{'TIMEOUT'} = 15;
337             }
338 2 50 33     17 if ((not defined($options{'HOST'})) && (not defined($_mods{'local'})))
339             {
340             # For a local VM, if we're missing IPC::Run, just ssh to the
341             # loopback interface instead
342 0         0 $options{'HOST'} = 'localhost';
343             }
344 2         9 $$self{'_OPTIONS'} = \%options;
345 2         9 bless $self, $class;
346              
347             # Check ssh host reachable
348 2 50       7 if ($options{'HOST'})
349             {
350 0 0       0 return undef unless $self->_bring_up_ssh();
351             }
352              
353 2         12 return $self;
354             }
355              
356             =head1 INSTANCE METHODS
357              
358             =head2 $ap->exec($tclcmd, @input)
359              
360             Executes the Pick B command C<$tclcmd> on the Pick VM associated
361             with the C object C<$ap> synchronously and returns the output.
362              
363             In order to cope with the wide variety of terminal settings found on
364             different Pick systems in the wild (or in some cases, even on different
365             ports of the same VM, allocated dynamically...), line endings in the
366             returned output are sanitised: any sequence of one or more control
367             characters (other than tabs) is treated as a single line ending. As a
368             consequence, any consecutive line endings are collapsed.
369              
370             In list context, returns a list of output lines; in scalar context,
371             returns all output lines joined with line feeds.
372              
373             The second parameter, C<@input>, is optional. If specified, its
374             elements, joined with carriage returns, are supplied as input to
375             the B session.
376              
377             On caller or Pick error (including if Pick or ssh emit anything
378             on C), returns false, sets C<$!> and emits a suitable
379             message. Likewise on B error, except that exit codes 11 and 255
380             are ignored, in order to support ancient versions of L).
381              
382             croak()s if the call to a local VM fails outright.
383              
384             =head2 $ap->execraw($tclcmd, @input)
385              
386             Does the same thing as the exec() method but without any
387             output sanitisation.
388              
389             This is useful when dealing with binary output, or when consecutive
390             line breaks in output are significant. However, in those circumstances
391             the caller will need to know in advance the pertinent terminal settings
392             of the port to which it is connecting on the target Pick system and do
393             its own filtering of extraneous nulls, form feeds, etc. to suit.
394              
395             =cut
396              
397             sub execraw
398             {
399 0     0 1 0 my $self = shift;
400 0         0 my $func = 'Pick::TCL::execraw()';
401 0 0       0 croak "$func is not a class method" unless ref($self);
402 0 0       0 if (scalar(@_) == 0)
403             {
404 0         0 carp "$func: cowardly refusing to execute a null TCL command";
405 0         0 $! = &Errno::ENOMSG;
406 0         0 return undef;
407             }
408 0         0 my $tclcmd = shift;
409 0         0 my $input = undef;
410 0 0       0 $input = join "\r", @_ if scalar(@_) > 0;
411 0         0 my @args = $self->_mkpickcmd($tclcmd);
412              
413             # Run command
414 0         0 my ($result, $err) = ("", "");
415 0         0 $ENV{'PATH'} = "";
416 0 0       0 if (defined($$self{'_SSH'}))
417             {
418             # Remote VM
419 0 0       0 unless ($self->_reconnect_ssh())
420             {
421 0         0 carp "$func: $!";
422 0         0 return undef;
423             }
424 0         0 my $ssh = $$self{'_SSH'};
425 0         0 ($result, $err) = $$ssh->capture2({stdin_data => $input}, @args);
426 0         0 my $serr = $$ssh->error();
427 0 0 0     0 if (($serr) && ($serr ne 'child exited with code 11')
      0        
428             && ($serr ne 'child exited with code 255'))
429             {
430 0         0 carp "$func: fatal error: $serr detail ($! $?): $err";
431 0         0 carp "$func: stdout was $result";
432 0         0 $! = &Errno::EBADFD;
433 0         0 return undef;
434             }
435             } else {
436             # Local VM
437 0 0       0 IPC::Run::run(\@args, \$input, \$result, \$err)
438             or croak "Broken pipe to Pick: $!";
439 0 0       0 if ($err)
440             {
441 0         0 carp "$func: $err";
442 0         0 $! = &Errno::EBADFD;
443 0         0 return undef;
444             }
445             }
446 0         0 return $result;
447             }
448              
449             sub exec
450             {
451 0     0 1 0 my $self = shift;
452 0         0 my $func = 'Pick::TCL::exec()';
453 0 0       0 croak "$func is not a class method" unless ref($self);
454 0 0       0 if (scalar(@_) == 0)
455             {
456 0         0 carp "$func: cowardly refusing to execute a null TCL command";
457 0         0 $! = &Errno::ENOMSG;
458 0 0       0 return wantarray ? () : undef;
459             }
460              
461             # Get response & sanitise
462 0 0       0 my $raw = $self->execraw(@_) or return wantarray ? () : undef;
    0          
463 0         0 my @lines = split /[^\x09\x20-\x7e]+/m, $raw;
464 0 0       0 return wantarray ? @lines : join "\n", @lines;
465             }
466              
467             =head2 $ap->spawn($tclcmd, @input)
468              
469             Spawns C<$tclcmd> for asynchronous execution on the Pick VM associated
470             with C<$ap>.
471              
472             On success, returns true. On failure, returns C and sets C<$!>.
473              
474             Output can be retrieved later with the output() method (see below).
475              
476             =cut
477              
478             sub spawn
479             {
480 0     0 1 0 my $self = shift;
481 0         0 my $func = 'Pick::TCL::spawn()';
482 0 0       0 croak "$func is not a class method" unless ref($self);
483 0 0       0 if (scalar(@_) == 0)
484             {
485 0         0 carp "$func: cowardly refusing to execute a null TCL command";
486 0         0 $! = &Errno::ENOMSG;
487 0         0 return undef;
488             }
489 0         0 my $tclcmd = shift;
490 0         0 my $input = undef;
491 0 0       0 $input = join "\r", @_ if scalar(@_) > 0;
492 0         0 my @args = $self->_mkpickcmd($tclcmd);
493              
494             # Run command
495 0         0 $ENV{'PATH'} = "";
496 0 0       0 if (defined($$self{'_SSH'}))
497             {
498             # Remote VM
499 0 0       0 unless ($self->_reconnect_ssh())
500             {
501 0         0 carp "$func: $!";
502 0         0 return undef;
503             }
504 0         0 my $ssh = $$self{'_SSH'};
505 0         0 my ($socket, $pid) = $$ssh->open2socket({}, @args);
506 0         0 my $serr = $$ssh->error();
507 0 0       0 if ($serr)
508             {
509 0         0 carp "$func: fatal error: $serr: $! $?";
510 0         0 $! = &Errno::EBADFD;
511 0         0 return undef;
512             }
513 0 0       0 if (defined($input))
514             {
515 0         0 while (length($input) > 0)
516             {
517 0         0 my $bytes = syswrite $socket, $input;
518 0 0       0 unless (defined($bytes))
519             {
520 0         0 carp "$func: socket write error: $!";
521 0         0 return undef;
522             }
523 0         0 $input = susbtr($input, $bytes);
524             }
525             }
526 0         0 $socket->blocking(0);
527 0         0 my $set = IO::Select->new();
528 0         0 $set->add($socket);
529 0         0 $$self{'_SOCKET'} = $socket;
530 0         0 $$self{'_SOCKSET'} = $set;
531 0         0 $$self{'_PID'} = $pid;
532             } else {
533             # Local VM -- IPC::Run cannot detect EOF when spawning asynchronously,
534             # so just fork() & run() instead
535 0         0 my ($child, $parent);
536 0 0       0 unless (socketpair($child, $parent, AF_UNIX, SOCK_STREAM, PF_UNSPEC))
537             {
538 0         0 carp "$func: socketpair(): $!";
539 0         0 return undef;
540             }
541 0         0 $child->autoflush(1);
542 0         0 $parent->autoflush(1);
543              
544 0         0 my $pid = fork();
545 0 0       0 unless (defined($pid))
546             {
547 0         0 my $errno = $!;
548 0         0 carp "$func: fork(): $errno";
549 0         0 $child->close;
550 0         0 $parent->close;
551 0         0 $! = $errno;
552 0         0 return undef;
553             }
554 0 0       0 if ($pid)
555             {
556             # In parent, act just like we would for a remote VM
557 0         0 $parent->close;
558 0         0 my $set = IO::Select->new();
559 0         0 $set->add($child);
560 0         0 $$self{'_SOCKET'} = $child;
561 0         0 $$self{'_SOCKSET'} = $set;
562 0         0 $$self{'_PID'} = $pid;
563 0         0 return 1;
564             }
565             # In child, act just like we would for synchronous execution
566 0         0 $child->close;
567 0         0 my ($result, $err) = ('', '');
568 0 0       0 my $ran = IPC::Run::run(\@args, \$input, \$result, \$err)
569             or croak "Broken pipe to Pick: $!";
570 0 0       0 croak "$func: $err" if $err;
571 0         0 print $parent $result;
572 0         0 exit 0;
573             }
574 0         0 return 1;
575             }
576              
577             =head2 $ap->is_ready
578              
579             Returns true if a previously spawned job has completed. Returns false
580             but defined if the job is still running. Returns C if the job
581             has aborted or if no job was spawned in the first place.
582              
583             =cut
584              
585             sub is_ready
586             {
587 0     0 1 0 my $self = shift;
588 0         0 my $func = 'Pick::TCL::is_ready()';
589 0 0       0 croak "$func is not a class method" unless ref($self);
590              
591             # Same approach for local or remote VM
592             # -- both use sockets for asyncrhonous execution
593 0 0       0 unless (defined($$self{'_SOCKSET'}))
594             {
595 0         0 $! = &Errno::ENOENT;
596 0         0 return undef;
597             }
598 0         0 my $buf = '';
599 0         0 my $errflag = 0;
600 0         0 my $errno = 0;
601 0         0 while(1)
602             {
603 0         0 my $readable = scalar($$self{'_SOCKSET'}->can_read(0));
604 0 0       0 unless (defined($readable))
605             {
606 0 0       0 return 0 unless defined($$self{'_PARTIAL'});
607 0         0 $errflag++;
608 0         0 $errno = $!;
609 0         0 last;
610             }
611 0 0       0 $$self{'_PARTIAL'} = '' unless defined($$self{'_PARTIAL'});
612 0 0       0 last if $readable == 0;
613 0         0 my $res = sysread $$self{'_SOCKET'}, $buf, 65536, length($buf);
614 0 0       0 unless (defined($res))
615             {
616 0 0       0 carp "$func: socket error: $!" unless $! == &Errno::EAGAIN;
617 0         0 $errno = $!;
618 0         0 $errflag++;
619 0         0 last;
620             }
621 0 0       0 last if $res == 0;
622             }
623 0         0 $$self{'_PARTIAL'} .= $buf;
624 0 0 0     0 if (($errflag) && ($errno == 0))
625             {
626 0         0 return 0;
627             }
628 0         0 $$self{'_SOCKSET'}->remove($$self{'_SOCKET'});
629 0         0 $$self{'_SOCKET'}->close;
630 0         0 waitpid($$self{'_PID'}, 0);
631 0         0 delete $$self{'_SOCKSET'};
632 0         0 delete $$self{'_SOCKET'};
633 0         0 delete $$self{'_PID'};
634 0 0       0 if ($errflag)
635             {
636 0         0 $! = $errno;
637 0         0 return undef;
638             }
639 0         0 return 1;
640             }
641              
642             =head2 $ap->output
643              
644             =head2 $ap->outputraw
645              
646             Returns the (raw or cooked) output of a previously spawned job if
647             it has completed.
648              
649             Sets C<$!> and returns C (or, for the cooked form, the empty
650             list if called in list context) if no job has been spawned.
651              
652             =cut
653              
654             sub outputraw
655             {
656 0     0 1 0 my $self = shift;
657 0         0 my $func = 'Pick::TCL::outputraw()';
658 0 0       0 croak "$func is not a class method" unless ref($self);
659 0 0       0 $$self{'_PARTIAL'} = '' unless defined($$self{'_PARTIAL'});
660              
661             # Same approach for local or remote VM
662             # -- both use sockets for asyncrhonous execution
663 0 0       0 $! = &Errno::ENOENT unless defined($$self{'_PARTIAL'});
664 0         0 return $$self{'_PARTIAL'};
665             }
666              
667             sub output
668             {
669 0     0 1 0 my $self = shift;
670 0         0 my $func = 'Pick::TCL::output()';
671 0 0       0 croak "$func is not a class method" unless ref($self);
672              
673             # Get response & sanitise
674 0         0 my $raw = $self->outputraw;
675 0         0 my $errno = $!;
676 0 0       0 if (defined($raw))
677             {
678 0         0 my @lines = split /[^\x09\x20-\x7e]+/m, $raw;
679 0 0       0 return wantarray ? @lines : join "\n", @lines;
680             }
681 0         0 $! = $errno;
682 0 0       0 return wantarray ? () : undef;
683             }
684              
685             =head2 $ap->partialoutput
686              
687             =head2 $ap->partialoutputraw
688              
689             Returns the (raw or cooked) output of a previously spawned job
690             that may not yet have completed.
691              
692             Returns C (or, for the cooked form, the empty list if
693             called in list context) if a previously spawned job does not
694             have any output yet or no job has been spawned.
695              
696             =cut
697              
698             sub partialoutputraw
699             {
700 0     0 1 0 my $self = shift;
701 0         0 my $func = 'Pick::TCL::partialoutputraw()';
702 0 0       0 croak "$func is not a class method" unless ref($self);
703 0         0 return $$self{'_PARTIAL'};
704             }
705              
706             sub partialoutput
707             {
708 0     0 1 0 my $self = shift;
709 0         0 my $func = 'Pick::TCL::partialoutput()';
710 0 0       0 croak "$func is not a class method" unless ref($self);
711 0         0 my $raw = $self->partialoutputraw;
712 0 0       0 if (defined($raw))
713             {
714 0         0 my @lines = split /[^\x09\x20-\x7e]+/m, $raw;
715 0 0       0 return wantarray ? @lines : join "\n", @lines;
716             }
717 0 0       0 return wantarray ? () : undef;
718             }
719            
720              
721             =head2 $ap->logout
722              
723             Destroys the connection. Not required to be called explicitly before
724             exit; does nothing when Pick is local.
725              
726             =cut
727              
728             sub logout
729             {
730 1     1 1 6 my $self = shift;
731 1 50       4 croak "Pick::TCL::logout() is not a class method" unless ref($self);
732 1 50       32 if (ref($$self{'_SSH'}))
733             {
734 0           my $ssh = $$self{'_SSH'};
735 0           $$ssh->DESTROY();
736 0           delete $$self{'_SSH'};
737             }
738             }
739              
740             =head1 CAVEATS
741              
742             =head2 Escaping metacharacters
743              
744             The commands sent to exec() and execraw() are always interpreted by
745             the Pick B interpreter -- so be sure to escape anything that needs
746             escaping in B before feeding it to exec() or execraw() (no
747             different from running native).
748              
749             If C is set, there's also the remote login shell to consider.
750             C uses L (which does auto-escaping of most
751             metacharacters) for the remote link, so this should not cause problems
752             either, so long as the remote user's login shell is set to the Bourne
753             shell, or at least something that's sufficiently compatible with it.
754              
755             Note especially that when C is set, parentheses around options
756             to B commands must be balanced (even though the Pick B
757             interpreter does not normally require that), as unbalanced parentheses
758             will likely confuse the remote shell.
759              
760             =head2 Parallel asynchronous commands
761              
762             Each C object can only spawn() or exec() one B
763             command at a time. If the caller needs to spawn() multiple B
764             commands in parallel (or exec() a B command while waiting
765             for an asynchronous one to complete), it should instantiate a
766             separate C object for each B command.
767              
768             =head2 Pick flavours
769              
770             C has only been tested with D3/Linux as the target Pick
771             platform (setting C to F). It should also work
772             unmodified with targets running D3/AIX, D3/SCO or legacy Advanced
773             Pick systems (on any host OS on which an sshd can be found or built).
774              
775             No attempt has been made thus far to cater specifically to other /
776             licensee / "Pick-like" target platforms, although the configurability
777             provided through C<%OPTIONS> may be sufficient to work with some.
778              
779             =head1 AUTHOR
780              
781             Jack Burton, C<< >>
782              
783             =head1 BUGS
784              
785             Please report any bugs or feature requests
786             to C, or through the web interface
787             at L.
788             I will be notified, and then you'll automatically be notified of
789             progress on your bug as I make changes.
790              
791             =head1 ACKNOWLEDGEMENTS
792              
793             Thanks to Jemalong Wool who provided funding for initial development.
794              
795             =head1 LICENSE AND COPYRIGHT
796              
797             Copyright 2013, 2014 Jack Burton.
798              
799             This program is free software; you can redistribute it and/or modify it
800             under the terms of either: the GNU General Public License as published
801             by the Free Software Foundation; or the Artistic License.
802              
803             See http://dev.perl.org/licenses/ for more information.
804              
805             =cut
806              
807             1; # End of Pick::TCL