Automatización de Guiones Pty

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$