/[meta-cvs]/meta-cvs/F-233AD6EEE14894A7303F09519A2AB734
ViewVC logotype

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Fri Feb 1 03:42:55 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.16: +8 -5 lines
* options.lisp (parse-opt): When multiple options characters are
bunched up into one argument, and one of them other than the
last one takes an argument, then the remaining ones are
considered to constitute a string which is an argument to that
option. For instance -y32 means -y 32, not -y -3 -2, assuming
that y is an option that requires an argument.

Top level handler terminates by non-local exit back to
mcvs function, rather than by calling (exit).

* mcvs-main.lisp (mcvs-top-error-handler): Restructured
to call (throw 'mcvs-exit t).
(mcvs-execute): Ensure that NIL is returned by normal exit.
(mcvs): Catches 'mcvs-exit throw, and calls (exit 0) or (exit 1)
accordingly.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "import")
6 (require "checkout")
7 (require "add")
8 (require "remove")
9 (require "move")
10 (require "update")
11 (require "commit")
12 (require "diff")
13 (require "filt")
14 (require "split")
15 (require "restart")
16 (require "options")
17 (provide "mcvs-main")
18
19 (defvar *mcvs-error-treatment* :interactive
20 "This variable is used by the top level error handler set up in mcvs-execute to
21 decide on what to do with a restartable error condition. If no restarts are
22 available, then this variable is ignored; the handler will print the error
23 message and terminate the program. If the error is restartable, then this
24 variable is examined. A value of :interactive indicates that a menu of options
25 should be presented to a user, who can choose to bail the program, or invoke
26 one of the available restarts. A value of :continue means to emit a warning
27 message and then invoke the a continue restart if one is available. If restarts
28 are available, but not ones that can be automatically selected by the handler,
29 then it will terminate the program. A value of :terminate means to terminate
30 on error, restartable or not.")
31
32 (defun mcvs-top-error-handler (condition)
33 (let ((available-restarts (compute-restarts)))
34 (when available-restarts
35 (let ((*print-escape* nil))
36 (ecase *mcvs-error-treatment*
37 ((:interactive)
38 (print-object condition t)
39 (format t
40 "~2&Choose one of the following ways of resolving this error:~%")
41 (format t "~%Type C to continue.~%")
42 (format t " A to continue and automatically continue~%")
43 (format t " any subsequent errors.~%")
44 (format t " T terminate mcvs.~%~%")
45 (loop
46 (format t "Your choice: ")
47 (let ((response (read-line)))
48 (if (> (length response) 0)
49 (let ((command (char-upcase (char response 0))))
50 (cond
51 ((char-equal command #\C)
52 (invoke-restart (first available-restarts)))
53 ((char-equal command #\A)
54 (setf *mcvs-error-treatment* :continue)
55 (invoke-restart (first available-restarts)))
56 ((char-equal command #\T)
57 (return))))))))
58 ((:continue)
59 (print-object condition *error-output*)
60 (format *error-output* "~&mcvs: auto-continuing.~%")
61 (invoke-restart (first available-restarts)))
62 ((:terminate))
63 (print-object condition *error-output*)
64 (return)))
65 (throw 'mcvs-terminate t))))
66
67 (defconstant *mcvs-command-table*
68 `(("import" ,#'mcvs-import-wrapper)
69 ("checkout" ,#'mcvs-checkout-wrapper)
70 ("co" ,#'mcvs-checkout-wrapper)
71 ("add" ,#'mcvs-add-wrapper)
72 ("remove" ,#'mcvs-remove-wrapper)
73 ("rm" ,#'mcvs-remove-wrapper)
74 ("move" ,#'mcvs-move-wrapper)
75 ("mv" ,#'mcvs-move-wrapper)
76 ("update" ,#'mcvs-update-wrapper)
77 ("up" ,#'mcvs-update-wrapper)
78 ("commit" ,#'mcvs-commit-wrapper)
79 ("ci" ,#'mcvs-commit-wrapper)
80 ("diff" ,#'mcvs-diff-wrapper)
81 ("filt" ,#'mcvs-filt-wrapper)
82 ("fi" ,#'mcvs-filt-wrapper)))
83
84 (defun mcvs-execute (args)
85 (handler-bind ((error #'mcvs-top-error-handler))
86 (multiple-value-bind (command-string cvs-options cvs-command-options
87 mcvs-args) (parse-args args)
88 (when (not command-string)
89 (error "mcvs: requires arguments."))
90 (let ((command (find command-string *mcvs-command-table* :key #'first
91 :test #'string=)))
92 (when (not command)
93 (error "mcvs: ~a is not a recognized mcvs command." command-string))
94 (funcall (second command)
95 cvs-options cvs-command-options mcvs-args)
96 nil))))
97
98 (defun mcvs-debug-shell ()
99 (let ((counter 0))
100 (loop
101 (format t "~&mcvs[~a]> " (incf counter))
102 (let ((line (string-trim #(#\space #\tab) (read-line))))
103 (can-restart-here ("Return to mcvs debug shell.~%")
104 (cond
105 ((zerop (length line)))
106 ((string-equal line "exit")
107 (return-from mcvs-debug-shell))
108 ((char-equal (char line 0) #\!)
109 (print (eval (read-from-string (subseq line 1)))))
110 (t (mcvs-execute (split-words line #(#\space #\tab))))))))))
111
112 (defconstant *cvs-options*
113 '("H" "help" "Q" "q" "f" "l" "n" "t" "r" "v" "--version" "w" "x"))
114
115 (defconstant *cvs-options-arg*
116 '("b" "d" "e" "z"))
117
118 (defconstant *cvs-command-options*
119 '("A" "f" "H" "help" "l" "n" "P" "p" "R" "u"))
120
121 (defconstant *cvs-command-options-arg*
122 '("D" "k" "r" "j" "m"))
123
124 (defun parse-args (args)
125 (multiple-value-bind (cvs-options args)
126 (parse-opt args *cvs-options* *cvs-options-arg* "mcvs")
127 (let ((command (first args)))
128 (multiple-value-bind (cvs-command-options args)
129 (parse-opt (rest args)
130 *cvs-command-options*
131 *cvs-command-options-arg*
132 "mcvs")
133 (values command cvs-options cvs-command-options args)))))
134
135 #+clisp
136 (defun mcvs ()
137 (if (catch 'mcvs-terminate (mcvs-execute ext:*args*))
138 (exit 1)
139 (exit 0)))

  ViewVC Help
Powered by ViewVC 1.1.5