scsh-conservatory
/
scsh-expect
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: scsh-conservatory:main
Branches Tags
scsh-conservatory:main
scsh-conservatory:import-1.1.1
..
compare: scsh-conservatory:import-1.1.1
Branches Tags
scsh-conservatory:main
scsh-conservatory:import-1.1.1

1 Commits
main ... import-1.1

Author SHA1 Message Date
frese aab6155ba8 Initial version, based on Olin's tarball. 2004-07-15 17:34:52 +00:00
20 changed files with 607 additions and 1345 deletions
Show Stats Expand all files Collapse all files

3
AUTHORS
View File

@ -1,3 +0,0 @@
David Fisher
Olin Shivers
David Frese

28
COPYING
View File

@ -1,26 +1,2 @@
Copyright (c) 1998 David Fisher and Olin Shivers
Copyright (c) 2004 David Frese
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the authors may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Designed and implemented by David Fisher and Olin Shivers.
Copyright (C) 1998 by the Scheme Underground.

43
INSTALL
View File

@ -1,43 +0,0 @@
These are generic installation instructions for scsh packages.
Prerequisites
=============
The scsh installation library is required to install this package.
This library *must* be present on your system before the current
package can be installed. It can be obtained from the following Web
page:
http://lamp.epfl.ch/~schinz/scsh_packages/
The installation library comes with its own documentation which
explains in detail how to install and use scsh packages. It is
recommended that you read it before installing your first scsh
package. What follows is a very brief summary of this documentation,
intended to get you started quickly.
Installation
============
Installation of a scsh package is performed by launching the
"scsh-install-pkg" script, which is part of the scsh installation
library. This script must be launched from within the directory which
resulted from the expansion of the current package's archive, i.e. the
one containing the file you are reading now.
A list of all the arguments accepted by the "scsh-install-pkg" script
can be obtained by launching it with the "--help" option. One of these
arguments, "--prefix", is mandatory and specifies the location where
installation should be performed. Ideally, you should use the same
prefix to install all scsh packages, as this makes them easier to
manage and use.
For example, to install the current package in
"/usr/local/share/scsh-modules", you should type the following:
scsh-install-pkg --prefix=/usr/local/share/scsh-modules
Provided that no errors are encountered during installation, a
message will be printed at the end explaining how to use the newly
installed package.

48
Makefile
View File

@ -1,48 +0,0 @@
SHELL = /bin/sh
PKGNAME=scsh-expect
RELEASE=0.1
distname=$(PKGNAME)-$(RELEASE)
distdir = /tmp
DISTFILES=README \
INSTALL \
COPYING \
AUTHORS \
pkg-def.scm \
scheme/interact.scm \
scheme/expect.scm \
scheme/chat.scm \
scheme/packages.scm \
scheme/tty-utils.scm \
doc/chat.doc \
doc/expect.doc \
examples/timed-choice.scm \
examples/ssh-same-path.scm \
examples/ping-and-mail.scm \
.PHONY: dist
dist:
distname=$(distname) && \
distfile=$(distdir)/$$distname.tar.gz && \
if [ -d $(distdir) ] && \
[ -w $$distfile -o -w $(distdir) ]; then \
rm -f $$distname && \
ln -s . $$distname && \
files='' && \
for i in $(DISTFILES); do \
if [ "$$i" != "c/sysdep.h" ]; then \
files="$$files $$distname/$$i"; \
fi \
done && \
tar --exclude .cvsignore --exclude CVS -cf - $$files | \
gzip --best >$$distfile && \
rm $$distname; \
else \
echo "Can't write $$distfile" >&2; \
exit 1; \
fi

20
README
View File

@ -1,18 +1,2 @@
scsh-expect v0.1
* What is scsh-expect?
Scsh-expect is a package for scsh, the Scheme shell that provides
the user with functions and macros similar to the Tcl/Tk extension
Expect. That includes the scripted "talk" with interactive programs,
and thus allows automating the interaction with programs that have
no or poor support for automation.
* How to install?
See the file INSTALL for installation instructions.
* How to use?
Look at the contents of the doc/ directory for a description of the
interfaces.
Designed and implemented by David Fisher and Olin Shivers.
Copyright (C) 1998 by the Scheme Underground.

5
TODO
View File

@ -1,5 +0,0 @@
* INTERACT
- else clause
- string patterns
- regexp patterns

42
doc/chat.doc
View File

@ -1,47 +1,15 @@
-------------------------------------------------------------------------------
(CHAT <task> <body> ...) -> values syntax
(chat <task> <body> ...)
Chat introduces a programmed conversation with a given task. Within
the body expressions, the LOOK-FOR and SEND functions are intended to
either wait for an output of the task, or to send a message to the
task respectively. Furthermore, there are some side-effecting
functions that set some options for this chat.
dynvars: $task $chat-cont $chat-abort-re $chat-timeout
(look-for* re [on-timeout])
(look-for re [<body> ...])
LOOK-FOR waits until a portion of the task's output matches the given
regular expression. The optional second argument of LOOK-FOR*, or the
body expressions in the LOOK-FOR macro, are executed if the output of
the task does not match within the time specified by the CHAT-TIMEOUT
option (see below).
(look-for re [on-timeout ...])
(send fmt arg ...)
(send/cr fmt arg ...)
SEND simply writes a formatted string to the input-port of the task
(see FORMAT). SEND/CR adds a carriage-return character to the end of
the string.
logging output funs?
Side-effecting option setting functions:
side-effecting option setting
(chat-abort <re>)
if this regular expression is matched, the chat call is aborted.
(chat-timeout <nsecs>)
sets the timeout for look-for calls
(chat-monitor <monitor>)
monitor has to be a function taking two arguments (event val),
where event is a symbol, and val a possible value for this
event. The events and the possible type of value are:
- looking-for(re)
- found(match)
- new-input(text)
- sending(text)
- abort(match)
- eof
- timeout
chat can return the following values:
- 'eof
- 'timeout if no timeout-handler was specified in a look-for clause
- <match> in case of an abortion the match of the abort-regexp
- #f if the whole body evaluated normally

94
doc/expect.doc
View File

@ -1,5 +1,5 @@
The Scheme Underground Expect package
Designed and implemented by David Fisher, Olin Shivers and David Frese
Designed and implemented by David Fisher and Olin Shivers
(spawn* THUNK) -> task procedure
@ -42,13 +42,12 @@ in the task:buf field.
<eclause> ::= (<task> <aclause> ...) [Task clause.]
| <option-clause>
| (ON-TIMEOUT <body> ...) [Do on timeout.]
Action clauses:
<aclause> ::= (ON-EOF <body> ...) [Do on EOF.]
| (<pattern> <matchvars> <exp> ...) [Do if pattern matches.]
| (TEST <exp> <body> ...)
| (TEST <exp> => <proc>)
| (ELSE <body> ...)
| (TEST . <cond-clause>)
<matchvars> ::= () [No match info]
| (<matchvar>) [Match struct only]
@ -59,7 +58,6 @@ Action clauses:
| (ECHO <bool>) ; Not supported
| (MAX-SIZE <nchars>) ; Not supported
| (MONITOR <proc>)
| (ON-TIMEOUT <body> ...) [Do on timeout.]
Expect takes a number of tasks, and waits for a number of patterns to
be output by these tasks. When expect sees a pattern for which it has been
@ -72,15 +70,12 @@ where an <option> is one of
before timing out. The lowest timeout clause
determines when the entire expect form will time out.
A timeout value of #f means no timeout. The default
value is 10 seconds.
value is ... seconds.
(MONITOR <proc>) This hook establishes a monitor procedure for the
the expect processing. A monitor is a procedure
of two arguments, that is applied when various
events occur. The second argument specifies the
event that occured for a task, which is passed
as the first argument (expect for the timeout
event which will have #f as the first argument).
of one argument, that is applied when various
events occur:
#F EOF
regexp Match occurred.
string New input arrived.
@ -92,13 +87,6 @@ where an <option> is one of
task's push-back buffer and is not reported.
'timeout EXPECT timed out.
(ON-TIMEOUT <body> ...)
This option specifies a special timeout-handler,
which has to be a function with no arguments,
which is called after the monitor is informed of
the timeout, and whose return value is the
return value of the whole expect call.
An action clause <aclause> can be one of
(<pattern> <matchvars> <body> ...)
If the pattern matches input read from the task, expect binds the
@ -117,9 +105,7 @@ An action clause <aclause> can be one of
is triggered. If EXPECT hits EOF and there is no ON-EOF clause for
the task, nothing happens.
(test <exp> <body> ...)
(test <exp> => <proc>)
(else <body> ...)
(test . COND-CLAUSE)
This allows for general conditionals to be placed into the
EXPECT form.
@ -128,56 +114,26 @@ An action clause <aclause> can be one of
Interact allows the user to interact with a running task, relaying the
keys pressed by the user to the task and outputting the characters
provided by the task to the user. For this purpose interact also turns
the terminal modes for the current input port to raw mode and turns
the echo off. If clauses are provided by the programmer, interact will
filter input before passing it along to the task, or filter output
from the task before showing it to the user. A clause is either a
timeout-clause or a pattern-clause.
provided by the task to the user. If clauses are provided by the
programmer, interact will filter input before passing it along to the
task. A clause is either a character-clause or a filter-clause.
(<character> <continuation-variable> <body> ...)
When interact matches the character, it bind the continuation variable
to the continuation out of the interaction, then evaluates the clause
body.
(TIMEOUT <seconds> <handler>)
If none of the pattern-clauses match within the given number of
seconds, then the handler-procedure is called with a continuation
procedure that can be called to return from the interact-call. If
the continuation is not called, interact continues normally.
(FILTER <procedure>)
Where filter is passed two variables, the character input and the
continuation out of the interaction. In both cases, if the clause
returns true, it falls through to the next clause. If all clauses
fall through, the character is passed on to the task. However, the
continuation still needs to be called in order to break out of the
interaction.
(<pattern> (<flag> ...) (k m ...) <body> ...)
The pattern can either be a character, a string or a regular
expression, although only characters are supported in this
version.
Example: (filter (lambda (c k)
(if
If the pattern matches some portion of the input from
the user or the output of the task, the continuation of the
interact-call is bound to K, M is bound to the matched character,
string or regexp-match object respectively, and if the pattern is
a regexp and more variable names are given, then the correspoding
submatches are bound to these names. Finally the body expressions
are executed. If the continuation is not called, interact
continues normally.
Furhtermore, the pattern can also be the special value
eof-pattern, which make it possible to react to an end-of-file
signal while either reading from the user or reading the output of
the task. In this case M is bound to #f, and the interaction is
not restarted after the body is executed.
Possible flags are:
output The whole pattern should be applied to the output of the
task. If this flag is not present, the pattern is matched
against the user-input.
reset The terminal modes are restored before the body is
executed, and set back to raw when it finishes.
echo The characters that match a pattern, are sent back to the
process that generated them (either the user or the task).
[not implemented]
Example: ((rx "a") () (return m) (display "You pressed a\n"))
(EOF (<flag> ...) <body> ...)
This a shortcut for
(eof-pattern (<flag>) (k m) <body> ...)
-------------------------------------------------------------------------------
(send STRING TASK) -> (undefined) procedure
Send sends the string to the task, as if a user had typed it.
@ -192,7 +148,7 @@ task.
Wait-task waits for the indicated task to complete, reaping the task.
-------------------------------------------------------------------------------
Tty-Utils Package
Tty-Mung Package
(modify-tty-info PROC [PORT]) procedure

423
examples/passwd-wrapper.scm
View File

@ -1,423 +0,0 @@
#!/bin/sh
exec scsh -lel expect/load.scm -lel yp/load.scm -o yp -o threads -o expect -o let-opt -e main -s "$0" "$@"
!#
(define (assq/false key alist)
(let ((p (assq key alist)))
(and p (cdr p))))
;; *** password restrictions *****************************************
(define min-password-length 8)
(define max-password-length 32)
(define min-password-char-classes 2)
(define known-char-sets
(list char-set:lower-case char-set:upper-case
char-set:digit char-set:punctuation))
(define all-char-sets
(cons (char-set-difference
char-set:full
(apply char-set-union known-char-sets))
known-char-sets))
(define (count-char-classes pw)
(apply + (map (lambda (cs)
(if (string-fold
(lambda (c s)
(or s (char-set-contains? cs c)))
#f pw)
1 0))
all-char-sets)))
(define (display-password-too-short)
(display "Password too short (minimum length ")
(display min-password-length)
(display ")")
(newline))
(define (display-password-too-long)
(display "Password too long (maximum length ")
(display max-password-length)
(display ")")
(newline))
(define (display-password-too-few-char-classes)
(display "
New password does not have enough character classes.
The character classes are:
- lower-case letters
- upper-case letters
- digits
- punctuation, and
- all other characters (e.g., control characters).
Please choose a password with at least 2 character classes.")
(newline))
;; *** tty support ***************************************************
;; read string without echoing it
;; optionals arguments:
;; prompt - a string to be display before reading (default none)
;; port - the port to read from (default current-input-port)
(define (read-password . args)
(let-optionals args ((prompt #f)
(port (current-input-port)))
(let* ((tty-before (tty-info port))
(tty-sans-echo (copy-tty-info tty-before)))
(if prompt
(begin
(display prompt)
(force-output (current-output-port))))
(set-tty-info:local-flags
tty-sans-echo (bitwise-and (tty-info:local-flags tty-sans-echo)
(bitwise-not ttyl/echo)))
(set-tty-info/now port tty-sans-echo)
(let ((password (read-line port)))
(set-tty-info/now port tty-before)
(flush-tty/both port)
(newline)
(force-output (current-output-port))
password))))
;; *** supported machines ********************************************
(define (raise-unsupported-machine)
(display "I refuse to run on unsupported machines\n"
(current-error-port))
(exit 10))
(define system-type
(let ((systype (getenv "SYSTYPE")))
(if (not systype)
(error "Cannot determine system type ($SYSTYPE not set)."))
(cond
((string=? systype "sun4x_59") 'solaris)
((string=? systype "i386_fbsd52") 'freebsd)
((string=? systype "i386_rh90") 'linux)
(else (raise-unsupported-machine)))))
;; *** general password interface ************************************
(define (define-passwd program old-prompt new-prompt retype-prompt wrong-message
mismatch-message success-message)
`((program . ,program)
(old-prompt . ,old-prompt)
(new-prompt . ,new-prompt)
(retype-prompt . ,retype-prompt)
(wrong-message . ,wrong-message)
(mismatch-message . ,mismatch-message)
(success-message . ,success-message)))
(define (verify-password spec password)
(call-with-current-continuation
(lambda (return)
(chat (spawn (,(assq/false 'program spec)) (= 2 1))
(chat-abort (rx ,(assq/false 'wrong-message spec)))
(chat-monitor (lambda (event value)
;(format (current-error-port)
; "Event: ~a <~a>\n" event value)
;(force-output (current-error-port))
(case event
((eof timeout abort) (return #f)))))
(look-for (assq/false 'old-prompt spec))
(send/cr password)
(look-for (assq/false 'new-prompt spec))
;; if we are prompted for the new pw, old one was correct
#t))))
(define (change-password spec old-pw new-pw)
(let ((success-message (assq/false 'success-message spec)))
(call-with-current-continuation
(lambda (return)
(chat (spawn (,(assq/false 'program spec)) (= 2 1))
(chat-abort (rx (| ,(assq/false 'mismatch-message spec)
,(assq/false 'wrong-message spec))))
(chat-monitor (lambda (event value)
;(format (current-error-port)
; "Event: ~a <~a>\n" event value)
;(force-output (current-error-port))
(case event
((timeout abort) (return #f))
((eof)
(if success-message
(return #f)
(return #t))))))
(look-for (assq/false 'old-prompt spec))
(send/cr old-pw)
(look-for (assq/false 'new-prompt spec))
(send/cr new-pw)
(look-for (assq/false 'retype-prompt spec))
(send/cr new-pw)
(if success-message
;; if there's gonna be a success-message, wait for it.
(begin (look-for success-message) #t)
;; else wait a bit for errors (#f) or eof (#t)
;; TODO: there is no eof, although program ends
(begin (sleep 2000) #t)))))))
;; *** interface to yppasswd *****************************************
(define (password-stored-in-yp-passwd? user . args)
(let-optionals args
((domain (yp-get-default-domain)))
(let ((splitter (infix-splitter (rx ":"))))
(cond
((yp-match "passwd.byname" user domain)
=> (lambda (entry)
(not (string=? "x" (cadr (splitter entry))))))
(else #f)))))
(define yppasswd
(let ((program "/usr/bin/yppasswd"))
(case system-type
((freebsd) (define-passwd program
"Old Password:"
"New Password:"
"Retype New Password:"
"yppasswd: sorry"
"Mismatch; try again, EOF to quit."
#f))
((solaris) (define-passwd program
"Enter existing login password:"
"New Password: "
"Re-enter new Password: "
"yppasswd: Sorry, wrong passwd"
(rx "passwd(SYSTEM): They don't match.")
"passwd: password successfully changed"))
((linux) (define-passwd program
"Please enter old password:"
"Please enter new password:"
"Please retype new password:"
"Sorry."
"Mismatch - password unchanged."
(rx "The NIS password has been changed on"))))))
(define (verify-yp-password password)
(let ((user-has-yp-password?
(password-stored-in-yp-passwd? (user-login-name))))
(if user-has-yp-password?
(verify-password yppasswd password)
#t)))
(define (change-yp-password old-pw new-pw)
(if (password-stored-in-yp-passwd? (user-login-name))
(change-password yppasswd old-pw new-pw)
#t))
;; *** Kerberos V interface ******************************************
(define kerberos-v
(case system-type
((freebsd) (define-passwd "/afs/wsi/i386_fbsd52/heimdal-1.6/bin/kpasswd"
"Password: "
"New password: "
"Verifying - New password: "
"kpasswd: Password incorrect"
"Verify failure"
"Success"))
((solaris) (define-passwd "/afs/wsi/sun4x_58/krb5-1.3.1/bin/kpasswd"
(rx (: "Password for " (+ (- any #\:)) ": "))
"Enter new password: : "
"Enter it again: : "
"Password incorrect while getting initial ticket"
"Password mismatch while reading password"
"Password changed."))
((linux) (define-passwd "/afs/wsi/i386_rh90/heimdal-0.6/bin/kpasswd"
"Password: "
"New password: "
"Verifying - New password: "
"kpasswd: Password incorrect"
"Verify failure"
"Success"))))
(define kerbv-programs
(case system-type
((freebsd) (cons "/afs/wsi/i386_fbsd52/heimdal-1.6/bin/klist"
"/afs/wsi/i386_fbsd52/heimdal-1.6/bin/kinit"))
((solaris) (cons "/afs/wsi/sun4x_58/heimdal-0.6/bin/klist"
"/afs/wsi/sun4x_58/heimdal-0.6/bin/kinit"))
((linux) (cons "/afs/wsi/i386_rh90/heimdal-0.6/bin/klist"
"/afs/wsi/i386_rh90/heimdal-0.6/bin/kinit"))))
(define (verify-kerbv-password password)
(verify-password kerberos-v password))
(define (change-kerbv-password old-pw new-pw)
(change-password kerberos-v old-pw new-pw))
(define (valid-kerbv-ticket?)
(let* ((klist (car kerbv-programs))
(output (run/string (,klist))))
(not (string-match (rx (| "No ticket file" ">>>Expired<<<")) output))))
;; works for heimdal's kinit program
(define (run-heimdal-kinit program user password)
(call-with-current-continuation
(lambda (return)
(let ((task (spawn (,program ,user) (= 2 1))))
(chat task
(chat-abort (rx "Password incorrect"))
(chat-monitor
(lambda (event value)
(case event
((eof) (return (zero? (wait (task:process task)))))
((timeout abort) (return #f)))))
(look-for (rx (: ,user "@" (+ (- any #\')) "'s Password:")))
(send/cr password)
(look-for (rx (: #\space ,(ascii->char 13) ,(ascii->char 10))))
(look-for (rx (- any any))))))))
(define (get-kerbv-ticket password)
(let ((kinit (cdr kerbv-programs)))
(run-heimdal-kinit kinit (user-login-name) password)))
(define (ensure-kerbv-ticket password)
(or (valid-kerbv-ticket?)
(get-kerbv-ticket password)))
;; *** AFS (Kerberos IV) interface ***********************************
(define afs
(case system-type
((freebsd) (define-passwd "/afs/wsi/i386_fbsd52/openafs-cvs/bin/kpasswd"
"Old password: "
(rx "New password (RETURN to abort): ")
"Retype new password: "
;; Attention: the old password is checked AFTER the
;; new password is entered! So verify will not work!
;; However: changing old-pw to old-pw works fine
"kpasswd: Incorrect old password."
"Mismatch"
"Password changed."))
((solaris) (define-passwd "/afs/wsi/sun4x_58/openafs-1.2.11/bin/kpasswd"
"Old password: "
(rx "New password (RETURN to abort): ")
"Retype new password: "
"kpasswd: Incorrect old password."
"Mismatch"
"Password changed."))
((linux) (define-passwd "/afs/wsi/i386_rh90/openafs-1.2.11/bin/kpasswd"
"Old password: "
(rx "New password (RETURN to abort): ")
"Retype new password: "
;; Attention: the old password is checked AFTER the
;; new password is entered! So verify will not work!
;; However: changing old-pw to old-pw works fine
"kpasswd: Incorrect old password."
"Mismatch"
"Password changed."))))
(define (change-afs-password old-pw new-pw)
(change-password afs old-pw new-pw))
;; *** all together **************************************************
;; also check kerberos and afs password
(define (verify-old-password pw)
(and (verify-yp-password pw)
(verify-kerbv-password pw)
(change-afs-password pw pw)))
(define (change-all-passwords old-pw new-pw)
(if (change-yp-password old-pw new-pw)
(begin
(display "NIS password changed successfully.\n")
;; TODO: make sure we have a ticket
(if (change-kerbv-password old-pw new-pw)
(begin
(display "Kerberos V password changed successfully.\n")
(if (change-afs-password old-pw new-pw)
(display "AFS password changed successfully.\n")
(begin
(display "AFS password could not be changed. Trying to restore old NIS and Kerberos V passwords. This will take some time. Please stand by.\n")
(sleep (* 1000 30))
(if (change-yp-password new-pw old-pw)
(begin
(display "Old NIS password restored.\n")
;; because the Kerberos password needs some
;; minutes to become effective, we also try
;; it with the old password.
(if (or (change-kerbv-password old-pw old-pw)
(change-kerbv-password new-pw old-pw))
(display "Old Kerberos V password restored.\n")
(begin
(display "Old Kerberos V password could not be restored.\n")
#f)))
(begin
(display "Old NIS password could not be restored.\n")
#f)))))
(begin
(display "Kerberos V password could not be changed. Trying to restore old NIS password.\n")
(if (change-yp-password new-pw old-pw)
(display "Old NIS password restored.\n")
(begin
(display "Old NIS password could not be restored.\n")
#f)))))
(display "NIS password could not be changed. No passwords changed.\n")))
(define (ask/check-old-password)
(let ((old-pw-prompt "Old password: "))
(let lp ((old-pw #f))
(let ((pw (read-password old-pw-prompt)))
(cond
((verify-old-password pw)
pw)
(else
(display "Wrong password. Try again.\n")
(force-output)
(lp (read-password old-pw-prompt))))))))
(define (ask-new-password)
(let ((new-pw-prompt-1 "New password: ")
(new-pw-prompt-2 "Retype new password: ")
(no-match "Passwords do not match. Retry."))
(let lp ((pw #f))
(if pw
(if (string=? pw (read-password new-pw-prompt-2))
pw
(begin
(display no-match)
(newline)
(lp #f)))
;; TODO: there are more restrictions concerning 'too similar'!
(let ((pw (read-password new-pw-prompt-1)))
(cond
((< (string-length pw) min-password-length)
(display-password-too-short)
(lp #f))
((> (string-length pw) max-password-length)
(display-password-too-long)
(lp #f))
((< (count-char-classes pw) min-password-char-classes)
(display-password-too-few-char-classes)
(lp #f))
(else
(lp pw))))))))
(define (display-usage)
(display "Usage: passwd-wrapper.scm\n")
(display "Change NIS, Kerberos IV and Kerberos V passwords at once.\n")
(display "Written by Eric Knauel and David Frese.\n"))
(define (main args)
(set-interrupt-handler interrupt/int (lambda a (values)))
(set-interrupt-handler interrupt/term (lambda a (values)))
(set-interrupt-handler interrupt/quit (lambda a (values)))
(if (null? (cdr args))
(case system-type
((freebsd solaris linux)
(let ((old-pw (ask/check-old-password))
(new-pw (ask-new-password)))
(if (not (ensure-kerbv-ticket old-pw))
(display "Cannot get a Kerberos-V ticket, required to change the Kerberos-V password. Use a different machine, or contact your administrator.")
(if (change-all-passwords old-pw new-pw)
(display "Success.\n")
(display "Warning: Your passwords are not consistent anymore. Contact your system administrator.\n")))))
(else
(raise-unsupported-machine)))
(display-usage)))

57
examples/ping-and-mail.scm
View File

@ -1,57 +0,0 @@
#!/bin/sh
exec scsh -lel expect/load.scm -o threads -o expect -o let-opt -e main -s "$0" "$@"
!#
(define *respond-time* 2)
(define *sendmail* "/usr/sbin/sendmail")
(define verbose? #t)
(define (display-mail address dead-hosts)
(display "From: ping-and-mail\n")
(display (format #f "To: ~a\n" address))
(display "Subject: Dead hosts detected\n\n")
(display "The following hosts did not react to a ping within a ")
(display (format #f "period of ~a seconds:" (number->string *respond-time*)))
(display "\n")
(for-each (lambda (s) (display (format #f "~a\n" s))) dead-hosts)
(display ".\n"))
(define (send-mail address dead-hosts)
(wait (fork (lambda ()
(fork/pipe (lambda ()
;; child (stdout)
(display-mail address dead-hosts)))
;; parent (stdin)
(exec-epf (,*sendmail* ,address))))))
(define (dead? host)
(let ((task (spawn (ping -c 1 ,host))))
(let ((res (chat task
(chat-timeout *respond-time*)
(look-for (rx "1 " (* (- any #\,)) "received") #f)
'alive)))
(close-task task)
(not (eq? res 'alive)))))
(define (main args)
(if (or (< (length args) 2) (string=? (cadr args) "--help"))
(display-usage)
(let* ((hosts (cddr args))
(address (cadr args))
(dead (filter (lambda (h)
(let ((d (dead? h)))
(if verbose?
(display (format #f "~a: ~a\n"
h (if d "dead" "alive"))))
d))
hosts)))
(if (not (null? dead))
(begin
(send-mail address dead)
(if verbose?
(display (format #f "Mail sent to ~a\n" address))))
(if verbose?
(display "No hosts dead\n"))))))
(define (display-usage)
(display "Usage: ping-and-mail.scm emailaddress host ...\n"))

85
examples/ssh-same-path.scm
View File

@ -1,85 +0,0 @@
#!/bin/sh
exec scsh -lel expect/load.scm -o threads -o tty-utils -o expect -o let-opt -e main -s "$0" "$@"
!#
;; this script runs the SSH program and passes all it's arguments to
;; it. If ssh asks for a password, this script asks you for it, and
;; passes it to ssh. After logged in successfully, the script tries to
;; change the current directory of the remote shell to the same
;; directory that you were in on the machine running the script. After
;; that you can normally work with the remote shell.
;; TODO:
;; - detect if the arguments for ssh do not cause a log in, like --help ?
;; - detect if machine does not answer
(define *connect-timeout* 5)
(define *prompt-timeout* 3)
(define *prompt-regexp*
(let ((env (getenv "PROMPT_REGEXP")))
(or env
(rx (+ ,(char-set-difference char-set:full
(string->char-set " ")))
"[" (* any) "] "))))
(define (main args)
(let ((dir (cwd))
(user-out (current-output-port))
(user-in (current-input-port))
(task (spawn (ssh . ,(cdr args)))))
(chat task
(chat-monitor (lambda (ev msg)
(cond
((eq? ev 'abort)
(if (task:pre-match task)
(write-string (task:pre-match task) user-out))
(write-string (match:substring msg) user-out)
(write-string (task:buf task) user-out))
((eq? ev 'timeout)
(if (task:pre-match task)
(write-string (task:pre-match task) user-out))
(write-string (task:buf task) user-out)))))
(chat-abort *prompt-regexp*)
(let lp ((first? #t))
(chat-timeout (if first?
*connect-timeout*
*prompt-timeout*))
(look-for "Password:")
(if (not first?)
(display "Incorrect password. Try again.\n" user-out))
(let ((pw (read-password "Password: "
user-in user-out)))
(send/cr pw)
(lp #f))))
(tsend/cr task (string-append "cd " dir))
(interact task)))
;; read string without echoing it
;; optionals arguments:
;; prompt - a string to be display before reading (default none)
;; inport - the port to read from (default current-input-port)
;; outport - the port to write to (default current-output-port)
(define (read-password . args)
(let-optionals args ((prompt #f)
(inport (current-input-port))
(outport (current-output-port)))
(let* ((tty-before (tty-info inport))
(tty-sans-echo (copy-tty-info tty-before)))
(if prompt
(begin
(display prompt outport)
(force-output outport)))
(set-tty-info:local-flags
tty-sans-echo (bitwise-and (tty-info:local-flags tty-sans-echo)
(bitwise-not ttyl/echo)))
(set-tty-info/now inport tty-sans-echo)
(let ((password (read-line inport)))
(set-tty-info/now inport tty-before)
(flush-tty/both inport)
(newline outport)
(force-output outport)
password))))

37
examples/timed-choice.scm
View File

@ -1,37 +0,0 @@
#!/bin/sh
exec scsh -lel expect/load.scm -o expect -o srfi-13 -e main -s "$0" "$@"
!#
(define (display-usage)
(display "Usage: timed-choice.scm timeout query choices...\n")
(display "Provides a query of the user with a timeout and a default answer.\n"))
(define (raise-too-few-arguments)
(display "timed-choice.scm: too few arguments\n")
(display-usage)
(exit))
(define (main args)
(if (< (length args) 4)
(raise-too-few-arguments))
(let ((timeout (string->number (second args)))
(query (third args))
(choices (cdddr args)))
(let ((default (car choices))
(pattern (re-choice (map re-string choices))))
(display (format #f "~a [~a] " query (string-join choices ", ")))
(display
(expect loop ()
(option (timeout timeout)
(on-timeout default))
((user-task)
((rx (: bos ,pattern (| "\n" "\r\n"))) (m)
(match:substring m))
((rx (: bos (| "\n" "\r\n"))) ()
(string-append default "\n"))
(else
(display (format #f "Please enter one of the choices: ~a.\n"
(string-join choices ", ")))
(loop)))))
;;(newline)
)))

12
pkg-def.scm
View File

@ -1,12 +0,0 @@
(define-package "expect" (0 1)
((install-lib-version (1 1)))
(install-file "COPYING" 'doc)
(install-file "README" 'doc)
(install-directory-contents "doc" 'doc)
(write-to-load-script
`((config)
(load ,(absolute-file-name "packages.scm"
(get-directory 'scheme #f)))))
(install-directory-contents "scheme" 'scheme))

21
scheme/chat.scm
View File

@ -60,18 +60,19 @@
(expect (option (timeout tmout) ; Timeout in $chat-timeout secs.
(monitor (if cmon
(chat->expect-monitor cmon)
(lambda (task event) #f))) ; No-op
;; Timeout => Call handler or abort.
(on-timeout (if (pair? maybe-on-timeout)
((car maybe-on-timeout))
(chat-cont 'timeout))))
(lambda (task event) #f)))) ; No-op
;; Expect triggers the monitor for us on timeout.
(on-timeout (if (pair? maybe-on-timeout) ; Timeout =>
((car maybe-on-timeout)) ; Call handler or
(chat-cont 'timeout))) ; abort.
(task (re (m) ; See RE => return false.
(if cmon (cmon 'found m))
#f)
(abort-re (m) ; See $chat-abort-re =>
(if cmon (cmon 'abort m)) ; abort & return the
(chat-cont m)) ; abort string.
(abort-re (#f s) ; See $chat-abort-re =>
(if cmon (cmon 'abort #f)) ; abort & return the
(chat-cont s)) ; abort string.
(on-eof
;; EXPECT triggers the monitor for us.
@ -90,7 +91,7 @@
;;; - found(match)
;;; - new-input(text)
;;; - sending(text)
;;; - abort(text)
;;; - abort
;;; - eof
;;; - timeout
@ -116,7 +117,7 @@
((sending) (format port "send(~a)\n" val))
((eof) (write-string "EOF encountered.\n" port))
((timeout) (write-string "-- timed out. \n" port))
((abort) (format port "-- aborting(~a). \n" val))
((abort) (write-string "-- aborting. \n" port))
(else (format port "Unknown chat event: ~a ~a\n" event val)))
(force-output port)))

288
scheme/expect-syntax.scm Normal file
View File

@ -0,0 +1,288 @@
;;; The EXPECT macro expander
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define syntax-error (structure-ref signals error))
;;; LET*, except that you can use multiple-value expressions in the binding
;;; forms. MLET = "M ultiple-value LET." I use this to keep the very long
;;; expect-expander code from drifting off the right side of the screen.
(define-syntax mlet
(syntax-rules ()
((mlet () body ...) (begin body ...))
;; Hack -- If a clause binds 0 vals, we *ignore* its return vals.
;; We don't require it to return exactly 0 vals.
((mlet ((() exp) init ...) body ...)
(begin exp (mlet (init ...) body ...)))
((mlet (((v ...) exp) init ...) body ...)
(receive (v ...) exp
(mlet (init ...) body ...)))
((mlet ((v exp) init ...) body ...)
(let ((v exp)) (mlet (init ...) body ...)))))
(define (filter pred lis)
(if (pair? lis)
(let ((x (car lis)))
(if (pred x) (cons x (filter pred (cdr lis)))
(filter pred (cdr lis))))
'()))
(define (partition pred lis)
(if (pair? lis)
(let ((x (car lis)))
(receive (ins outs) (partition pred (cdr lis))
(if (pred x)
(values (cons x ins) outs)
(values ins (cons x outs)))))
(values '() '())))
;;; This is a hairy mother. If you ever try to read it or change it, you are
;;; advised to first try expanding a couple of toy examples and looking at the
;;; output to get a feel for the basic compilation strategy.
(define (expand-expect exp r c)
(mlet (((exp-name loop-var-inits clauses) ; Parse out the loop name
(if (and (<= 3 (length exp)) ; and var inits, if any.
(not (pair? (cadr exp))))
(values (cadr exp) (caddr exp) (cdddr exp)) ; Yep.
(values #f '() (cdr exp)))) ; Nope.
;; Parse the clauses into task clauses, a list of options,
;; and 0 or 1 on-timeout clauses.
((task-clauses options timeout-clauses)
(let recur ((clauses clauses))
(if (pair? clauses)
(let ((clause (car clauses)))
(receive (t o to) (recur (cdr clauses))
(cond ((not (pair? clause))
(syntax-error "Bad EXPECT clause" clause))
((c (car clause) (r 'option))
(values t (append (cdr clause) o) to))
((c (car clause) (r 'on-timeout))
(if (null? to)
(values t o (cons (cdr clause) to))
(syntax-error "Too many ON-TIMEOUT clauses in EXPECT" exp)))
;; It's a task clause.
(else (values (cons clause t) o to)))))
(values '() '() '()))))
;; Parse each task clause into three parts: the task expression, the
;; pattern/action aclauses, and 0 or 1 ON-EOF aclauses.
((tasks pa-clauses-list eof-clauses)
(let recur ((clauses task-clauses))
(if (pair? clauses)
(let* ((clause (car clauses))
(task (car clause))
(aclauses (cdr clause)))
(receive (tasks pas eofs) (recur (cdr clauses))
(receive (this-tasks-eofs this-tasks-pas)
(partition (lambda (ac)
(if (pair? ac)
(c (car ac) (r 'on-eof))
(syntax-error "Bad action clause in EXPECT"
clause ac)))
aclauses)
(if (> (length this-tasks-eofs) 1)
(syntax-error "Too many ON-EOF action clauses in EXPECT"
clause)
(values (cons task tasks)
(cons this-tasks-pas pas)
(cons this-tasks-eofs eofs))))))
(values '() '() '()))))
(%vector (r 'vector)) ; Bind a mess of syntax
(%lambda (r 'lambda))
(%let (r 'let))
(%let* (r 'let*))
(%letrec (r 'letrec))
(%begin (r 'begin))
(%and (r 'and))
(%string-match (r 'string-match))
(%vector (r 'vector))
(%let-match (r 'let-match))
(%s (r 's))
(%i (r 'i))
(%m (r 'm))
(%monitor (r 'mon))
(%do-next (r 'do-next))
(%do-match-hacking (r 'do-match-hacking))
(%do-select (r 'do-select))
(%=> (r '=>))
(%test (r 'test))
(%else (r 'else))
(%cond (r 'cond))
(%try-task (r 'try-task))
(%task:buf (r 'task:buf))
(%task:in (r 'task:in))
(%set-prematch (r 'set-prematch))
(%first-try (r 'first-try))
(%time (r 'time))
(%receive (r 'receive))
(%select! (r 'select!))
(%if (r 'if))
(%- (r '-))
(%+ (r '+))
(%> (r '>))
;; Now we need a bunch of label names. Task clause #3 needs
;; try-task3, task3, try-match3, and maybe do-eof3 (if it has
;; an ON-EOF action clause)
(task-indices (let recur ((tclauses task-clauses) (i 0))
(if (pair? tclauses)
(cons i (recur (cdr tclauses) (+ i 1)))
'())))
(vari (lambda (s i)
(r (string->symbol (string-append s (number->string i))))))
(try-task-vars (map (lambda (i) (vari "try-task" i)) task-indices))
(task-vars (map (lambda (i) (vari "task" i)) task-indices))
(try-match-vars (map (lambda (i) (vari "try-match" i)) task-indices))
(do-eof-vars (map (lambda (i maybe-eof-clause)
;; #F if the tclause doesn't have an ON-EOF aclause.
(and (pair? maybe-eof-clause)
(vari "do-eof" i)))
task-indices eof-clauses))
;; do-next[i] is the proc task I should call to
;; do the next thing.
(do-nexts (append (cdr try-task-vars)
(list %do-select)))
;; Build a bunch of LET bindings.
;; First, evaluate and bind all the tasks.
(task-bindings (map list task-vars tasks))
;; Bind IVEC to the task vector.
(ivec (r 'ivec))
(ivec-binding `(,ivec (,%vector ,@(map (lambda (tv) `(,%task:in ,tv))
task-vars))))
;; Build a bunch of LETREC bindings.
;; First, the do-eof bindings.
(do-eofs1 (map (lambda (label bodies) ; (length BODIES) < 2.
(and (pair? bodies)
`(,label (,%lambda () . ,(cdar bodies)))))
do-eof-vars eof-clauses))
(do-eofs (filter (lambda (x) x) do-eofs1))
;; Second, the try-matchI bindings.
(pa->cond-clause (lambda (pa-clause task)
(if (c (car pa-clause) %test)
(cdr pa-clause)
`((,%string-match ,(car pa-clause) ,%s) ,%=>
(,%lambda (,%m)
(,%do-match-hacking ,task ,%m ,%s ,%i ,%monitor)
(,%let-match ,%m . ,(cdr pa-clause)))))))
(try-matcher (lambda (pa-clauses task)
`(,%lambda (,%s ,%i ,%do-next)
(,%cond ,@(map (lambda (pa)
(pa->cond-clause pa task))
pa-clauses)
(,%else (,%monitor ,task ,%i)
(,%do-next))))))
(try-matches (map (lambda (label task pa-clauses)
`(,label ,(try-matcher pa-clauses task)))
try-match-vars
task-vars
pa-clauses-list))
;; Third, the try-taskI bindings
(try-tasks (map (lambda (label task i match-tryer
do-next do-eof)
`(,label (,%lambda ()
(,%try-task ,ivec ,i ,task ,match-tryer
,do-next
,(or do-eof do-next)
,%monitor))))
try-task-vars task-vars task-indices
try-match-vars do-nexts do-eof-vars))
;; When EXPECT starts, there may be leftover data sitting in
;; the task buffers from a previous EXPECT execution (too bad
;; we don't have infinite push-back ports). So we have to run
;; all the pattern/action match code before doing the select
;; call, or trying to do input. This expression is the code
;; that does this. If there *isn't* any saved-up input in a
;; task's push-back buffer, we don't call the task's try-match
;; proc.
(initial-trymatch
(let recur ((try-matchers try-match-vars)
(tasks task-vars))
(if (pair? try-matchers)
(let ((try-match (car try-matchers))
(try-matchers (cdr try-matchers))
(task (car tasks))
(tasks (cdr tasks)))
`(,%first-try ,task ,try-match
(,%lambda () ,(recur try-matchers tasks))))
`(,%do-select))))
;; Parse the options
((timeout-secs mon-exp)
(let lp ((timeout-secs 10) (mon-exp (r 'null-monitor))
(opts options))
(if (pair? opts)
(let ((opt (car opts))
(opts (cdr opts)))
(if (or (not (pair? opt))
(not (= (length opt) 2)))
(syntax-error "Illegal EXPECT option" opt))
(let ((kw (car opt)))
(cond ((c kw (r 'timeout))
(lp (cadr opt) mon-exp opts))
((c kw (r 'monitor))
(lp timeout-secs (cadr opt) opts))
(else (syntax-error "Illegal EXPECT option" opt)))))
(values timeout-secs mon-exp))))
;; Build the select code.
;; The TIME-DONE var is bound to "what time we time out",
;; not "how many seconds until we time out."
(timeout-var (and timeout-secs (r 'time-done)))
(loop-top `(,%lambda ()
(,%receive (in out ex)
(,%select! ,ivec '#() '#()
,@(if timeout-var
`((,%and ,timeout-var
(,%- ,timeout-var (,%time))))
'()))
(,%if (,%> in 0)
(,(car try-task-vars))
,(if (pair? timeout-clauses)
`(,%begin ,@(car timeout-clauses))
''timeout)))))
;; This is the core letrec -- the wait-for-input &
;; try-to-match loop.
(inner-loop `(,%letrec (,@do-eofs
,@try-matches
,@try-tasks
(,%do-select ,loop-top))
,initial-trymatch))
;; This is the outer, named loop (if any).
(named-loop (if exp-name
`(,%let ,exp-name ,loop-var-inits
,inner-loop)
inner-loop)))
;; Build the final expression.
`(,%let* (,@task-bindings
,ivec-binding
(,%monitor ,mon-exp)
,@(if timeout-var
`((,timeout-var ,timeout-secs)
(,timeout-var (,%and ,timeout-var
(,%+ (,%time) ,timeout-var))))
'())) ; No timeout-var binding needed.
,named-loop)))

402
scheme/expect.scm
View File

@ -6,47 +6,39 @@
;;; - Fairness & round-robin looping
;;; - If all tasks eof, should we detect this and bail out early?
;;; - I need a little toolkit for constructing monitors.
;;; - A wrapper that gives a spawned process a tty with the same
;;; options as the current tty.
;;; If I had infinite-pushback ports, I could flush the "task" structure
;;; entirely. This would be better done with a transducer architecture.
;;; Interact
;;; - -nobuffer is useful for spotting stuff as it flies by.
;;; - It can handle matching in both directions.
;;; - It can handle strings and regexps.
;;; This file contains the following Scheme 48 modules:
;;; - expect-syntax-support
;;; This package must be opened in expect-package's FOR-SYNTAX package,
;;; so that the EXPECT macro-expander code can use its procedure.
;;; - expect-package
;;; This package must be opened by expect's clients.
(define error (structure-ref signals error))
(define-syntax expect expand-expect)
;;; A task is a guy with whom we can interact.
(define-record-type task
(really-make-task process in out buf pre-match)
task?
(process task:process)
(in task:in)
(out task:out)
(buf task:buf set-task:buf!)
(pre-match task:pre-match set-task:pre-match!) ;; Everything before
;; the current match.
)
(define (make-task process in out)
(really-make-task process in out "" #f))
;;; Wait written for tasks.
(define (wait-task task) (wait (task:process task)))
;;; Close all ports associated with a task.
(define (close-task task)
(close (task:out task))
(close (task:in task)))
(define-record task
process
in
out
(buf "")
(pre-match #f)) ; Everything before the current match.
(define (tsend task fmt . args)
(apply format (task:out task) fmt args))
(define tsend/cr
(define tsend-line
(let ((cr (string-ref "\r" 0))) ; Ugh
(lambda (task fmt . args)
(let ((p (task:out task)))
@ -88,6 +80,121 @@
(close (task:in task))
(close (task:out task)))
;;;; Append info to a buffer without its going over the max size.
;;;; As data is moved out of the match buffer, it is moved into
;;;; the pre-match buffer.
;;;;
;;;; Ack, this is not too efficient. Need to change this whole style.
;
;(define (buf-append task str max-size)
; (let* ((buf (task:buf task))
; (buf-size (string-length buf))
; (str-size (string-length str))
; (total-size (+ buf-size str-size)))
;
; (cond ((<= total-size max-size) ; BUF := all of BUF + all of STR.
; (string-append buf str))
;
; ;; BUF := some of BUF + all of STR.
; ((<= str-size max-size)
; (let ((i (- total-size max-size)))
; (set-task:pre-match (string-append (task:pre-match task)
; (substring buf 0 i)))
; (string-append (substring buf i buf-size)
; str)))
;
; ;; BUF := some of STR.
; (else (let ((i (- str-size max-size)))
; (set-task:pre-match (string-append (task:pre-match task)
; buf
; (substring str 0 i)))
; (substring str i str-size))))))
;;; We just matched M out of BUFFER.
;;; - Put everything in BUFFER *before* the match into (TASK:PRE-MATCH TASK).
;;; - Put everything in BUFFER *after* the match into (TASK:BUF TASK).
(define (set-prematch task buffer m)
(set-task:pre-match task (substring buffer 0 (match:start m)))
(set-task:buf task
(substring buffer (match:end m) (string-length buffer))))
;;; Slurp in data from port ivec[i] and add it to the task's buffer.
;;; Return the new data (not the whole buffer).
;;; If we get EOF instead, set ivec[i] to #f and return false. This is
;;; really inefficient in space and time -- every time we get a little bit
;;; of input, we copy and throw away the whole match buffer. Argh.
(define (do-input task)
(let* ((port (task:in task))
;; If the read blows up, return #f. This is how tty's indicate
;; to pty's they've been closed. Ugh.
(s (with-errno-handler ((e p) ((errno/io) #f))
(read-string/partial 256 port))))
(and s (let ((newbuf (string-append (task:buf task) s)))
(set-task:buf task newbuf)
s))))
;;; A (<task> <aclause> ...) task-clause becomes the following chunk of code
;;; that is executed after the select call on ivec[]. I is the index of
;;; <task>'s input port in the port vector ivec:
;;;
;;; If ivec[i] is non-#f
;;; -- Select says there's input available.
;;; Get input from task
;;; If EOF
;;; ivec[i] := #f (This task is now permanently out of the running.)
;;; If there's an ON-EOF clause, do it and quit.
;;; If no ON-EOF clause, go on to task i+1.
;;; else we got some data:
;;; Try out matches. On match, do the match action & we are done.
;;; If no match, go on to task i+1
;;;
;;; If ivec[i] is #f
;;; -- No input available right now.
;;; ivec[i] := taski.in (Put the input port back in the vector)
;;; go on to task i+1
;;;
;;; "go on to task i+i" means "loop back to the select call" when task i
;;; is the last one.
(define (try-task ivec i task try-match-clauses do-next do-eof monitor)
(if (vector-ref ivec i)
;; Input is available (or EOF). Read it in.
;; If we get some, try out the pattern/action clauses.
;; If we get EOF, do the EOF action (which is the ON-EOF action clause,
;; if there is one, or go on to the next task clause if there isn't).
(cond ((do-input task) =>
(lambda (i) (try-match-clauses (task:buf task) i do-next)))
(else
(set-task:pre-match task (task:buf task))
(set-task:buf task "")
(monitor task #f) ; Signal EOF
(do-eof)
(vector-set! ivec i #f)))
;; No input available for task i. Put it back in the select vector
;; for next time, and go on to the next thing.
(begin (vector-set! ivec i (task:in task))
(do-next))))
;;; M is the match. S is the total string. I is the new data that just
;;; arrived -- a non-empty suffix of S.
(define (do-match-hacking task m s i monitor)
;; Log all new data up to the match.
(let* ((delta (- (string-length s) (string-length i)))
(mend (- (match:end m 0) delta)))
(monitor task (substring i 0 mend))
(monitor task m))
(set-prematch task s m)) ; Set the prematch buffer.
;;; The default monitor -- does nothing.
(define (null-monitor task event) #f)
@ -158,244 +265,3 @@
(let ((s (task:buf task)))
(if (zero? (string-length s)) (otherwise)
(tm s s otherwise))))
;;; expect functional interface
(define *default-timeout* 10)
(define *default-echo* #f)
(define *default-max-size* #f)
(define (in-select! rvec timeout)
(receive (in out ex)
(select! rvec '#() '#() timeout)
(not (zero? in))))
;; pattern: (match (lambda () regexp) (lambda (match) ...))
;; or (eof (lambda () ...))
;; or (test (lambda () #t/#f) (lambda (v) ...))
;; or (else (lambda () ...)) ; else
(define (expect* options . tasks-patterns-alist)
(let ((monitor (cond
((assq 'monitor options) => cdr)
(else null-monitor)))
(on-timeout (cond
((assq 'on-timeout options) => cdr)
(else (lambda () #f))))
(timeout (cond
((assq 'timeout options) => cdr)
(else *default-timeout*)))
(echo (cond
((assq 'echo options) => cdr)
(else *default-echo*)))
(max-size (cond
((assq 'max-size options) => cdr)
(else *default-max-size*))))
(expect-1* on-timeout monitor timeout echo max-size tasks-patterns-alist)))
;;; Slurp in data from port and add it to the task's buffer. Return
;;; the new data (not the whole buffer). If we get EOF instead, set
;;; ivec[i] to #f and return false. This is really inefficient in
;;; space and time -- every time we get a little bit of input, we copy
;;; and throw away the whole match buffer. Argh.
(define (do-input task)
(let* ((port (task:in task))
;; If the read blows up, return #f. This is how tty's indicate
;; to pty's they've been closed. Ugh.
(s (with-errno-handler ((e p) ((errno/io) #f))
(read-string/partial 256 port))))
(and s (let ((newbuf (string-append (task:buf task) s)))
(set-task:buf! task newbuf)
s))))
;;; We just matched M out of BUFFER.
;;; - Put everything in BUFFER *before* the match into (TASK:PRE-MATCH TASK).
;;; - Put everything in BUFFER *after* the match into (TASK:BUF TASK).
(define (set-prematch task buffer m)
(set-task:pre-match! task (substring buffer 0 (match:start m)))
(set-task:buf! task
(substring buffer (match:end m) (string-length buffer))))
(define (handle-input task patterns input do-next monitor)
(let ((s (task:buf task)))
(let loop ((patterns patterns))
(if (null? patterns)
(do-next)
(let ((pattern (car patterns)))
(case (car pattern)
((match)
(let ((m (string-match ((cadr pattern)) s)))
(if m
;; Log all new data up to the match.
(let* ((delta (- (string-length s)
(string-length input)))
(mend (- (match:end m 0) delta)))
(monitor task (substring input 0 mend))
(monitor task m)
;; Set the prematch buffer.
(set-prematch task s m)
((caddr pattern) m))
(loop (cdr patterns)))))
((eof) (loop (cdr patterns)))
((test)
(let ((v ((cadr pattern))))
(if v
((caddr pattern) v)
(loop (cdr patterns)))))
((else)
((cadr pattern)))
(else (error "undefined pattern type" (car pattern)))))))))
(define (handle-eof task patterns do-next monitor)
(set-task:pre-match! task (task:buf task))
(set-task:buf! task "")
(monitor task #f)
(let loop ((patterns patterns))
(if (null? patterns)
(do-next)
(let ((pattern (car patterns)))
(case (car pattern)
((eof) ((cadr pattern)))
((match test else) (loop (cdr patterns)))
(else (error "undefined pattern type" (car pattern))))))))
(define (handle-timeout monitor on-timeout)
(monitor #f 'timeout)
(on-timeout))
(define (expect-1* on-timeout monitor timeout echo max-size
tasks-patterns-alist)
;; first check existing data in the buffers
(let loop ((f-tasks-patterns-alist tasks-patterns-alist))
(if (not (null? f-tasks-patterns-alist))
(let* ((task-patterns (car f-tasks-patterns-alist))
(task (car task-patterns))
(s (task:buf task)))
(if (not (zero? (string-length s)))
(handle-input task (cdr task-patterns) s
(lambda () (loop (cdr f-tasks-patterns-alist)))
monitor)
(loop (cdr f-tasks-patterns-alist))))
;; start looking for input, handle it and throw away those
;; that got eof
(let loop ((tasks-patterns-alist tasks-patterns-alist))
(if (null? tasks-patterns-alist)
#f ;; all eof
(let ((ivec (list->vector (map (lambda (task-patterns)
(task:in (car task-patterns)))
tasks-patterns-alist))))
;; what is this (time) thing in the original?
(if (not (in-select! ivec timeout))
(handle-timeout monitor on-timeout)
(let iloop ((inports (vector->list ivec))
(tasks-patterns-alist tasks-patterns-alist)
(remaining '()))
(if (null? tasks-patterns-alist)
(loop (reverse remaining))
(if (car inports)
(let* ((task-patterns (car tasks-patterns-alist))
(task (car task-patterns))
(s (do-input task)))
(if s
(handle-input task (cdr task-patterns) s
(lambda ()
(iloop (cdr inports)
(cdr tasks-patterns-alist)
(cons task-patterns
remaining)))
monitor)
(handle-eof task (cdr task-patterns)
(lambda ()
(iloop (cdr inports)
(cdr tasks-patterns-alist)
remaining))
monitor)))
(iloop (cdr inports)
(cdr tasks-patterns-alist)
(cons (car tasks-patterns-alist)
remaining))))))))))))
;; Syntax based on procedural interface
;; TODO: better error recognition/messages
(define-syntax expect-options-clauses
(syntax-rules (on-timeout timeout echo max-size monitor)
((expect-options-clauses)
'())
((expect-options-clauses (on-timeout body ...) clause ...)
(cons (cons 'on-timeout (lambda () body ...))
(expect-options-clauses clause ...)))
((expect-options-clauses (timeout v) clause ...)
(cons (cons 'timeout v)
(expect-options-clauses clause ...)))
((expect-options-clauses (echo v) clause ...)
(cons (cons 'echo v)
(expect-options-clauses clause ...)))
((expect-options-clauses (max-size v) clause ...)
(cons (cons 'max-size v)
(expect-options-clauses clause ...)))
((expect-options-clauses (monitor proc) clause ...)
(cons (cons 'monitor proc)
(expect-options-clauses clause ...)))
((expect-options-clauses x clause ...)
(expect-options-clauses clause ...))))
(define-syntax expect-action-clauses
(syntax-rules (on-eof test => else)
((expect-action-clauses)
'())
((expect-action-clauses (on-eof body ...) clause ...)
(cons (list 'eof
(lambda () body ...))
(expect-action-clauses clause ...)))
((expect-action-clauses (test exp body ...) clause ...)
(cons (list 'test
(lambda () exp)
(lambda (_) body ...))
(expect-action-clauses clause ...)))
((expect-action-clauses (test exp => proc) clause ...)
(cons (list 'test
(lambda () exp)
(lambda (v) (proc v)))
(expect-action-clauses clause ...)))
((expect-action-clauses (else body ...) clause ...)
(cons (list 'else (lambda () body ...))
(expect-action-clauses clause ...)))
((expect-action-clauses (pattern () body ...) clause ...)
(expect-action-clauses (pattern (ignore) body ...) clause ...))
((expect-action-clauses (pattern (m mvars ...) body ...) clause ...)
(cons (list 'match (lambda () pattern)
(lambda (m)
(let-match m (mvars ...) body ...)))
(expect-action-clauses clause ...)))))
(define-syntax expect-clauses
(syntax-rules (option)
((expect-clauses)
(cons '() '()))
((expect-clauses (option oclause ...) clause ...)
(let ((res (expect-clauses clause ...)))
(cons (append (expect-options-clauses oclause ...) (car res))
(cdr res))))
((expect-task-clauses (task aclause ...) clause ...)
(let ((res (expect-clauses clause ...)))
(cons (car res)
(cons (cons task (expect-action-clauses aclause ...))
(cdr res)))))))
(define-syntax expect
(syntax-rules ()
((expect (x ...) eclause ...)
(let ((r (expect-clauses (x ...) eclause ...)))
(apply expect* (car r) (cdr r))))
((expect name (var-inits ...) eclause ...)
(let name (var-inits ...)
(let ((r (expect-clauses eclause ...)))
(apply expect* (car r) (cdr r)))))))

135
scheme/interact.scm
View File

@ -1,135 +0,0 @@
;; The pattern eof introduces an action that is executed upon end-
;; of-file. A separate eof pattern may also follow the -output flag
;; in which case it is matched if an eof is detected while writing
;; output. The default eof action is "return", so that interact
;; simply returns upon any EOF.
;; The pattern timeout introduces a timeout (in seconds) and action
;; that is executed after no characters have been read for a given
;; time.
;; The -echo flag sends characters that match the following pattern
;; back to the process that generated them as each character is read.
;; This may be useful when the user needs to see feedback from
;; partially typed patterns.
;; The -nobuffer flag sends characters that match the following pat-
;; tern on to the output process as characters are read.
(define-record-type :eof-pattern
(make-eof-pattern)
eof-pattern?)
(define eof-pattern (make-eof-pattern))
(define (interact* task re-flags-handler-list timeout-handler)
(let* ((user-in (current-input-port))
(user-out (current-output-port))
(user-task (user-task))
(tty-before (tty-info user-in))
(init-tty (lambda ()
(set! tty-before (tty-info user-in))
(modify-tty (lambda (ti) (raw (echo-off ti))) user-in)))
(reset-tty (lambda ()
(set-tty-info/now user-in tty-before))))
;; TODO: if no tty??
(init-tty)
(call-with-current-continuation
(lambda (k)
(let ((conv
(lambda (loop)
(lambda (re-flags-handler)
(let* ((re (car re-flags-handler))
(re (cond
((string? re) (rx ,re))
((char? re) (rx ,(make-string 1 re)))
(else re)))
(flags (cadr re-flags-handler))
(handler (caddr re-flags-handler))
(before (lambda ()
(if (memq 'reset flags) (reset-tty))))
(after (lambda ()
(if (memq 'reset flags) (init-tty)))))
(cond
((eq? eof-pattern re)
(list 'eof
(lambda ()
(before)
(handler k #f)
(after))))
(else
(list 'match
(lambda () re)
(lambda (m)
(before)
(handler k m)
(after)
(loop))))))))))
(let-values (((outputs inputs)
(partition (lambda (re-flag-handler)
(memq 'output (second re-flag-handler)))
re-flags-handler-list)))
(let ((output-else-rx (else-rx (map car outputs)))
(input-else-rx (else-rx (map car inputs))))
(let loop ()
(let ((timeout (if timeout-handler
(list (cons 'timeout (car timeout-handler))
(cons 'on-timeout
(lambda ()
((cdr timeout-handler) k)
(loop))))
'((timeout . #f)))))
(expect* timeout
(cons user-task
(cons (list 'match (lambda () input-else-rx)
(lambda (m)
(write-string (match:substring m)
(task:out task))
(loop)))
(map (conv loop) inputs)))
(cons task
(cons (list 'match (lambda () output-else-rx)
(lambda (m)
(write-string (match:substring m)
(task:out user-task)
)
(loop)))
(map (conv loop) outputs)))))))))))
(reset-tty)))
;; returns a pattern, that matches anything but the given patterns
(define (else-rx patterns)
;; only character-patterns supported
(if (null? patterns)
(rx any)
(let ((p (car patterns))
(rest (cdr patterns)))
(cond
((char? (car patterns))
(rx (- ,(else-rx rest) ,p)))
(else (error "Only character-patterns are supported."))))))
(define-syntax interact-clauses
(syntax-rules (timeout eof)
((interact-clauses) (cons #f '()))
((interact-clauses (timeout secs handler) rest ...)
(let ((r (interact-clauses rest ...)))
(cons (cons secs handler)
(cdr r))))
((interact-clauses (eof (flag ...) body ...) rest ...)
(interact-clauses (eof-pattern (flag ...) (cont ignore) body ...)
rest ...))
((interact-clauses (rx (flag ...) (cont match mvar ...) body ...) rest ...)
(let ((r (interact-clauses rest ...)))
(cons (car r)
(cons (list rx `(flag ...) (lambda (cont match)
(let-match match (mvar ...)
body ...)))
(cdr r)))))))
(define-syntax interact
(syntax-rules ()
((interact task iclause ...)
(let ((r (interact-clauses iclause ...)))
(interact* task (cdr r) (car r))))))

99
scheme/let-match.scm Normal file
View File

@ -0,0 +1,99 @@
;;; These are some macros to support using regexp matching.
;;; (let-match m mvars body ...)
;;; Bind the match & submatch vars, and eval the body forms.
(define-syntax let-match
(lambda (exp r c)
(if (< (length exp) 3)
(error "No match-vars list in LET-MATCH" exp))
(let ((m (cadr exp)) ; The match expression
(mvars (caddr exp)) ; The match vars
(body (cdddr exp)) ; The expression's body forms
(%begin (r 'begin))
(%match:substring (r 'match:substring))
(%let* (r 'let*)))
(cond ((null? mvars) `(,%begin ,@body))
((pair? mvars)
(let* ((msv (or (car mvars) (r 'match-val))) ; "match-struct var"
(sm-bindings (let recur ((i 0) (vars (cdr mvars)))
(if (pair? vars)
(let ((var (car vars))
(bindings (recur (+ i 1) (cdr vars))))
(if var
(cons `(,var (,%match:substring ,msv ,i))
bindings)
bindings))
'()))))
`(,%let* ((,msv ,m) ,@sm-bindings) ,@body)))
(else (error "Illegal match-vars list in LET-MATCH" mvars exp))))))
(define-syntax if-match
(syntax-rules ()
((if-match match-exp mvars on-match no-match)
(cond (match-exp => (lambda (m) (let-match m mvars on-match)))
(else no-match)))))
;;; (MATCH-COND (<match-exp> <match-vars> <body> ...)
;;; (TEST <exp> <body> ...)
;;; (TEST <exp> => <proc>)
;;; (ELSE <body> ...))
;;;
;;; The first clause is as-in IF-MATCH; the next three clauses are as-in COND.
;;;
;;; It would be slicker if we could *add* extra clauses to the syntax
;;; of COND, but Scheme macros aren't extensible this way.
(define-syntax match-cond
(syntax-rules (else test =>)
((match-cond (else body ...) clause2 ...) (begin body ...))
((match-cond) (cond))
((match-cond (TEST exp => proc) clause2 ...)
(let ((v exp)) (if v (proc v) (match-cond clause2 ...))))
((match-cond (TEST exp body ...) clause2 ...)
(if exp (begin body ...) (match-cond clause2 ...)))
((match-cond (TEST exp) clause2 ...)
(or exp (match-cond clause2 ...)))
((match-cond (match-exp mvars body ...) clause2 ...)
(if-match match-exp mvars (begin body ...)
(match-cond clause2 ...)))))
(define-syntax match-cond
(syntax-rules ()
((match-cond clause ...) (match-cond-aux () clause ...))))
(define-syntax match-cond-aux
(syntax-rules (test else)
;; No more clauses.
((match-cond-aux (cond-clause ...))
(cond cond-clause ...))
;; (TEST . <cond-clause>)
((match-cond-aux (cond-clause ...)
(test . another-cond-clause) clause2 ...)
(match-cond-aux (cond-clause ... another-cond-clause)
clause2 ...))
;; (ELSE <body> ...)
((match-cond-aux (cond-clause ...)
(else body ...) clause2 ...)
(match-cond-aux (cond-clause ... (else body ...))))
;; (<match-exp> <mvars> <body> ...)
((match-cond-aux (cond-clause ...)
(match-exp mvars body ...) clause2 ...)
(match-cond-aux (cond-clause ... (match-exp => (lambda (m)
(let-match m mvars
body ...))))
clause2 ...))))

64
scheme/packages.scm
View File

@ -1,45 +1,63 @@
(define-structure tty-utils
(export modify-tty echo-off echo-on raw raw-initialize)
(open scheme-with-scsh let-opt)
(open scsh let-opt scheme)
(files tty-utils))
(define-structure expect
(export task? make-task
task:process
task:in
task:out
task:buf set-task:buf!
task:pre-match set-task:pre-match!
(define-structure let-match-package
(export (let-match :syntax)
(if-match :syntax)
(match-cond :syntax))
(for-syntax (open scheme
signals)) ; For ERROR
(open scsh scheme)
(access signals) ; for ERROR
(files let-match))
(define-structure expect-syntax-support
(export expand-expect)
(open scheme structure-refs
receiving) ; for making alien containers.
(access signals) ; for ERROR
(files expect-syntax))
(define-structure expect-package
(export task? make-task copy-task
task:process set-task:process modify-task:process
task:in set-task:in modify-task:in
task:out set-task:out modify-task:out
task:buf set-task:buf modify-task:buf
task:pre-match set-task:pre-match modify-task:pre-match
port->monitor
user-task file->task ports->task close-task
wait-task close-task
spawn* (spawn :syntax)
tsend tsend/cr
(expect :syntax)
expect*
tsend tsend-line
(expect :syntax))
(for-syntax (open expect-syntax-support scheme))
interact*
(interact :syntax)
eof-pattern eof-pattern?
(open scsh formats structure-refs let-match-package
receiving defrec-package scheme srfi-13)
(access signals) ; for ERROR
chat-abort chat-timeout chat-monitor
(files expect))
(define-structure chat-package
(export chat-abort chat-timeout chat-monitor
port->chat-logger file->chat-logger
look-for* (look-for :syntax)
(look-for :syntax)
(chat :syntax)
send send/cr)
(for-syntax (open scheme-with-scsh))
(open scheme-with-scsh formats structure-refs let-opt
receiving srfi-9 srfi-13 srfi-1 srfi-11
tty-utils fluids)
(open scsh expect-package fluids scheme)
(files expect interact chat))
(files chat))
(define-structure printf-package
(export printf sprintf display/cr display/nl)
(open scheme-with-scsh formats)
(open scsh formats scheme)
(begin

46
scheme/tty-utils.scm
View File

@ -1,46 +0,0 @@
;;; Some scsh utilities to mung the tty.
;;; Designed and implemented by David Fisher and Olin Shivers.
;;; Copyright (C) 1998 by the Scheme Underground.
;;; (modify-tty proc [tty-fd/port/fname])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Get the tty's current tty-info record. Apply PROC to the record;
;;; set the tty's mode to the result tty-info record returned by PROC.
;;; Return the original, unmodified tty-info record.
;;; RAW RAW-INITIALIZE ECHO-ON ECHO-OFF CANONICAL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These are tty-info -> tty-info functions. They can be used as the PROC
;;; parameter to MODIFY-TTY.
(define (modify-tty proc . maybe-tty)
(let* ((tty (:optional maybe-tty (current-input-port)))
(info0 (tty-info tty)))
(set-tty-info/now tty (proc (copy-tty-info info0)))
info0))
;;; Make a proc that frobs the :local-flags field of a tty-info record.
(define (local-flags-modifier modifier)
(lambda (ti)
(modify-tty-info:local-flags ti modifier)
ti))
(define echo-off
(let ((no-echo (bitwise-not ttyl/echo)))
(local-flags-modifier (lambda (lf) (bitwise-and lf no-echo)))))
(define echo-on
(local-flags-modifier (lambda (lf) (bitwise-ior lf ttyl/echo))))
(define raw
(let ((no-canon (bitwise-not ttyl/canonical)))
(local-flags-modifier (lambda (lf) (bitwise-and lf no-canon)))))
(define (raw-initialize tty-info)
;; min and time can't be set until the terminal is in raw mode. Really.
(set-tty-info:min tty-info 0)
(set-tty-info:time tty-info 0)
tty-info)
(define canonical
(local-flags-modifier (lambda (lf) (bitwise-ior lf ttyl/canonical))))