En esta sección desarrollamos un módulo que facilita el proceso de escribir un guión para una interacción con un programa através de seudoterminales.
La implementación se realiza a través del
módulo IO::Pty::Script
. La distribución
actual esta aún en desarrollo:
IO-Pty-Script-0.02.tar.gz.
El guión se almacena como un array anónimo asociado con la clave
script
. El guión es una secuencia de parejas (expresión-regular,
respuesta).
La respuesta del lado maestro
es habitualmente una cadena,
pero también puede ser una referencia a una subrutina
la cuál actúa como manejador de la respuesta del programa lanzado.
Si la respuesta es un manejador recibe como primer
argumento un objeto que describe el resultado de la última
lectura desde la seudoterminal. Es posible especificar
argumentos para la llamada al manejador haciendo que
el valor asociado con la clave-expresión regular sea una referencia
a un array. Es posible especificar un manejador o acción por defecto.
La subrutina apuntada por defaultaction
se ejecuta
para todas las parejas que no definen un manejador
específico.
lhp@nereida:~/Lperl/src/perl_networking/ch2/IO-Pty-Script/lib/IO/Pty$ cat -n Script.pm 1 package IO::Pty::Script; 2 use 5.008008; 3 use strict; 4 use warnings; 5 use IO::Handle; 6 use IO::Pty; 7 use IO::Select; 8 use Carp; 9 use POSIX; 10 use UNIVERSAL qw( isa ); 11 12 require Exporter; 13 14 our @ISA = qw(Exporter); 15 16 our @EXPORT_OK = ( qw{TIMEOUT DEFAULT_DEADLINE chats} ); 17 our @EXPORT = qw( ); 18 our $VERSION = '0.02'; 19 20 use constant BUFFER_SIZE => 4096; 21 use constant DEBUG => 1; 22 use constant DEFAULT_DEADLINE => 4; 23 use constant TIMEOUT => 0.2; 24 25 sub new { 26 my $class = shift; 27 my $self = { @_ }; 28 bless $self, $class; 29 } 30 31 sub do_command { 32 my ($pty, $STAT_RDR, $STAT_WTR, $command, @args) = @_; 33 34 $pty->set_raw(); 35 defined(my $child = fork) or carp "Can't fork: $!"; 36 return if $child; 37 close $STAT_RDR; 38 $pty->make_slave_controlling_terminal(); 39 my $tty = $pty->slave(); 40 $tty->set_raw(); 41 close($pty); 42 STDIN->fdopen($tty, "<"); 43 STDOUT->fdopen($tty, ">"); 44 STDERR->fdopen($tty, ">"); 45 close($tty); 46 $| = 1; 47 { exec $command, @args; } 48 print $STAT_WTR $!+0; # Fuerza contexto numérico 49 } 50 51 { 52 my $line = ''; 53 54 sub waitfor { 55 my $pty = shift; 56 my $sel = shift; 57 my $regexp = shift; 58 my $seconds = shift; 59 my ($localline, $delayed, $nr, $parenthesis); 60 61 alarm($seconds); 62 eval { 63 while ($nr = sysread($pty, $line, BUFFER_SIZE, length($line))) { 64 last if $line =~ m{$regexp}; 65 } 66 }; 67 alarm(0); 68 # Leer si hay algo en la seudoterminal despues de TIMEOUT 69 while ($sel->can_read(TIMEOUT)) { 70 $nr = sysread($pty, $line, BUFFER_SIZE, length($line)); 71 } 72 $line =~ m{($regexp)}; 73 if (defined($1)) { 74 $localline = substr($line, 0, $+[0]); 75 $line = substr($line, length($localline)); 76 $delayed = 0; 77 no strict 'refs'; 78 $parenthesis = [ map { ${$_} } 2..(scalar @+) ]; 79 } 80 else { 81 $localline = $line; 82 $line = ''; 83 $delayed = 1; 84 } 85 my $is_eof = defined($nr) && ($nr == 0); 86 return wantarray? ($localline, $line, $delayed, $parenthesis, $is_eof) : $localline; 87 } 88 } 89 90 sub printpty { 91 my $pty = shift; 92 my $sel = shift; 93 my $message = shift; 94 do {} until $sel->can_write(TIMEOUT); 95 syswrite($pty, $message); 96 } 97 98 sub chat { 99 my $self = shift; 100 my $command = $self->command() || 101 carp "Error in chat: command argument missed";; 102 my $deadline = $self->deadline() || DEFAULT_DEADLINE; 103 104 carp "Error in chat: script argument missed" unless defined($self->script()); 105 my @script = @{$self->script()}; 106 my $action = $self->defaultaction() || sub {}; 107 my ($r, $s, $d, $p, $eof); 108 109 my $pty = IO::Pty->new or carp "Can't make Pty: $!"; 110 my $sel = IO::Select->new(); 111 $sel->add($pty); 112 my ($STAT_RDR, $STAT_WTR); 113 pipe($STAT_RDR, $STAT_WTR) or carp "Cannot open pipe: $!"; 114 do_command($pty, $STAT_RDR, $STAT_WTR, $command); 115 close $STAT_WTR; 116 my $errno; 117 my $errstatus = sysread($STAT_RDR, $errno, 256); 118 carp "Cannot sync with child: $!" if not defined $errstatus; 119 close $STAT_RDR; 120 if ($errstatus) { 121 $! = $errno+0; 122 carp "Cannot exec(@ARGV): $!"; 123 } 124 my $alarmhandler = sub { die; }; 125 local $SIG{ALRM} = $alarmhandler; 126 while (@script) { 127 my $question = shift @script; 128 my $answer = shift @script; 129 ($r, $s, $d, $p, $eof) = waitfor($pty, $sel, $question, $deadline); 130 my $qaa = IO::Pty::Script::Answer->new( 131 pty => $pty, 132 sel => $sel, 133 script => \@script, 134 answer => $r, 135 overpassed => $s, 136 delayed => $d, 137 parenthesis => $p, 138 eof => $eof, 139 deadline => \$deadline 140 ); 141 if (isa $answer, "CODE") { 142 $answer = $answer->($qaa); 143 } 144 elsif (isa $answer, "ARRAY") { 145 my $func = shift @$answer || carp "Empty array of parameters"; 146 if (isa $func, "CODE") { 147 my @params = @$answer; 148 $answer = $func->($qaa, @params); 149 } 150 else { 151 $action->($qaa, @$answer); 152 } 153 } 154 else { # $answer is a string 155 $action->($qaa); 156 } 157 printpty($pty, $sel, $answer); 158 } 159 close($pty); 160 } 161 162 sub chats { 163 while (@_) { 164 my $self = shift; 165 $self->chat(); 166 } 167 } 168 169 our $AUTOLOAD; 170 sub AUTOLOAD { 171 my $self = shift; 172 173 $AUTOLOAD =~ /.*::(\w+)/; 174 my $subname = $1; 175 carp "No such method $AUTOLOAD " unless (defined($subname)); 176 no strict 'refs'; 177 if (exists($self->{$subname})) { 178 *{$AUTOLOAD} = sub { 179 $_[0]->{$subname} = $_[1] if @_ >1; 180 $_[0]->{$subname} 181 }; 182 $self->{$subname} = $_[0] if @_; 183 return $self->{$subname}; 184 } 185 carp "No such method $AUTOLOAD"; 186 } 187 188 sub DESTROY { 189 } 190 191 1; 192 193 ####################################################################### 194 package IO::Pty::Script::Answer; 195 use Carp; 196 use strict; 197 our $AUTOLOAD; 198 199 sub new { 200 my $class = shift; 201 my $self = { @_ }; 202 bless $self, $class; 203 } 204 205 use overload q("") => \&strqa; 206 sub strqa { 207 my $self = shift; 208 209 my $r = $self->answer(); 210 my $s = $self->overpassed(); 211 my $d = $self->delayed(); 212 return <<"EOL"; 213 <<r = '$r' 214 s = '$s' 215 d = '$d'>> 216 EOL 217 } 218 219 sub redirect { 220 my ($src,$dst) = @_; 221 my $buf = ''; 222 my $read = sysread($src, $buf, 1); 223 if (defined $read && $read) { 224 syswrite($dst,$buf,$read); 225 } 226 else { # EOF 227 print STDERR "Nothing from $src"; 228 print "$read\n" if defined($read); 229 } 230 return $buf; 231 } 232 233 sub keyboard { 234 my $self = shift; 235 my $escape = shift; 236 my $return_value = shift; 237 238 my $char; 239 my $pty = $self->pty(); 240 my $ws = $self->sel(); 241 my $rs = IO::Select->new(); 242 $rs->add(\*STDIN, $pty); 243 WHILE_NOT_ESCAPE_OR_EOF: 244 { # infinite loop 245 my @ready = $rs->can_read(IO::Pty::Script::TIMEOUT); 246 if (@ready) { 247 @ready = reverse @ready if (@ready >1) and ($ready[0] != $pty); 248 if ($ready[0] == $pty) { 249 my $read = sysread($pty, $char, 1); 250 if (defined $read && $read) { 251 syswrite(STDOUT,$char,$read); 252 } 253 else { # EOF 254 last WHILE_NOT_ESCAPE_OR_EOF 255 } 256 } 257 elsif ($ws->can_write(IO::Pty::Script::TIMEOUT)) { # Algo en STDIN 258 my $read = sysread(STDIN, $char, 1); 259 last WHILE_NOT_ESCAPE_OR_EOF if $char eq $escape; 260 if (defined $read && $read) { 261 syswrite($pty,$char,$read); 262 } 263 else { 264 last WHILE_NOT_ESCAPE_OR_EOF 265 } 266 } 267 } 268 redo; 269 } 270 return $return_value; 271 } 272 273 sub deadline { 274 ${$_[0]->{deadline}} = $_[1] if @_ >1; 275 ${$_[0]->{deadline}}; 276 } 277 278 sub parenthesis { 279 return @{$_[0]->{parenthesis}}; 280 } 281 282 sub can_read { 283 my $self = shift; 284 my $deadline = shift; 285 my $sel = $self->{sel}; 286 287 return $sel->can_read($deadline); 288 } 289 290 sub can_write { 291 my $self = shift; 292 my $deadline = shift; 293 my $sel = $self->{sel}; 294 295 return $sel->can_write($deadline); 296 } 297 298 sub AUTOLOAD { 299 my $self = shift; 300 301 $AUTOLOAD =~ /.*::(\w+)/; 302 my $subname = $1; 303 carp "No such method $AUTOLOAD " unless (defined($subname)); 304 no strict 'refs'; 305 if (exists($self->{$subname})) { 306 *{$AUTOLOAD} = sub { 307 $_[0]->{$subname} = $_[1] if @_ >1; 308 $_[0]->{$subname} 309 }; 310 $self->{$subname} = $_[0] if @_; 311 return $self->{$subname}; 312 } 313 carp "No such method $AUTOLOAD"; 314 } 315 316 sub DESTROY { 317 } 318 319 1;
Veamos un ejemplo de uso:
lhp@nereida:~/Lperl/src/perl_networking/ch2/IO-Pty-Script/script$ cat -n ptyconnect4.pl 1 #!/usr/bin/perl -sw -I../lib 2 use strict; 3 use IO::Pty::Script qw{TIMEOUT DEFAULT_DEADLINE chats}; 4 5 my %script; 6 our($c, $d, $p, $f); # Inicializadas via -s switch 7 8 $p = '' unless defined($p); 9 $d = DEFAULT_DEADLINE unless defined($d); 10 $f = '' unless defined($f); 11 die "Usage:$0 -c=command -p=key -d=deadline -f=script\n" 12 unless defined($c); 13 my $prompt = '[$>]\s+'; 14 15 $script{'ssh -l casiano etsii'} = [ 16 '.*password:\s' => "$p\n", 17 '(word:\s)|(login: )|(> )' => "$f\n", 18 $prompt => "exit\n" 19 ]; 20 21 #$script{'ssh -l casiano etsii'} = [ 22 #'.*password:\s' => "$p\n", 23 #'.*q para salir.\s\s\s\s' => "millo\n", 24 #'word:\s' => "$p\n", 25 #'(word:\s)|(login: )|(> )' => "$f\n", 26 #$prompt => "exit\n" 27 #]; 28 29 $script{'ssh -l casiano beowulf'} = [ 30 '.*password:\s' => "$p\n", 31 $prompt => "$f\n", 32 $prompt => "exit\n" 33 ]; 34 35 #$script{'ssh europa'} = [ 36 #$prompt => "$f\n", 37 #$prompt => [\&titi, 1, 2, "tres"], 38 #$prompt => "exit\n" 39 #]; 40 41 $script{'ssh europa'} = [ 42 $prompt => "$f\n", 43 $prompt => [\&titi, 1, 2, "tres"], 44 $prompt => sub { my $self = shift; $self->keyboard("\cD"); "ls\n" }, 45 $prompt => "echo 'Despues de la interaccion'\n", 46 $prompt => "exit\n" 47 ]; 48 49 sub tutu { 50 print "<<sub tutu:\n"; 51 print $_[0]; 52 my @par = $_[0]->parenthesis(); 53 print "Paréntesis: @par\n"; 54 print "Es posible leer en la terminal\n" if $_[0]->can_read(TIMEOUT); 55 print "Es posible escribir en la terminal\n" if $_[0]->can_write(TIMEOUT); 56 print "end sub tutu>>\n"; 57 "8*2\n" 58 } 59 60 sub titi { 61 local $" = "\nsub titi:"; 62 print "<<sub titi: @_>>\n"; 63 "date\n"; 64 } 65 66 $script{bc} = [ 67 'warranty..\s\s' => "5*9.5\n", 68 '(\d+)\.?(\d*)\s+' => \&tutu, 69 '\d+\.?\d*\s+' => "4*2\n", 70 '\d+\.?\d*\s+' => "quit", 71 ]; 72 73 my $bc = IO::Pty::Script->new( 74 command => 'bc', 75 deadline => 4, 76 script => $script{bc}, 77 defaultaction => sub { print $_[0] } 78 ); 79 80 my $s = IO::Pty::Script->new( 81 command => $c, 82 deadline => $d, 83 script => $script{$c}, 84 defaultaction => sub { print $_[0] } 85 ); 86 chats($bc, $s);
Sigue un ejemplo de ejecución:
lhp@nereida:~/Lperl/src/perl_networking/ch2/IO-Pty-Script/script$ ptyconnect4.pl -c='ssh -l casiano beowulf' -p=password -d=3 -f='ls' <<r = 'bc 1.06 Copyright 1991-1994, 1997, 1998, 2000 Free Software Foundation, Inc. This is free software with ABSOLUTELY NO WARRANTY. For details type `warranty'. ' s = '' d = '0'>> <<sub tutu: <<r = '47.5 ' s = '' d = '0'>> Paréntesis: 47 5 Es posible escribir en la terminal end sub tutu>> <<r = '16 ' s = '' d = '0'>> <<r = '8 ' s = '' d = '0'>> <<r = 'casiano@beowulf's password: ' s = '' d = '0'>> <<r = ' Linux beowulf 2.6.15-1-686 #2 Mon Mar 6 15:27:08 UTC 2006 i686 The programs included with the Debian GNU/Linux system are free software; the exact distribution terms for each program are described in the individual files in /usr/share/doc/*/copyright. Debian GNU/Linux comes with ABSOLUTELY NO WARRANTY, to the extent permitted by applicable law. Last login: Mon Jun 5 13:24:42 2006 from nereida.deioc.ull.es casiano@beowulf:~$ ' s = '' d = '0'>> <<r = 'bc_pty2.pl _Inline passwd_pty.pl pilock.pl src try6 bc_pty6.pl log pi pi.pl ssh_pty.pl casiano@beowulf:~$ ' s = '' d = '0'>> lhp@nereida:~/Lperl/src/perl_networking/ch2/IO-Pty-Script/script$