home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 2 / 2021 / expect.pl
Encoding:
Perl Script  |  1990-12-28  |  9.1 KB  |  361 lines
  1. ## expect.pl rev ALPHA.1.01 01-NOV-90
  2. # Copyright (c) 1990, Randal L. Schwartz.  All Rights Reserved.
  3. # Available for use by all under the GNU PUBLIC LICENSE
  4.  
  5. # Status: AN ALPHA RELEASE
  6. #
  7. # Missing some functionality provided by the Don Libes 'expect' program.
  8. # The main stuff for babysitting an interactive process from a Perl program
  9. # is here, though.
  10. #
  11. # Will fail if called from non-'main' package unless variables and
  12. # filehandles are qualified (I don't have caller() yet).
  13. #
  14. # Missing better documentation. :-)  It helps if you have used the
  15. # Libes stuff.
  16. #
  17. # Some of the stuff didn't map really well to Perl.  I was torn
  18. # between making it useful and making it compatible.  I'm open to
  19. # suggestions. :-)
  20.  
  21. # THANKS:
  22. # Special thanks to Don Libes to provide the reason to write this package.
  23. # Thanks also to Larry Wall for his infinite patience with me.
  24.  
  25. package expect;
  26.  
  27. # &close(HANDLE)
  28. # Closes HANDLE.  may eventually ensure that the process associated
  29. # with HANDLE is gone, so call this instead of just close().
  30.  
  31. sub main'close {
  32.     local($handle) = @_;
  33.     $handle =~ s/^[^']+$/"main'".$&/e; # eventually caller()
  34.     close($handle);
  35. }
  36.  
  37. # &debug(...)
  38.  
  39. sub main'debug {
  40.     die "debug NOT IMPLEMENTED";
  41. }
  42.  
  43. # &exit(EXITVAL)
  44. # Calls exit.
  45.  
  46. sub main'exit {
  47.     exit(@_);
  48. }
  49.  
  50. # $expect'match:
  51. # contains the buffer (limited by $expect'match_max) of the most
  52. # recent chars seen in the last &expect call.
  53.  
  54. $match = "";
  55.  
  56. # $expect'match_max:
  57. # don't keep any more than this many characters when scanning for
  58. # an &expect.
  59.  
  60. $match_max = 2000;
  61.  
  62. # $expect'timeout:
  63. # number of seconds to wait before figuring that the process won't
  64. # give you what you wanted.  (This should have been a parameter to
  65. # expect, but for this round, it's a global for compatibility.)
  66.  
  67. $timeout = 30;
  68.  
  69. # $ret = &expect(HANDLE,PATLIST1,BODY1,PATLIST2,BODY2,...)
  70. # waits until one of the PATLISTn elements matches the output from
  71. # the process attached to HANDLE, then 'eval's the matching BODYn,
  72. # in the context of the caller.
  73. #
  74. # Each PATLIST is a regular-expression (probably enclosed in single-quotes
  75. # in the invocation).  ^ and $ will work, respecting the current value of $*.
  76. # If PATLIST is 'timeout', the BODY is executed if $expect'timeout is
  77. # exceeded.  If PATLIST is 'eof', the BODY is executed if the process
  78. # exits before the other patterns are seen.
  79. #
  80. # PATLISTs are scanned in the order given, so later PATLISTs can contain
  81. # general defaults that won't be examined unless the earlier PATLISTs
  82. # have failed.
  83. #
  84. # The *scalar* result of eval'ing BODY is returned as the result of
  85. # the invocation.  (If you need a list from the BODY, spin it off as
  86. # a side-effect.)  Recursive invocations of &expect are not thought
  87. # through, and may work only accidentally. :-)
  88.  
  89. sub main'expect {
  90.     local($PTY,@case) = @_;
  91.     $PTY =~ s/^[^']+$/"main'".$&/e; # eventually caller()
  92.     local(@casec,$pattern,$action);
  93.     local($rmask,$nfound,$buf,$ret,$nread);
  94.     local($endtime) = time + $timeout;
  95.     local(@incr);
  96.     local($shortkey) = 9999;
  97.     local($meta,$i);
  98.     $match = "";
  99.     @casec = @case;
  100.     @incr[0..255] = ();
  101.     while (@casec) {
  102.         ($pattern,$action) = splice(@casec,0,2);
  103.         ($buf = $pattern) =~ s/\\(\W)//g;
  104.         $meta = $buf =~ /[][()|+*?]/;
  105.         if ($pattern eq 'timeout') {
  106.             next;
  107.         } elsif ($pattern eq 'eof') {
  108.             next;
  109.         } elsif ($meta) {
  110.             @incr = split(//, 1 x 256);
  111.             $shortkey = 1;
  112.         } else {
  113.             $pattern = eval "<<UnLiKeLy\n$pattern\nUnLiKeLy\n"
  114.                 if $pattern =~ m#\\#;
  115.             $shortkey = length($pattern)
  116.                 if $shortkey > length($pattern);
  117.             chop $pattern;
  118.             $i = 1;
  119.                         for (reverse split(//,$pattern)) {
  120.                                 $incr[ord] = $i unless $incr[ord];
  121.                                 $i++;
  122.                         }
  123.         }
  124.         
  125.     }
  126.     $incr[0] = 1;
  127.     for (@incr) {
  128.         $_ = $shortkey unless $_;
  129.     }
  130.     while (1) {
  131.         $rmask = "";
  132.         vec($rmask,fileno($PTY),1) = 1;
  133.         $nread = 0;
  134.         ($nfound, $timeleft) =
  135.              select($rmask,undef,undef,$endtime - time);
  136.         if ($nfound) {
  137.             $buf = ' ' x @incr[ord(substr($match,-1,1))];
  138.             $nread = syscall(3,fileno($PTY),$buf,length($buf));
  139.             # print STDOUT "<$nread " . length($buf) . ">";
  140.             $nread = 0 if $nread < 0; # any I/O err is eof
  141.             substr($buf,$nread,9999) = '';
  142.             $match .= $buf;
  143.             substr($match,0,
  144.                 length($match)-$match_max) = ''
  145.                 if length($match) > $match_max;
  146.             print STDOUT $buf if $log_user;
  147.         }
  148.         @casec = @case;
  149.         while (@casec) {
  150.             ($pattern,$action) = splice(@casec,0,2);
  151.             if ($pattern eq 'timeout') {
  152.                 unless ($nfound) {
  153.                     $ret = eval "package main; $action";
  154.                     # add caller() when available
  155.                     die "$@\n" if $@;
  156.                     return $ret;
  157.                 }
  158.             } elsif ($pattern eq 'eof') {
  159.                 unless ($nread) {
  160.                     $ret = eval "package main; $action";
  161.                     # add caller() when available
  162.                     die "$@\n" if $@;
  163.                     return $ret;
  164.                 }
  165.             } elsif ($match =~ /$pattern/) {
  166.                 $ret = eval "package main; $action";
  167.                 # add caller() when available
  168.                 die "$@\n" if $@;
  169.                 return $ret;
  170.             }
  171.         }
  172.         return undef unless $nread;
  173.     }
  174. }
  175.  
  176. # $ret = &expect_user(PATLIST1,BODY1,PATLIST2,BODY2...)
  177. # invoke &expect on STDIN
  178.  
  179. sub main'expect_user {
  180.     local(@case) = @_;
  181.     local($log_user) = 0; # don't echo user input... let process do that
  182.     &main'expect(STDIN,@case);
  183. }
  184.  
  185. # &interact(...)
  186.  
  187. sub main'interact {
  188.     die "interact NOT IMPLEMENTED"; # it's broke, so far
  189.     local($esc,$spawnid) = @_;
  190.     # hmm.. have to duplicate most of &select here.  not good
  191.     local($imask,$omask) = "";
  192.     local($buf,$nread) = ' ';
  193.     for (STDIN,$spawnid) {
  194.         vec($imask,fileno($_),1) = 1;
  195.     }
  196.     # need to fiddle with STDIN's stty bits now
  197.     while (1) {
  198.         select($omask = $imask, undef, undef, undef);
  199.         if (vec($omask, fileno(STDIN), 1)) {
  200.             # prefer stdin over process
  201.             $nread = syscall(3,fileno(STDIN),$buf,1);
  202.             die "read: $!" if $nread < 0;
  203.             return undef if $nread == 0;
  204.             return $esc if $buf eq $esc;
  205.             &main'send($spawnid,$buf);
  206.         } else {
  207.             $nread = syscall(3,fileno($spawnid),$buf,1);
  208.             die "read: $!" if $nread < 0;
  209.             return undef if $nread == 0;
  210.             &main'send(STDOUT,$buf);
  211.         }
  212.     }
  213. }
  214.  
  215. # &log_file(...)
  216.  
  217. sub main'log_file {
  218.     die "log_file NOT IMPLEMENTED";
  219. }
  220.  
  221. # $expect'log_user:
  222. # set to non-zero to echo the processes STDOUT to this process STDOUT
  223. # while scanning via &expect.  Default is non-zero.
  224.  
  225. $log_user = 1;
  226.  
  227. # &log_user(NEWVAL)
  228. # sets $expect'log_user to NEWVAL
  229.  
  230. sub main'log_user {
  231.     ($log_user) = @_;
  232. }
  233.  
  234. # @handlelist = &select(HANDLE1,HANDLE2,HANDLE3...)
  235. # returns a list of the HANDLEs that can do I/O, or () if none can
  236. # do I/O before $expect'timeout seconds.
  237.  
  238. sub main'select {
  239.     local($rmask) = "";
  240.     local($nfound,$timeleft);
  241.     local(@ret);
  242.     for (@_) {
  243.         s/^[^']+$/"main'".$&/e; # eventually caller()
  244.         vec($rmask,fileno($_),1) = 1;
  245.     }
  246.     ($nfound, $timeleft) =
  247.          select($rmask,undef,undef,$timeout);
  248.     grep(vec($rmask,fileno($_),1),@_);
  249. }
  250.  
  251. # &send(HANDLE,@TEXT);
  252. # sends @TEXT to HANDLE.  May log it too, but logging isn't done yet.
  253.  
  254. sub main'send {
  255.     local($PTY,@args) = @_;
  256.     $PTY =~ s/^[^']+$/"main'".$&/e; # eventually caller()
  257.     print $PTY @args;
  258.     # should this copy STDOUT if $log_user?  dunno yet.
  259. }
  260.  
  261. # &send_error(HANDLE,@TEXT);
  262. # sends @TEXT to STDERR.  May log it too, but logging isn't done yet.
  263.  
  264. sub main'send_error {
  265.     &main'send(STDERR,@_);
  266. }
  267.  
  268. # &send_error(HANDLE,@TEXT);
  269. # sends @TEXT to STDOUT.  May log it too, but logging isn't done yet.
  270.  
  271. sub main'send_user {
  272.     &main'send(STDOUT,@_);
  273. }
  274.  
  275. # $pty = &spawn(HANDLE,PROGRAM,@ARGS)
  276. # starts process PROGRAM with args @ARGS, associating it with a pty
  277. # opened on filehandle HANDLE.  Returns the name of the pty, or undef
  278. # if not successful.
  279.  
  280. sub main'spawn {
  281.     local($PTY,@cmd) = @_;
  282.     $PTY =~ s/^[^']+$/"main'".$&/e; # eventually caller()
  283.     local($TTY) = "__TTY" . time;
  284.     local($pty,$tty) = &_getpty($PTY,$TTY);
  285.     return undef unless defined $pty;
  286.     local($pid) = fork;
  287.     return undef unless defined $pid;
  288.     unless ($pid) {
  289.         close STDIN; close STDOUT; close STDERR;
  290.         setpgrp(0,$$);
  291.         if (open(TTY, "/dev/tty")) {
  292.             ioctl(TTY,0x20007471,0);        # XXX s/b &TIOCNOTTY
  293.             close TTY;
  294.         }
  295.         open(STDIN,"<&$TTY");
  296.         open(STDOUT,">&$TTY");
  297.         open(STDERR,">&STDOUT");
  298.         die "Oops" unless fileno(STDERR) == 2;    # sanity
  299.         close($PTY);
  300.         exec @cmd;
  301.         die "cannot exec @cmd: $!";
  302.     }
  303.     close($TTY);
  304.     $pty;
  305. }
  306.  
  307. # &system(@ARGS)
  308. # just like system(@ARGS)... for compatibility
  309.  
  310. sub main'system {
  311.     system(@_);
  312. }
  313.  
  314. # &trace(...)
  315.  
  316. sub main'trace {
  317.     die "trace NOT IMPLEMENTED";
  318. }
  319.  
  320. # &trap(...)
  321.  
  322. sub main'trap {
  323.     local($cmd,@signals) = @_;
  324.     die "trap NOT IMPLEMENTED";
  325. }
  326.  
  327. # &wait;
  328. # just like wait... for compatibility.
  329.  
  330. sub main'wait {
  331.     wait; # (that's easy. :-)
  332. }
  333.  
  334. # ($pty,$tty) = &expect'_getpty(PTY,TTY):
  335. # internal procedure to get the next available pty.
  336. # opens pty on handle PTY, and matching tty on handle TTY.
  337. # returns undef if can't find a pty.
  338.  
  339. sub _getpty {
  340.     local($PTY,$TTY) = @_;
  341.     # don't adjust $PTY,$TTY with main', but use caller when available
  342.     local($pty,$tty);
  343.     for $bank (112..127) {
  344.         next unless -e sprintf("/dev/pty%c0", $bank);
  345.         for $unit (48..57) {
  346.             $pty = sprintf("/dev/pty%c%c", $bank, $unit);
  347.             # print "Trying $pty\n";
  348.             open($PTY,"+>$pty") || next;
  349.             select((select($PTY), $| = 1)[0]);
  350.             ($tty = $pty) =~ s/pty/tty/;
  351.             open($TTY,"+>$tty") || next;
  352.             select((select($TTY), $| = 1)[0]);
  353.             system "stty nl >$tty";
  354.             return ($pty,$tty);
  355.         }
  356.     }
  357.     undef;
  358. }
  359.  
  360. 1;
  361.