home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 2 / 2052 / expect.pl
Perl Script  |  1990-12-28  |  9KB  |  362 lines
  1. ## expect.pl rev ALPHA.2.01 09-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. undef($spawn_id);
  28. $spawn_id_next = "expect'SPAWN00001";
  29.  
  30. # &close()
  31. # Closes $spawn_id.  may eventually ensure that the process associated
  32. # with $spawn_id is gone, so call this instead of just close().
  33.  
  34. sub main'close {
  35.     close($spawn_id);
  36. }
  37.  
  38. # &debug(...)
  39.  
  40. sub main'debug {
  41.     die "debug NOT IMPLEMENTED";
  42. }
  43.  
  44. # &exit(EXITVAL)
  45. # Calls exit.
  46.  
  47. sub main'exit {
  48.     exit(@_);
  49. }
  50.  
  51. # $expect'match:
  52. # contains the buffer (limited by $expect'match_max) of the most
  53. # recent chars seen in the last &expect call.
  54.  
  55. $match = "";
  56.  
  57. # $expect'match_max:
  58. # don't keep any more than this many characters when scanning for
  59. # an &expect.
  60.  
  61. $match_max = 2000;
  62.  
  63. # $expect'timeout:
  64. # number of seconds to wait before figuring that the process won't
  65. # give you what you wanted.  (This should have been a parameter to
  66. # expect, but for this round, it's a global for compatibility.)
  67.  
  68. $timeout = 30;
  69.  
  70. # $ret = &expect(HANDLE,PATLIST1,BODY1,PATLIST2,BODY2,...)
  71. # waits until one of the PATLISTn elements matches the output from
  72. # the process attached to HANDLE, then 'eval's the matching BODYn,
  73. # in the context of the caller.
  74. #
  75. # Each PATLIST is a regular-expression (probably enclosed in single-quotes
  76. # in the invocation).  ^ and $ will work, respecting the current value of $*.
  77. # If PATLIST is 'timeout', the BODY is executed if $expect'timeout is
  78. # exceeded.  If PATLIST is 'eof', the BODY is executed if the process
  79. # exits before the other patterns are seen.
  80. #
  81. # PATLISTs are scanned in the order given, so later PATLISTs can contain
  82. # general defaults that won't be examined unless the earlier PATLISTs
  83. # have failed.
  84. #
  85. # The *scalar* result of eval'ing BODY is returned as the result of
  86. # the invocation.  (If you need a list from the BODY, spin it off as
  87. # a side-effect.)  Recursive invocations of &expect are not thought
  88. # through, and may work only accidentally. :-)
  89.  
  90. sub main'expect {
  91.     local(@case) = @_;
  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($spawn_id),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($spawn_id),$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(@args) = @_;
  256.     print $spawn_id @args;
  257.     # should this copy STDOUT if $log_user?  dunno yet.
  258. }
  259.  
  260. # &send_error(HANDLE,@TEXT);
  261. # sends @TEXT to STDERR.  May log it too, but logging isn't done yet.
  262.  
  263. sub main'send_error {
  264.     local($spawn_id) = "STDERR";
  265.     &main'send(@_);
  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.     local($spawn_id) = "STDOUT";
  273.     &main'send(@_);
  274. }
  275.  
  276. # $pty = &spawn(PROGRAM,@ARGS)
  277. # starts process PROGRAM with args @ARGS, associating it with a pty
  278. # opened on a new filehandle.  Returns the name of the pty, or undef
  279. # if not successful.
  280.  
  281. sub main'spawn {
  282.     local(@cmd) = @_;
  283.     $spawn_id = $spawn_id_next++;
  284.     local($TTY) = "__TTY" . time;
  285.     local($pty,$tty) = &_getpty($spawn_id,$TTY);
  286.     return undef unless defined $pty;
  287.     local($pid) = fork;
  288.     return undef unless defined $pid;
  289.     unless ($pid) {
  290.         close STDIN; close STDOUT; close STDERR;
  291.         setpgrp(0,$$);
  292.         if (open(TTY, "/dev/tty")) {
  293.             ioctl(TTY,0x20007471,0);        # XXX s/b &TIOCNOTTY
  294.             close TTY;
  295.         }
  296.         open(STDIN,"<&$TTY");
  297.         open(STDOUT,">&$TTY");
  298.         open(STDERR,">&STDOUT");
  299.         die "Oops" unless fileno(STDERR) == 2;    # sanity
  300.         close($spawn_id);
  301.         exec @cmd;
  302.         die "cannot exec @cmd: $!";
  303.     }
  304.     close($TTY);
  305.     $pty;
  306. }
  307.  
  308. # &system(@ARGS)
  309. # just like system(@ARGS)... for compatibility
  310.  
  311. sub main'system {
  312.     system(@_);
  313. }
  314.  
  315. # &trace(...)
  316.  
  317. sub main'trace {
  318.     die "trace NOT IMPLEMENTED";
  319. }
  320.  
  321. # &trap(...)
  322.  
  323. sub main'trap {
  324.     local($cmd,@signals) = @_;
  325.     die "trap NOT IMPLEMENTED";
  326. }
  327.  
  328. # &wait;
  329. # just like wait... for compatibility.
  330.  
  331. sub main'wait {
  332.     wait; # (that's easy. :-)
  333. }
  334.  
  335. # ($pty,$tty) = &expect'_getpty(PTY,TTY):
  336. # internal procedure to get the next available pty.
  337. # opens pty on handle PTY, and matching tty on handle TTY.
  338. # returns undef if can't find a pty.
  339.  
  340. sub _getpty {
  341.     local($PTY,$TTY) = @_;
  342.     # don't adjust $PTY,$TTY with main', but use caller when available
  343.     local($pty,$tty);
  344.     for $bank (112..127) {
  345.         next unless -e sprintf("/dev/pty%c0", $bank);
  346.         for $unit (48..57) {
  347.             $pty = sprintf("/dev/pty%c%c", $bank, $unit);
  348.             # print "Trying $pty\n";
  349.             open($PTY,"+>$pty") || next;
  350.             select((select($PTY), $| = 1)[0]);
  351.             ($tty = $pty) =~ s/pty/tty/;
  352.             open($TTY,"+>$tty") || next;
  353.             select((select($TTY), $| = 1)[0]);
  354.             system "stty nl >$tty";
  355.             return ($pty,$tty);
  356.         }
  357.     }
  358.     undef;
  359. }
  360.  
  361. 1;
  362.