Requesting comments on some Lisp code
Damien Kick
to have an excuse to do something with Lisp other than work on
exercises in books. It was a toy version of Don Libes' Expect
<http://groups.google.com/groups?hl=en&lr=&ie=UTF-8&oe=UTF-8&threadm=ovwuaefgtw.fsf%40email.mot.com&rnum=3&prev=/groups%3Fq%3Ddamien%2Bkick%2Bgroup:comp.lang.lisp.*%26hl%3Den%26lr%3D%26ie%3DUTF-8%26oe%3DUTF-8%26selm%3Dovwuaefgtw.fsf%2540email.mot.com%26rnum%3D3>.
I've continued to tinker, in a low priority, background thread kind of
way. Basically, I've incorporated CL-PPCRE to provide support for
regular expressions in my version of EXPECT. As I am not fortunate
enough to have any contact with Lispniks outside of c.l.l., I always
appreciate any advice, suggestions, etc., I get from this group. What
is the deal with LispChicago <http://alu.cliki.net/LispChicago>?
However, I did just discover that, apparently, Paul Dietz is in my
area <http://www.cliki.net/Paul%20Dietz>. Anyway, here is the latest
snapshot of that with which I've been playing (some names and such
have been changed to protect the paranoid).
;;;; file: load.lisp
;;; I'll put this into something fancy, i.e. DEFSYSTEM and/or ASDF,
;;; later. This'll do for now.
(in-package #:cl-user)
(load "/usr/vob/2gtt/lti/cl-ppcre-0.7.1/load")
(load "/usr/vob/2gtt/lti/lti")
(load "/usr/vob/2gtt/lti/lti-test")
(eval-when (:load-toplevel :execute)
;; I suppose we should only do this if the package doesn't already
;; exist.
(unless (find-package '#:lone-trip-investments-user)
(defpackage #:lone-trip-investments-user
(:nicknames #:lti-user)
(:use #:cl #:lti #:lti-test)))
;; <shrug> Might as well throw this in, too...
(unless (find-package '#:playground)
(defpackage #:playground
(:nicknames #:pg)
(:use #:cl)))
;; <shrug> And this...
(unless (find-package '#:playground-user)
(defpackage #:playground-user
(:nicknames #:pg-user)
(:use #:cl #:pg))))
;;;; file: lti.lisp
(defpackage #:lone-trip-investments
(:nicknames #:lti)
(:use #:common-lisp #:extensions #:cl-ppcre)
(:export #:with-spawn-process #:with-spawn-stream
#:spawn #:expect #:send))
(in-package #:lone-trip-investments)
(defmacro with-spawn-process ((id exec-name . exec-args) &body code)
`(let ((,id (spawn ,exec-name ',exec-args)))
(unwind-protect
(progn ,@code)
(process-close ,id))))
(defmacro with-spawn-stream ((stream exec-name . exec-args) &body code)
(let ((id (gensym "SPAWN-PROCESS-")))
`(with-spawn-process (,id ,exec-name ,@exec-args)
(let ((,stream (process-pty ,id)))
(flet ((expect (expected &optional (spawn ,stream)
&key (echo *standard-output*))
(expect expected spawn :echo echo))
(send (message &optional (spawn ,stream))
(send message spawn)))
,@code)))))
;; Eventually, there needs to be some kind of mechanism to support
;; multiple spawn at the same time. Don Libe's Expect has this built
;; into the "expect" function, i.e. one can pass in a list of more
;; than one spawn-id and associated expectations. I suppose that this
;; could be built into LTI:EXPECT in a similiar fashion, using
;; SYSTEM:SERVE-EVENT in the implementation. However, this seems too
;; limiting because I might want to have non-spawn related events
;; included, too. I'll think about this later.
(defgeneric expect (expected spawn &key echo)
(:documentation
"ARGS: EXPECTED SPAWN &KEY ECHO
This is a CMU CL version of Don Libes' expect. EXPECTED is what one
expects to find on SPAWN, created by the function SPAWN."))
(defgeneric send (message spawn)
(:documentation
"ARGS: MESSAGE SPAWN
A CMU CL version of Don Libe's send. Send MESSAGE to SPAWN, created by
the function SPAWN."))
(defun spawn (program &optional args)
"ARGS: PROGRAM &OPTIONAL ARGS
A CMU CL version of Don Libes' spawn. PROGRAM is the name of the program
to be exec'd in a pseudo-terminal."
(run-program program args :wait nil :pty t :input t :output t :error t))
(defmethod expect ((expected string) (spawn extensions::process)
&key (echo *standard-output*)
regexp
case-insensitive-mode
multi-line-mode
single-line-mode
extended-mode)
(expect (create-scanner (if regexp
expected
(quote-meta-chars expected))
:case-insensitive-mode case-insensitive-mode
:multi-line-mode multi-line-mode
:single-line-mode single-line-mode
:extended-mode extended-mode)
(process-pty spawn)
:echo echo))
(defmethod expect ((expected string) (spawn stream)
&key (echo *standard-output*)
regexp
case-insensitive-mode
multi-line-mode
single-line-mode
extended-mode)
(expect (create-scanner (if regexp
expected
(quote-meta-chars expected))
:case-insensitive-mode case-insensitive-mode
:multi-line-mode multi-line-mode
:single-line-mode single-line-mode
:extended-mode extended-mode)
spawn
:echo echo))
;; expected is a parse-tree
(defmethod expect ((expected t) (spawn extensions::process)
&key (echo *standard-output*)
case-insensitive-mode
multi-line-mode
single-line-mode
extended-mode
destructive)
(expect (create-scanner expected
:case-insensitive-mode case-insensitive-mode
:multi-line-mode multi-line-mode
:single-line-mode single-line-mode
:extended-mode extended-mode
:destructive destructive)
(process-pty spawn) :echo echo))
;; expected is a parse-tree
(defmethod expect ((expected t) (spawn stream)
&key (echo *standard-output*)
case-insensitive-mode
multi-line-mode
single-line-mode
extended-mode
destructive)
(expect (create-scanner expected
:case-insensitive-mode case-insensitive-mode
:multi-line-mode multi-line-mode
:single-line-mode single-line-mode
:extended-mode extended-mode
:destructive destructive)
spawn :echo echo))
;; expected is a scanner
(defmethod expect ((expected function) (spawn extensions::process)
&key (echo *standard-output*))
(expect expected (process-pty spawn) :echo echo))
;; expected is a scanner
(defmethod expect ((expected function) (spawn stream)
&key (echo *standard-output*))
(let ((buffer (make-array '(0) :element-type 'base-char
:fill-pointer 0 :adjustable t)))
(with-output-to-string (match buffer)
(let ((io (make-echo-stream spawn
(if echo
(make-broadcast-stream match echo)
match))))
;; I know that this is going to be a horribly inefficient
;; algorithm; i.e. reading a single character at a time
;; and re-scanning the BUFFER every time a new character
;; is added. I'll work on fixing this later. For know, I
;; just want to get something working. -- Damien Kick
(loop
(read-char io)
(multiple-value-bind (match-start match-end reg-starts reg-ends)
(scan expected buffer)
(when match-start
(return (values buffer match-start match-end
reg-starts reg-ends)))))))))
(defmethod send ((message string) (spawn extensions::process))
(send message (process-pty spawn)))
(defmethod send ((message string) (spawn stream))
(write-string message spawn)
(force-output spawn)
message)
;;;; file: lti-test.lisp
(defpackage #:lone-trip-investments-test
(:nicknames #:lti-test)
(:use #:common-lisp #:extensions #:lone-trip-investments)
(:export #:*login* #:*password*
#:test-expect #:test-telnet-some-mgts-server))
(in-package #:lone-trip-investments-test)
(defvar *login* "elvis"
"The login to be used for the test cases.")
(defvar *password* "doughnut"
"The password to be used for the test cases.")
(declaim (inline make-adjustable-string))
(defun make-adjustable-string ()
(make-array '(0)
:element-type 'base-char :fill-pointer 0 :adjustable t))
(declaim (inline string-cat))
(defun string-cat (&rest args)
(apply #'concatenate 'string args))
(declaim (inline make-test-expect-string--case-1))
(defun make-test-expect-string--case-1 ()
"telnet some-mgts-server
Trying 0.0.0.0...
Connected to some-mgts-server.
Escape character is '^]'.
SunOS 5.6
login: elvis
Password: ")
(declaim (inline make-expected-match-string--case-1))
(defun make-expected-match-string--case-1 ()
"telnet some-mgts-server
Trying 0.0.0.0...
Connected to some-mgts-server.
Escape character is '^]'.
SunOS 5.6
login:")
(defun call-expect--case-1 (&key (echo nil echo-supplied-p))
"Use EXPECT to find \"login\" in the string
MAKE-TEST-EXPECT-STRING--CASE-1. We expect for EXPECT to return
MAKE-EXPECTED-MATCH-STRING--CASE-1. Call EXPECT with the value of
ECHO, if one was supplied."
(let ((what-to-expect "login:"))
(with-input-from-string
(phake-spawn-in (make-test-expect-string--case-1))
(multiple-value-bind
(what-was-matched match-start match-end reg-starts reg-ends)
(funcall (if echo-supplied-p
#'(lambda (what-to-expect spawn)
(expect what-to-expect spawn :echo echo))
#'(lambda (what-to-expect spawn)
(expect what-to-expect spawn)))
what-to-expect phake-spawn-in)
(declare (ignore reg-starts reg-ends))
(assert (equal what-was-matched
(make-expected-match-string--case-1)))
(assert (equal (subseq what-was-matched match-start match-end)
what-to-expect))))))
(defun test-expect ()
"Executes all of the \"test-expect--case-[0-9]+\" cases."
(assert (test-expect--case-1))
t)
(defun test-expect--case-1 ()
"Tests all the ways to call CALL-EXPECT--CASE-1 with different
values for the :ECHO keyword parameter."
(call-expect--case-1 :echo nil)
(assert (equal (with-output-to-string
(phake-echo-stream)
(call-expect--case-1 :echo phake-echo-stream))
(make-expected-match-string-case-1)))
(call-expect--case-1)
t)
(defun test-telnet-some-mgts-server (&optional (login *login*)
(password *password*))
"Executes all of the \"test-telnet-some-mgts-server--case-[0-9]+\" cases."
(assert (test-telnet-some-mgts-server--case-1 login password))
(assert (test-telnet-some-mgts-server--case-2 login password))
t)
(defun test-telnet-some-mgts-server--case-1 (&optional (login *login*)
(password *password*))
(with-spawn-stream (stream "telnet" "some-mgts-server")
;; It would be nice to be able to somehow get WITH-SPAWN-STREAM to
;; generate FLET versions of functions, like EXPECT-PROMPT below,
;; that take STREAM as an optional parameter, as is done with
;; EXPECT and SEND. I wonder how much extra work would be
;; required to accomplish this for any function, FOO. Or would it
;; be better to do this with closures?
(flet ((expect-prompt ()
(expect "tekelec:[")
(expect "]")
(expect "%")))
(expect "login:")
(send (string-cat (string login) (string #\Newline)))
(expect "assword:")
(send (string-cat (string password) (string #\Newline)))
(expect-prompt)
(send (string-cat "ls" (string #\Newline)))
(expect-prompt)
t)))
(defun test-telnet-some-mgts-server--case-2 (&optional (login *login*)
(password *password*))
(with-spawn-stream (stream "telnet" "some-mgts-server")
;; It would be nice to be able to somehow get WITH-SPAWN-STREAM to
;; generate FLET versions of functions, like EXPECT-PROMPT below,
;; that take STREAM as an optional parameter, as is done with
;; EXPECT and SEND. I wonder how much extra work would be
;; required to accomplish this for any function, FOO. Or would it
;; be better to do this with closures?
(let ((prompt '(:sequence
"tekelec:["
(:greedy-repetition 0 nil :everything)
#\]
(:greedy-repetition 1 nil #\Space)
(:greedy-repetition 1 nil (:char-class
(:range #\0 #\9)))
(:greedy-repetition 1 nil #\Space)
#\%)))
(expect "login:")
(send (string-cat (string login) (string #\Newline)))
(expect "assword:")
(send (string-cat (string password) (string #\Newline)))
(expect prompt)
(send (string-cat "ls" (string #\Newline)))
(expect prompt)
t)))
;;;; ILISP sessions capture of running tests...
* Starting [...]/cmucl ...
; Loading #p"[...]/.cmucl-init.sparcf".
;; Loading #p"[...]/clocc-20040206/clocc.sparcf".
;; Loading #p"[...]/clocc-20040206/src/defsystem-3.x/defsystem.sparcf".
CMU Common Lisp 18e, running on gsdapp05
With core: [...]/lib/cmucl/lib/lisp.core
Dumped on: Tue, 2003-04-08 13:23:10-05:00 on achat
See <http://www.cons.org/cmucl/> for support information.
Loaded subsystems:
Python 1.1, target SPARCstation/Solaris 2
CLOS 18e (based on PCL September 16 92 PCL (f))
*
*
; Loading #p"/usr/vob/2gtt/lti/load.sparcf".
;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/load.lisp".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/packages.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/specials.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/util.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/errors.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/lexer.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/parser.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/regex-class.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/convert.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/optimize.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/closures.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/repetition-closures.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/scanner.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/api.sparcf".
;;; Loading #p"/usr/vob/2gtt/lti/cl-ppcre-0.7.1/ppcre-tests.sparcf".
;; Loading #p"/usr/vob/2gtt/lti/lti.sparcf".
;; Loading #p"/usr/vob/2gtt/lti/lti-test.sparcf".
T
* (in-package #:lti-user)
#<The LONE-TRIP-INVESTMENTS-USER package, 0/9 internal, 0/2 external>
* (test-expect)
telnet some-mgts-server
Trying 0.0.0.0...
Connected to some-mgts-server.
Escape character is '^]'.
SunOS 5.6
login:
T
* (test-telnet-some-mgts-server)
Trying 0.0.0.0...
Connected to some-mgts-server.
Escape character is '^]'.
SunOS 5.6
login: automation
Password:
Last login: Sat Feb 14 01:57:18 from 10.17.193.25
Sun Microsystems Inc. SunOS 5.6 Generic August 1997
tcsh: using dumb terminal settings.
tekelec:[/tekelec/users/automation] 1 % ls
SEdisplaylJ_1N_ log mgts_cit_csh
auto.sh mgts.Xdefaults mgts_cit_env
auto_datafiles.tar mgts.cshrc mgts_gsr6.tar
datafile.6.0.1.0.4.tar mgts.login mgts_run
datafiles mgts.profile mgts_umt_csh
datafiles.bak mgts.xinitrc set_mgts_env
install.errors mgts.xsession
;;; At this point, the ILISP session always dies. Perhaps I should
;;; give Slime a try. Anyway, it works from raw cmucl...
Damien Kick
> [...] Anyway, here is the latest snapshot of that with which I've
> been playing [...].
Two little things to change.
> ;;;; file: lti-test.lisp
[...]
> (defun call-expect--case-1 (&key (echo nil echo-supplied-p))
> "Use EXPECT to find \"login\" in the string
> MAKE-TEST-EXPECT-STRING--CASE-1. We expect for EXPECT to return
> MAKE-EXPECTED-MATCH-STRING--CASE-1. Call EXPECT with the value of
> ECHO, if one was supplied."
> (let ((what-to-expect "login:"))
> (with-input-from-string
> (phake-spawn-in (make-test-expect-string--case-1))
> (multiple-value-bind
> (what-was-matched match-start match-end reg-starts reg-ends)
> (funcall (if echo-supplied-p
> #'(lambda (what-to-expect spawn)
> (expect what-to-expect spawn :echo echo))
> #'(lambda (what-to-expect spawn)
> (expect what-to-expect spawn)))
> what-to-expect phake-spawn-in)
> (declare (ignore reg-starts reg-ends))
> (assert (equal what-was-matched
> (make-expected-match-string--case-1)))
> (assert (equal (subseq what-was-matched match-start match-end)
> what-to-expect))))))
;; I decided that I liked the following better.
(defun call-expect--case-1 (&key (echo nil echo-supplied-p))
"Use EXPECT to find \"login\" in the string
MAKE-TEST-EXPECT-STRING--CASE-1. We expect for EXPECT to return
MAKE-EXPECTED-MATCH-STRING--CASE-1. Call EXPECT with the value of
ECHO, if one was supplied."
(let ((what-to-expect "login:"))
(with-input-from-string
(phake-spawn-in (make-test-expect-string--case-1))
(multiple-value-bind
(what-was-matched match-start match-end reg-starts reg-ends)
(apply #'expect
(append (list what-to-expect phake-spawn-in)
(when echo-supplied-p
(list :echo echo))))
(declare (ignore reg-starts reg-ends))
(assert (equal what-was-matched
(make-expected-match-string--case-1)))
(assert (equal (subseq what-was-matched match-start match-end)
what-to-expect))))))
> (defun test-expect--case-1 ()
> "Tests all the ways to call CALL-EXPECT--CASE-1 with different
> values for the :ECHO keyword parameter."
> (call-expect--case-1 :echo nil)
> (assert (equal (with-output-to-string
> (phake-echo-stream)
> (call-expect--case-1 :echo phake-echo-stream))
> (make-expected-match-string-case-1)))
> (call-expect--case-1)
> t)
;; I'm confused at how this managed to pass my tests, as I made a
;; type: MAKE-EXPECTED-MATCH-STRING-CASE-1 should really be
;; MAKE-EXPECTED-MATCH-STRING--CASE-1. I'm surprised that CMUCL
;; didn't warn me about the function not being defined... Ah! I
;; must've loaded a version of the function as
;; MAKE-EXPECTED-MATCH-STRING-CASE-1 before I decided I liked the
;; "--case-1" better and my tests were finding the lingering old
;; symbol. Anyway... it should really be
(defun test-expect--case-1 ()
"Tests all the ways to call CALL-EXPECT--CASE-1 with different
values for the :ECHO keyword parameter."
(call-expect--case-1 :echo nil)
(assert (equal (with-output-to-string (phake-echo-stream)
(call-expect--case-1 :echo phake-echo-stream))
(make-expected-match-string--case-1)))
(call-expect--case-1)
t)