Skip to content
Snippets Groups Projects
Commit 81d7bfcd authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Use optima, not fare-matcher. Fix tests.

parent a313e7a4
No related branches found
No related tags found
No related merge requests found
;;; -*- Lisp -*- ;;; -*- Lisp -*-
#+sbcl (require :sb-posix)
(defsystem :inferior-shell (defsystem :inferior-shell
:defsystem-depends-on (:asdf-condition-control) :defsystem-depends-on (:asdf-condition-control)
:depends-on (:asdf :xcvb-driver :fare-utils :fare-matcher :fare-quasiquote-readtable :fare-mop :alexandria) :depends-on (:asdf :xcvb-utils :fare-quasiquote-extras :fare-mop :alexandria
#+sbcl :sb-posix)
:description "spawn local or remote processes and shell pipes" :description "spawn local or remote processes and shell pipes"
:components :components
((:file "pkgdcl") ((:file "pkgdcl")
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(in-package :cl) (in-package :cl)
(defpackage :inferior-shell (defpackage :inferior-shell
(:use :cl :xcvb-utils :fare-matcher :named-readtables :fare-mop) (:use :cl :xcvb-utils :optima :named-readtables :fare-mop)
(:export (:export
#:run #:run/s #:run/ss #:run/lines #:run #:run/s #:run/ss #:run/lines
#:simple-command-line-token #:token-string #:simple-command-line-token #:token-string
......
#+xcvb (module (:depends-on ("pkgdcl"))) #+xcvb (module (:depends-on ("pkgdcl")))
(in-package :inferior-shell) (in-package :inferior-shell)
(in-readtable :fare-quasiquote)
(in-readtable :fare-quasiquote)
(defclass process-spec (simple-print-object-mixin) ()) (defclass process-spec (simple-print-object-mixin) ())
...@@ -193,12 +193,12 @@ ...@@ -193,12 +193,12 @@
(make-sequence-instance progn-spec args)) (make-sequence-instance progn-spec args))
(`(fork ,@args) (`(fork ,@args)
(make-sequence-instance fork-spec args)) (make-sequence-instance fork-spec args))
(`(,* ,@*) (`(,_ ,@_)
(let ((c (make-instance 'command-parse))) (let ((c (make-instance 'command-parse)))
(dolist (elem spec) (dolist (elem spec)
(parse-command-spec-top-token c elem)) (parse-command-spec-top-token c elem))
(command-parse-results c))) (command-parse-results c)))
(* (_
(error "Invalid process spec ~S" spec))))) (error "Invalid process spec ~S" spec)))))
(deftype simple-command-line-token () '(or string pathname keyword symbol character integer)) (deftype simple-command-line-token () '(or string pathname keyword symbol character integer))
...@@ -206,20 +206,31 @@ ...@@ -206,20 +206,31 @@
(defun token-string (x) (defun token-string (x)
(with-safe-io-syntax () (with-safe-io-syntax ()
(typecase x (typecase x
(null "")
(character (format nil "-~A" x)) (character (format nil "-~A" x))
(keyword (format nil "--~(~A~)" x)) (keyword (format nil "--~(~A~)" x))
(symbol (string-downcase x)) (symbol (string-downcase x))
(string x) (string x)
(pathname (native-namestring (translate-logical-pathname x))) (pathname (native-namestring (translate-logical-pathname x)))
(list (write-to-string x)) (cons (with-output-to-string (s) (mapcar (curry 'write-token-component s) x)))
(t (princ-to-string x))))) (t (princ-to-string x)))))
(defun write-token-component (s x)
(typecase x
(null nil)
(character (write-char x s))
(symbol (write-string (string-downcase x) s))
(string (write-string x s))
(pathname (write-string (native-namestring (translate-logical-pathname x)) s))
(cons (mapcar (curry 'write-token-component s) x))
(t (princ x s))))
(defun parse-command-spec-top-token (c x) (defun parse-command-spec-top-token (c x)
(labels (labels
((r (x) ((r (x)
(add-redirection c x)) (add-redirection c x))
(f (sym fd pn flags) (f (sym fd pn flags)
(r (make-file-redirection sym fd pn flags))) (r (make-file-redirection sym fd (token-string pn) flags)))
(fd (old new) (fd (old new)
(r (make-fd-redirection old new))) (r (make-fd-redirection old new)))
(cl (old) (cl (old)
...@@ -276,7 +287,7 @@ ...@@ -276,7 +287,7 @@
(`(>>&! ,pn) (`(>>&! ,pn)
(c `(>>! 1 ,pn)) (c `(>>! 1 ,pn))
(c `(>& 2 1))) (c `(>& 2 1)))
(* (_
(flush-argument c) (flush-argument c)
(parse-command-spec-token c x) (parse-command-spec-token c x)
(flush-argument c))))) (flush-argument c)))))
...@@ -306,9 +317,9 @@ ...@@ -306,9 +317,9 @@
(`(quote ,@args) ;; quote (`(quote ,@args) ;; quote
(e (xcvb-driver:escape-command (e (xcvb-driver:escape-command
(parse-command-spec-tokens args)))) (parse-command-spec-tokens args))))
(`(,(of-type simple-command-line-token) ,@*) ;; recurse (`(,(typep simple-command-line-token) _) ;; recurse
(map () #'p x)) (map () #'p x))
(* (_
(error "Unrecognized command-spec token ~S" x))))) (error "Unrecognized command-spec token ~S" x)))))
(p x))) (p x)))
......
...@@ -57,6 +57,6 @@ ...@@ -57,6 +57,6 @@
(let ((collected (mapcar #'collect-threads full-results))) (let ((collected (mapcar #'collect-threads full-results)))
(case output (case output
(:string (apply #'concatenate 'string collected)) (:string (apply #'concatenate 'string collected))
(:string/stripped (strcat collected)) (:string/stripped (stripln (apply #'concatenate 'string collected)))
(:lines (apply #'concatenate 'list collected)) (:lines (apply #'concatenate 'list collected))
(otherwise collected))))))) (otherwise collected)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment