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 David Fisher and Olin Shivers
|
||||||
Copyright (C) 1998 by the Scheme Underground.
|
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.
|
scsh-expect v0.1
|
||||||
Copyright (C) 1998 by the Scheme Underground.
|
|
||||||
|
* 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 [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 fmt arg ...)
|
||||||
(send/cr 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>)
|
(chat-abort <re>)
|
||||||
|
if this regular expression is matched, the chat call is aborted.
|
||||||
(chat-timeout <nsecs>)
|
(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
|
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
|
(spawn* THUNK) -> task procedure
|
||||||
|
|
||||||
|
@ -42,12 +42,13 @@ in the task:buf field.
|
||||||
|
|
||||||
<eclause> ::= (<task> <aclause> ...) [Task clause.]
|
<eclause> ::= (<task> <aclause> ...) [Task clause.]
|
||||||
| <option-clause>
|
| <option-clause>
|
||||||
| (ON-TIMEOUT <body> ...) [Do on timeout.]
|
|
||||||
|
|
||||||
Action clauses:
|
Action clauses:
|
||||||
<aclause> ::= (ON-EOF <body> ...) [Do on EOF.]
|
<aclause> ::= (ON-EOF <body> ...) [Do on EOF.]
|
||||||
| (<pattern> <matchvars> <exp> ...) [Do if pattern matches.]
|
| (<pattern> <matchvars> <exp> ...) [Do if pattern matches.]
|
||||||
| (TEST . <cond-clause>)
|
| (TEST <exp> <body> ...)
|
||||||
|
| (TEST <exp> => <proc>)
|
||||||
|
| (ELSE <body> ...)
|
||||||
|
|
||||||
<matchvars> ::= () [No match info]
|
<matchvars> ::= () [No match info]
|
||||||
| (<matchvar>) [Match struct only]
|
| (<matchvar>) [Match struct only]
|
||||||
|
@ -58,6 +59,7 @@ Action clauses:
|
||||||
| (ECHO <bool>) ; Not supported
|
| (ECHO <bool>) ; Not supported
|
||||||
| (MAX-SIZE <nchars>) ; Not supported
|
| (MAX-SIZE <nchars>) ; Not supported
|
||||||
| (MONITOR <proc>)
|
| (MONITOR <proc>)
|
||||||
|
| (ON-TIMEOUT <body> ...) [Do on timeout.]
|
||||||
|
|
||||||
Expect takes a number of tasks, and waits for a number of patterns to
|
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
|
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
|
before timing out. The lowest timeout clause
|
||||||
determines when the entire expect form will time out.
|
determines when the entire expect form will time out.
|
||||||
A timeout value of #f means no timeout. The default
|
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
|
(MONITOR <proc>) This hook establishes a monitor procedure for the
|
||||||
the expect processing. A monitor is a procedure
|
the expect processing. A monitor is a procedure
|
||||||
of one argument, that is applied when various
|
of two arguments, that is applied when various
|
||||||
events occur:
|
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
|
#F EOF
|
||||||
regexp Match occurred.
|
regexp Match occurred.
|
||||||
string New input arrived.
|
string New input arrived.
|
||||||
|
@ -87,6 +92,13 @@ where an <option> is one of
|
||||||
task's push-back buffer and is not reported.
|
task's push-back buffer and is not reported.
|
||||||
'timeout EXPECT timed out.
|
'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
|
An action clause <aclause> can be one of
|
||||||
(<pattern> <matchvars> <body> ...)
|
(<pattern> <matchvars> <body> ...)
|
||||||
If the pattern matches input read from the task, expect binds the
|
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
|
is triggered. If EXPECT hits EOF and there is no ON-EOF clause for
|
||||||
the task, nothing happens.
|
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
|
This allows for general conditionals to be placed into the
|
||||||
EXPECT form.
|
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
|
Interact allows the user to interact with a running task, relaying the
|
||||||
keys pressed by the user to the task and outputting the characters
|
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
|
provided by the task to the user. For this purpose interact also turns
|
||||||
programmer, interact will filter input before passing it along to the
|
the terminal modes for the current input port to raw mode and turns
|
||||||
task. A clause is either a character-clause or a filter-clause.
|
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> ...)
|
(TIMEOUT <seconds> <handler>)
|
||||||
When interact matches the character, it bind the continuation variable
|
If none of the pattern-clauses match within the given number of
|
||||||
to the continuation out of the interaction, then evaluates the clause
|
seconds, then the handler-procedure is called with a continuation
|
||||||
body.
|
procedure that can be called to return from the interact-call. If
|
||||||
|
the continuation is not called, interact continues normally.
|
||||||
|
|
||||||
(FILTER <procedure>)
|
(<pattern> (<flag> ...) (k m ...) <body> ...)
|
||||||
Where filter is passed two variables, the character input and the
|
The pattern can either be a character, a string or a regular
|
||||||
continuation out of the interaction. In both cases, if the clause
|
expression, although only characters are supported in this
|
||||||
returns true, it falls through to the next clause. If all clauses
|
version.
|
||||||
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.
|
|
||||||
|
|
||||||
Example: (filter (lambda (c k)
|
If the pattern matches some portion of the input from
|
||||||
(if
|
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 STRING TASK) -> (undefined) procedure
|
||||||
|
|
||||||
Send sends the string to the task, as if a user had typed it.
|
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.
|
Wait-task waits for the indicated task to complete, reaping the task.
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
Tty-Mung Package
|
Tty-Utils Package
|
||||||
|
|
||||||
(modify-tty-info PROC [PORT]) procedure
|
(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.
|
(expect (option (timeout tmout) ; Timeout in $chat-timeout secs.
|
||||||
(monitor (if cmon
|
(monitor (if cmon
|
||||||
(chat->expect-monitor cmon)
|
(chat->expect-monitor cmon)
|
||||||
(lambda (task event) #f)))) ; No-op
|
(lambda (task event) #f))) ; No-op
|
||||||
|
;; Timeout => Call handler or abort.
|
||||||
;; Expect triggers the monitor for us on timeout.
|
(on-timeout (if (pair? maybe-on-timeout)
|
||||||
(on-timeout (if (pair? maybe-on-timeout) ; Timeout =>
|
((car maybe-on-timeout))
|
||||||
((car maybe-on-timeout)) ; Call handler or
|
(chat-cont 'timeout))))
|
||||||
(chat-cont 'timeout))) ; abort.
|
|
||||||
|
|
||||||
(task (re (m) ; See RE => return false.
|
(task (re (m) ; See RE => return false.
|
||||||
(if cmon (cmon 'found m))
|
(if cmon (cmon 'found m))
|
||||||
#f)
|
#f)
|
||||||
(abort-re (#f s) ; See $chat-abort-re =>
|
(abort-re (m) ; See $chat-abort-re =>
|
||||||
(if cmon (cmon 'abort #f)) ; abort & return the
|
(if cmon (cmon 'abort m)) ; abort & return the
|
||||||
(chat-cont s)) ; abort string.
|
(chat-cont m)) ; abort string.
|
||||||
|
|
||||||
(on-eof
|
(on-eof
|
||||||
;; EXPECT triggers the monitor for us.
|
;; EXPECT triggers the monitor for us.
|
||||||
|
@ -91,7 +90,7 @@
|
||||||
;;; - found(match)
|
;;; - found(match)
|
||||||
;;; - new-input(text)
|
;;; - new-input(text)
|
||||||
;;; - sending(text)
|
;;; - sending(text)
|
||||||
;;; - abort
|
;;; - abort(text)
|
||||||
;;; - eof
|
;;; - eof
|
||||||
;;; - timeout
|
;;; - timeout
|
||||||
|
|
||||||
|
@ -117,7 +116,7 @@
|
||||||
((sending) (format port "send(~a)\n" val))
|
((sending) (format port "send(~a)\n" val))
|
||||||
((eof) (write-string "EOF encountered.\n" port))
|
((eof) (write-string "EOF encountered.\n" port))
|
||||||
((timeout) (write-string "-- timed out. \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)))
|
(else (format port "Unknown chat event: ~a ~a\n" event val)))
|
||||||
(force-output port)))
|
(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
|
;;; - Fairness & round-robin looping
|
||||||
;;; - If all tasks eof, should we detect this and bail out early?
|
;;; - If all tasks eof, should we detect this and bail out early?
|
||||||
;;; - I need a little toolkit for constructing monitors.
|
;;; - 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
|
;;; If I had infinite-pushback ports, I could flush the "task" structure
|
||||||
;;; entirely. This would be better done with a transducer architecture.
|
;;; entirely. This would be better done with a transducer architecture.
|
||||||
|
|
||||||
;;; Interact
|
;;; Interact
|
||||||
;;; - -nobuffer is useful for spotting stuff as it flies by.
|
;;; - -nobuffer is useful for spotting stuff as it flies by.
|
||||||
;;; - It can handle matching in both directions.
|
|
||||||
;;; - It can handle strings and regexps.
|
;;; - 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.
|
;;; A task is a guy with whom we can interact.
|
||||||
|
|
||||||
(define-record task
|
(define-record-type task
|
||||||
process
|
(really-make-task process in out buf pre-match)
|
||||||
in
|
task?
|
||||||
out
|
(process task:process)
|
||||||
(buf "")
|
(in task:in)
|
||||||
(pre-match #f)) ; Everything before the current match.
|
(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)
|
(define (tsend task fmt . args)
|
||||||
(apply format (task:out task) fmt args))
|
(apply format (task:out task) fmt args))
|
||||||
|
|
||||||
(define tsend-line
|
(define tsend/cr
|
||||||
(let ((cr (string-ref "\r" 0))) ; Ugh
|
(let ((cr (string-ref "\r" 0))) ; Ugh
|
||||||
(lambda (task fmt . args)
|
(lambda (task fmt . args)
|
||||||
(let ((p (task:out task)))
|
(let ((p (task:out task)))
|
||||||
|
@ -80,121 +88,6 @@
|
||||||
(close (task:in task))
|
(close (task:in task))
|
||||||
(close (task:out 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.
|
;;; The default monitor -- does nothing.
|
||||||
(define (null-monitor task event) #f)
|
(define (null-monitor task event) #f)
|
||||||
|
|
||||||
|
@ -265,3 +158,244 @@
|
||||||
(let ((s (task:buf task)))
|
(let ((s (task:buf task)))
|
||||||
(if (zero? (string-length s)) (otherwise)
|
(if (zero? (string-length s)) (otherwise)
|
||||||
(tm s 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
|
(define-structure tty-utils
|
||||||
(export modify-tty echo-off echo-on raw raw-initialize)
|
(export modify-tty echo-off echo-on raw raw-initialize)
|
||||||
(open scsh let-opt scheme)
|
(open scheme-with-scsh let-opt)
|
||||||
(files tty-utils))
|
(files tty-utils))
|
||||||
|
|
||||||
(define-structure let-match-package
|
(define-structure expect
|
||||||
(export (let-match :syntax)
|
(export task? make-task
|
||||||
(if-match :syntax)
|
task:process
|
||||||
(match-cond :syntax))
|
task:in
|
||||||
(for-syntax (open scheme
|
task:out
|
||||||
signals)) ; For ERROR
|
task:buf set-task:buf!
|
||||||
|
task:pre-match set-task:pre-match!
|
||||||
(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
|
port->monitor
|
||||||
|
|
||||||
user-task file->task ports->task close-task
|
user-task file->task ports->task close-task
|
||||||
|
wait-task close-task
|
||||||
spawn* (spawn :syntax)
|
spawn* (spawn :syntax)
|
||||||
tsend tsend-line
|
tsend tsend/cr
|
||||||
(expect :syntax))
|
(expect :syntax)
|
||||||
(for-syntax (open expect-syntax-support scheme))
|
expect*
|
||||||
|
|
||||||
(open scsh formats structure-refs let-match-package
|
interact*
|
||||||
receiving defrec-package scheme srfi-13)
|
(interact :syntax)
|
||||||
(access signals) ; for ERROR
|
eof-pattern eof-pattern?
|
||||||
|
|
||||||
(files expect))
|
chat-abort chat-timeout chat-monitor
|
||||||
|
|
||||||
(define-structure chat-package
|
|
||||||
(export chat-abort chat-timeout chat-monitor
|
|
||||||
port->chat-logger file->chat-logger
|
port->chat-logger file->chat-logger
|
||||||
(look-for :syntax)
|
look-for* (look-for :syntax)
|
||||||
(chat :syntax)
|
(chat :syntax)
|
||||||
send send/cr)
|
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
|
(define-structure printf-package
|
||||||
(export printf sprintf display/cr display/nl)
|
(export printf sprintf display/cr display/nl)
|
||||||
(open scsh formats scheme)
|
(open scheme-with-scsh formats)
|
||||||
|
|
||||||
(begin
|
(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