Better checking for the inter-switch dependencies.
In particular, the code now complains if -e was used with an end-option, switches to non-interactive-mode for -e and ensures that -ds,-dm, and -de always get -s <script> as end-option. In addition, better diagnostics is provided.
This commit is contained in:
mainzelm
parent
bd890a7338
commit
388d2f7b2b
175
scsh/top.scm
175
scsh/top.scm
|
|
@ -107,7 +107,7 @@
|
|||
(define (parse-scsh-args args)
|
||||
(let lp ((args (meta-arg-process-arglist args))
|
||||
(switches '()) ; A list of handler thunks
|
||||
(top-entry #f) ; -t <entry>
|
||||
(top-entry #f) ; -e <entry>
|
||||
(need-script? #f)) ; Found a -ds, -dm, or -de?
|
||||
; (display args (current-output-port))
|
||||
(if (pair? args)
|
||||
|
|
@ -115,31 +115,47 @@
|
|||
(args (cdr args)))
|
||||
|
||||
(cond ((string=? arg "-c")
|
||||
(if (or need-script? top-entry (not (pair? args)))
|
||||
(bad-arg)
|
||||
(values (reverse switches) 'c (car args)
|
||||
top-entry (cdr args))))
|
||||
(cond ((not (pair? args))
|
||||
(bad-arg "-c switch requires argument"))
|
||||
(top-entry
|
||||
(bad-arg "-c switch used with -e switch"))
|
||||
(need-script?
|
||||
(bad-arg "-ds, -dm, or -de switch requires -s <script>"))
|
||||
(else
|
||||
(values (reverse switches) 'c (car args)
|
||||
top-entry (cdr args)))))
|
||||
|
||||
((string=? arg "-s")
|
||||
(if (not (pair? args))
|
||||
(bad-arg "-s switch requires argument")
|
||||
(values (reverse switches) 's (car args)
|
||||
top-entry (cdr args))))
|
||||
(cond ((not (pair? args))
|
||||
(bad-arg "-s switch requires argument"))
|
||||
(top-entry
|
||||
(bad-arg "-s switch used with -e switch"))
|
||||
(need-script?
|
||||
(bad-arg "-ds, -dm, or -de switch requires -s <script>"))
|
||||
(else
|
||||
(values (reverse switches) 's (car args)
|
||||
top-entry (cdr args)))))
|
||||
|
||||
;; -sfd <num>
|
||||
((string=? arg "-sfd")
|
||||
(if (not (pair? args))
|
||||
(bad-arg "-sfd switch requires argument")
|
||||
(let* ((fd (string->number (car args)))
|
||||
(p (fdes->inport fd)))
|
||||
(release-port-handle p) ; Unreveal the port.
|
||||
(values (reverse switches) 'sfd p
|
||||
top-entry (cdr args)))))
|
||||
(cond ((not (pair? args))
|
||||
(bad-arg "-sfd switch requires argument"))
|
||||
(top-entry
|
||||
(bad-arg "-sdf switch used with -e switch"))
|
||||
(else
|
||||
(let* ((fd (string->number (car args)))
|
||||
(p (fdes->inport fd)))
|
||||
(release-port-handle p) ; Unreveal the port.
|
||||
(values (reverse switches) 'sfd p
|
||||
top-entry (cdr args))))))
|
||||
|
||||
((string=? arg "--")
|
||||
(if need-script?
|
||||
(bad-arg "-ds, -dm, or -de switch requires -s <script>")
|
||||
(values (reverse switches) #f #f top-entry args)))
|
||||
(cond (need-script?
|
||||
(bad-arg "-ds, -dm, or -de switch requires -s <script>"))
|
||||
(top-entry
|
||||
(bad-arg "-- switch used with -e switch"))
|
||||
(else
|
||||
(values (reverse switches) #f #f top-entry args))))
|
||||
|
||||
((or (string=? arg "-ds")
|
||||
(string=? arg "-dm")
|
||||
|
|
@ -186,8 +202,10 @@
|
|||
(string->symbol (car args)) need-script?))
|
||||
|
||||
(else (bad-arg "Unknown switch" arg))))
|
||||
|
||||
(values (reverse switches) #f #f top-entry '()))))
|
||||
(cond (need-script?
|
||||
(bad-arg "-ds, -dm, or -de switch requires -s <script>"))
|
||||
(else
|
||||
(values (reverse switches) #f #f top-entry '()))))))
|
||||
|
||||
;;; Do each -ds, -dm, -de, -o, -n, -m, -l/lm/ll, +lp/+lpe/lp+/lpe+, or
|
||||
;;; -lp-clear/lp-default switch, and return the final result package and a
|
||||
|
|
@ -341,68 +359,69 @@
|
|||
(define (parse-switches-and-execute all-args context)
|
||||
(receive (switches term-switch term-val top-entry args)
|
||||
(parse-scsh-args (cdr all-args))
|
||||
(with-handler
|
||||
(lambda (cond more)
|
||||
(if (warning? cond)
|
||||
(more)
|
||||
(with-handler
|
||||
(lambda (c m)
|
||||
(scheme-exit-now 1))
|
||||
(lambda ()
|
||||
(call-exit-hooks-and-narrow (lambda () #t))
|
||||
(more)))))
|
||||
(lambda ()
|
||||
(with-scsh-initialized
|
||||
(not term-switch) context args
|
||||
(lambda ()
|
||||
;; Have to do these before calling DO-SWITCHES, because actions
|
||||
;; performed while processing the switches may use these guys.
|
||||
(set-command-line-args!
|
||||
(cons (if (eq? term-switch 's)
|
||||
term-val ; Script file.
|
||||
(if (eq? term-val 'sfd)
|
||||
"file-descriptor-script" ; -sfd <num>
|
||||
(car all-args)))
|
||||
args))
|
||||
(let ((interactive? (not (or term-switch top-entry))))
|
||||
(with-handler
|
||||
(lambda (cond more)
|
||||
(if (warning? cond)
|
||||
(more)
|
||||
(with-handler
|
||||
(lambda (c m)
|
||||
(scheme-exit-now 1))
|
||||
(lambda ()
|
||||
(call-exit-hooks-and-narrow (lambda () #t))
|
||||
(more)))))
|
||||
(lambda ()
|
||||
(with-scsh-initialized
|
||||
interactive? context args
|
||||
(lambda ()
|
||||
;; Have to do these before calling DO-SWITCHES, because actions
|
||||
;; performed while processing the switches may use these guys.
|
||||
(set-command-line-args!
|
||||
(cons (if (eq? term-switch 's)
|
||||
term-val ; Script file.
|
||||
(if (eq? term-val 'sfd)
|
||||
"file-descriptor-script" ; -sfd <num>
|
||||
(car all-args)))
|
||||
args))
|
||||
|
||||
(let* ((script-loaded? (do-switches switches term-val)))
|
||||
(if (not script-loaded?) ; There wasn't a -ds, -dm, or -de,
|
||||
(if (eq? term-switch 's) ; but there is a script,
|
||||
(load-quietly term-val; so load it now.
|
||||
(interaction-environment))
|
||||
(if (eq? term-switch 'sfd)
|
||||
(load-port-quietly term-val (interaction-environment)))))
|
||||
(let* ((script-loaded? (do-switches switches term-val)))
|
||||
(if (not script-loaded?) ; There wasn't a -ds, -dm, or -de,
|
||||
(if (eq? term-switch 's) ; but there is a script,
|
||||
(load-quietly term-val ; so load it now.
|
||||
(interaction-environment))
|
||||
(if (eq? term-switch 'sfd)
|
||||
(load-port-quietly term-val (interaction-environment)))))
|
||||
|
||||
(cond ((not term-switch) ; -- interactive
|
||||
(scsh-exit-now ;; TODO: ,exit will bypass this
|
||||
(restart-command-processor
|
||||
args
|
||||
context
|
||||
(lambda ()
|
||||
(display (string-append
|
||||
"Welcome to scsh "
|
||||
scsh-version-string
|
||||
" (" scsh-release-name ")")
|
||||
(current-output-port))
|
||||
(newline (current-output-port))
|
||||
(display "Type ,? for help."
|
||||
(current-output-port))
|
||||
(newline (current-output-port))
|
||||
(in-package (user-environment) '())))))
|
||||
(cond (interactive?
|
||||
(scsh-exit-now ;; TODO: ,exit will bypass this
|
||||
(restart-command-processor
|
||||
args
|
||||
context
|
||||
(lambda ()
|
||||
(display (string-append
|
||||
"Welcome to scsh "
|
||||
scsh-version-string
|
||||
" (" scsh-release-name ")")
|
||||
(current-output-port))
|
||||
(newline (current-output-port))
|
||||
(display "Type ,? for help."
|
||||
(current-output-port))
|
||||
(newline (current-output-port))
|
||||
(in-package (user-environment) '())))))
|
||||
|
||||
((eq? term-switch 'c)
|
||||
(let ((result (eval (read-exactly-one-sexp-from-string term-val)
|
||||
(interaction-environment))))
|
||||
(scsh-exit-now 0)))
|
||||
((eq? term-switch 'c)
|
||||
(let ((result (eval (read-exactly-one-sexp-from-string term-val)
|
||||
(interaction-environment))))
|
||||
(scsh-exit-now 0)))
|
||||
|
||||
(top-entry ; There was a -e <entry>.
|
||||
((eval top-entry (interaction-environment))
|
||||
(command-line))
|
||||
(scsh-exit-now 0))
|
||||
(top-entry ; There was a -e <entry>.
|
||||
((eval top-entry (interaction-environment))
|
||||
(command-line))
|
||||
(scsh-exit-now 0))
|
||||
|
||||
;; Otherwise, the script executed as it loaded,
|
||||
;; so we're done.
|
||||
(else (scsh-exit-now 0))))))))))
|
||||
;; Otherwise, the script executed as it loaded,
|
||||
;; so we're done.
|
||||
(else (scsh-exit-now 0)))))))))))
|
||||
|
||||
|
||||
(define (read-exactly-one-sexp-from-string s)
|
||||
|
|
|
|||
Loading…
Reference in New Issue