Compare commits
46 Commits
import-1.1
...
main
Author | SHA1 | Date |
---|---|---|
eknauel | d4bc81dfff | |
eknauel | 08b2fa0f6f | |
eknauel | d016ba79d9 | |
eknauel | 09f27ea9f3 | |
frese | c68b9d1ec2 | |
frese | 97edbb494d | |
mainzelm | 4a557891da | |
frese | f40d245325 | |
frese | 43ed1b800f | |
frese | d403ceb52e | |
frese | 0b1163c4c3 | |
frese | a5b218c7e6 | |
frese | 10bc934a43 | |
frese | fef087fbab | |
frese | 96fccbe6b0 | |
frese | 0a2217bc5c | |
frese | 03d7ee90f6 | |
frese | 5921374d20 | |
frese | 4a49fb8f30 | |
frese | 44c9d5be05 | |
frese | 571e979360 | |
frese | c608b585a5 | |
frese | 3eaa70e248 | |
frese | 92f0933c7c | |
frese | e80f450175 | |
frese | adbb0856af | |
frese | f327192879 | |
frese | c7f21da61a | |
frese | 7642842a3a | |
frese | 7606bdca71 | |
frese | 87fd5ead30 | |
frese | dd1583ad55 | |
frese | 22db3628ab | |
frese | 3428c7a94d | |
frese | c966d7d3d2 | |
frese | b7f45aec49 | |
frese | 62bb1116e4 | |
frese | 9a645ede38 | |
frese | 66b4c7abf8 | |
frese | e5aa09b545 | |
frese | a69eb8275d | |
frese | 72deaa76de | |
frese | ddf471ff81 | |
frese | 7ee58bbe7a | |
frese | 6d8a32093e | |
frese | 731fc793c0 |
28
COPYING
28
COPYING
|
@ -1,2 +1,26 @@
|
|||
Designed and implemented by David Fisher and Olin Shivers.
|
||||
Copyright (C) 1998 by the Scheme Underground.
|
||||
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.
|
||||
|
|
|
@ -0,0 +1,43 @@
|
|||
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.
|
|
@ -0,0 +1,48 @@
|
|||
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
20
README
|
@ -1,2 +1,18 @@
|
|||
Designed and implemented by David Fisher and Olin Shivers.
|
||||
Copyright (C) 1998 by the Scheme Underground.
|
||||
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.
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
* INTERACT
|
||||
|
||||
- else clause
|
||||
- string patterns
|
||||
- regexp patterns
|
42
doc/chat.doc
42
doc/chat.doc
|
@ -1,15 +1,47 @@
|
|||
(chat <task> <body> ...)
|
||||
-------------------------------------------------------------------------------
|
||||
(CHAT <task> <body> ...) -> values syntax
|
||||
|
||||
dynvars: $task $chat-cont $chat-abort-re $chat-timeout
|
||||
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.
|
||||
|
||||
(look-for* re [on-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).
|
||||
|
||||
(send fmt arg ...)
|
||||
(send/cr fmt arg ...)
|
||||
|
||||
logging output funs?
|
||||
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.
|
||||
|
||||
side-effecting option setting
|
||||
Side-effecting option setting functions:
|
||||
(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
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
The Scheme Underground Expect package
|
||||
Designed and implemented by David Fisher and Olin Shivers
|
||||
Designed and implemented by David Fisher, Olin Shivers and David Frese
|
||||
|
||||
(spawn* THUNK) -> task procedure
|
||||
|
||||
|
@ -42,12 +42,13 @@ 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 . <cond-clause>)
|
||||
| (TEST <exp> <body> ...)
|
||||
| (TEST <exp> => <proc>)
|
||||
| (ELSE <body> ...)
|
||||
|
||||
<matchvars> ::= () [No match info]
|
||||
| (<matchvar>) [Match struct only]
|
||||
|
@ -58,6 +59,7 @@ 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
|
||||
|
@ -70,12 +72,15 @@ 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 ... seconds.
|
||||
value is 10 seconds.
|
||||
|
||||
(MONITOR <proc>) This hook establishes a monitor procedure for the
|
||||
the expect processing. A monitor is a procedure
|
||||
of one argument, that is applied when various
|
||||
events occur:
|
||||
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).
|
||||
#F EOF
|
||||
regexp Match occurred.
|
||||
string New input arrived.
|
||||
|
@ -87,6 +92,13 @@ 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
|
||||
|
@ -105,7 +117,9 @@ 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 . COND-CLAUSE)
|
||||
(test <exp> <body> ...)
|
||||
(test <exp> => <proc>)
|
||||
(else <body> ...)
|
||||
This allows for general conditionals to be placed into the
|
||||
EXPECT form.
|
||||
|
||||
|
@ -114,26 +128,56 @@ 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. 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.
|
||||
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.
|
||||
|
||||
(<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.
|
||||
|
@ -148,7 +192,7 @@ task.
|
|||
Wait-task waits for the indicated task to complete, reaping the task.
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
Tty-Mung Package
|
||||
Tty-Utils Package
|
||||
|
||||
(modify-tty-info PROC [PORT]) procedure
|
||||
|
||||
|
|
|
@ -0,0 +1,423 @@
|
|||
#!/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)))
|
|
@ -0,0 +1,57 @@
|
|||
#!/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"))
|
|
@ -0,0 +1,85 @@
|
|||
#!/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))))
|
|
@ -0,0 +1,37 @@
|
|||
#!/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)
|
||||
)))
|
|
@ -0,0 +1,12 @@
|
|||
(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))
|
|
@ -60,19 +60,18 @@
|
|||
(expect (option (timeout tmout) ; Timeout in $chat-timeout secs.
|
||||
(monitor (if cmon
|
||||
(chat->expect-monitor cmon)
|
||||
(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.
|
||||
(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))))
|
||||
|
||||
(task (re (m) ; See RE => return false.
|
||||
(if cmon (cmon 'found m))
|
||||
#f)
|
||||
(abort-re (#f s) ; See $chat-abort-re =>
|
||||
(if cmon (cmon 'abort #f)) ; abort & return the
|
||||
(chat-cont s)) ; abort string.
|
||||
(abort-re (m) ; See $chat-abort-re =>
|
||||
(if cmon (cmon 'abort m)) ; abort & return the
|
||||
(chat-cont m)) ; abort string.
|
||||
|
||||
(on-eof
|
||||
;; EXPECT triggers the monitor for us.
|
||||
|
@ -91,7 +90,7 @@
|
|||
;;; - found(match)
|
||||
;;; - new-input(text)
|
||||
;;; - sending(text)
|
||||
;;; - abort
|
||||
;;; - abort(text)
|
||||
;;; - eof
|
||||
;;; - timeout
|
||||
|
||||
|
@ -117,7 +116,7 @@
|
|||
((sending) (format port "send(~a)\n" val))
|
||||
((eof) (write-string "EOF encountered.\n" port))
|
||||
((timeout) (write-string "-- timed out. \n" port))
|
||||
((abort) (write-string "-- aborting. \n" port))
|
||||
((abort) (format port "-- aborting(~a). \n" val))
|
||||
(else (format port "Unknown chat event: ~a ~a\n" event val)))
|
||||
(force-output port)))
|
||||
|
||||
|
|
|
@ -1,288 +0,0 @@
|
|||
;;; 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)))
|
|
@ -6,39 +6,47 @@
|
|||
;;; - 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 task
|
||||
process
|
||||
in
|
||||
out
|
||||
(buf "")
|
||||
(pre-match #f)) ; Everything before the current match.
|
||||
(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 (tsend task fmt . args)
|
||||
(apply format (task:out task) fmt args))
|
||||
|
||||
(define tsend-line
|
||||
(define tsend/cr
|
||||
(let ((cr (string-ref "\r" 0))) ; Ugh
|
||||
(lambda (task fmt . args)
|
||||
(let ((p (task:out task)))
|
||||
|
@ -80,121 +88,6 @@
|
|||
(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)
|
||||
|
||||
|
@ -265,3 +158,244 @@
|
|||
(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)))))))
|
||||
|
|
|
@ -0,0 +1,135 @@
|
|||
;; 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))))))
|
|
@ -1,99 +0,0 @@
|
|||
;;; 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 ...))))
|
|
@ -1,63 +1,45 @@
|
|||
(define-structure tty-utils
|
||||
(export modify-tty echo-off echo-on raw raw-initialize)
|
||||
(open scsh let-opt scheme)
|
||||
(open scheme-with-scsh let-opt)
|
||||
(files tty-utils))
|
||||
|
||||
(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
|
||||
(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!
|
||||
|
||||
port->monitor
|
||||
|
||||
user-task file->task ports->task close-task
|
||||
wait-task close-task
|
||||
spawn* (spawn :syntax)
|
||||
tsend tsend-line
|
||||
(expect :syntax))
|
||||
(for-syntax (open expect-syntax-support scheme))
|
||||
tsend tsend/cr
|
||||
(expect :syntax)
|
||||
expect*
|
||||
|
||||
(open scsh formats structure-refs let-match-package
|
||||
receiving defrec-package scheme srfi-13)
|
||||
(access signals) ; for ERROR
|
||||
interact*
|
||||
(interact :syntax)
|
||||
eof-pattern eof-pattern?
|
||||
|
||||
(files expect))
|
||||
|
||||
(define-structure chat-package
|
||||
(export chat-abort chat-timeout chat-monitor
|
||||
chat-abort chat-timeout chat-monitor
|
||||
port->chat-logger file->chat-logger
|
||||
(look-for :syntax)
|
||||
look-for* (look-for :syntax)
|
||||
(chat :syntax)
|
||||
send send/cr)
|
||||
(for-syntax (open scheme-with-scsh))
|
||||
|
||||
(open scsh expect-package fluids scheme)
|
||||
(open scheme-with-scsh formats structure-refs let-opt
|
||||
receiving srfi-9 srfi-13 srfi-1 srfi-11
|
||||
tty-utils fluids)
|
||||
|
||||
(files chat))
|
||||
(files expect interact chat))
|
||||
|
||||
(define-structure printf-package
|
||||
(export printf sprintf display/cr display/nl)
|
||||
(open scsh formats scheme)
|
||||
(open scheme-with-scsh formats)
|
||||
|
||||
(begin
|
||||
|
||||
|
|
|
@ -0,0 +1,46 @@
|
|||
;;; 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))))
|
Loading…
Reference in New Issue