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

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Fri Feb 1 08:56:55 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.17: +62 -48 lines
* mcvs-main.lisp (mcvs-execute): Parse command-specific options
properly based on knowledge of each command's set of options.
(parse-args): Function removed.
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 *cvs-options*
68 '("H" "help" "Q" "q" "r" "w" "l" "n" "t" "v" "f" "a" "version"))
69
70 (defconstant *cvs-options-arg* '("T" "e" "d" "z" "s"))
71
72 (defconstant *import-options* '(("d") ("k" "I" "b" "m" "W")))
73 (defconstant *checkout-options* '(("A" "N" "f") ("r" "D" "d" "k" "j")))
74 (defconstant *add-options* '(() ("k" "m")))
75 (defconstant *remove-options* '(("R") ()))
76 (defconstant *update-options* '(("A" "f") ("k" "r" "D" "j" "I" "W")))
77 (defconstant *commit-options* '(("f") ("F" "m" "r")))
78 (defconstant *diff-options* '(("a" "b" "B" "brief" "c" "d" "e" "ed"
79 "expand-tabs" "f" "forward-ed" "H" "i"
80 "ignore-all-space" "ignore-blank-lines"
81 "ignore-case" "ignore-space-change"
82 "initial-tab" "l" "left-column" "minimal"
83 "n" "N" "new-file" "p" "P" "--paginate" "q"
84 "rcs" "report-identical-files" "s"
85 "show-c-function" "side-by-side"
86 "speed-large-files" "suppress-common-lines"
87 "t" "T" "text" "u" "unidirectional-new-file"
88 "w" "y")
89 ("C" "context" "F" "horizon-lines" "ifdef"
90 "ignore-matching-lines" "L" "label"
91 "line-format" "new-group-format"
92 "new-line-format" "old-group-format"
93 "old-line-format" "show-function-line"
94 "unchanged-group-format" "unchanged-line-format"
95 "U" "unified" "W" "width")))
96
97 (defconstant *mcvs-command-table*
98 `(("import" ,#'mcvs-import-wrapper ,@*import-options*)
99 ("checkout" ,#'mcvs-checkout-wrapper ,@*checkout-options*)
100 ("co" ,#'mcvs-checkout-wrapper ,@*checkout-options*)
101 ("add" ,#'mcvs-add-wrapper ,@*add-options*)
102 ("remove" ,#'mcvs-remove-wrapper ,@*remove-options*)
103 ("rm" ,#'mcvs-remove-wrapper ,@*remove-options*)
104 ("move" ,#'mcvs-move-wrapper nil nil)
105 ("mv" ,#'mcvs-move-wrapper nil nil)
106 ("update" ,#'mcvs-update-wrapper ,@*update-options*)
107 ("up" ,#'mcvs-update-wrapper ,@*update-options*)
108 ("commit" ,#'mcvs-commit-wrapper ,@*commit-options*)
109 ("ci" ,#'mcvs-commit-wrapper ,@*commit-options*)
110 ("diff" ,#'mcvs-diff-wrapper ,@*diff-options*)
111 ("filt" ,#'mcvs-filt-wrapper nil nil)
112 ("fi" ,#'mcvs-filt-wrapper nil nil)))
113
114 (defun mcvs-execute (args)
115 (handler-bind ((error #'mcvs-top-error-handler))
116 (multiple-value-bind (global-options global-args)
117 (parse-opt args *cvs-options*
118 *cvs-options-arg* "mcvs")
119 (when (not (first global-args))
120 (error "mcvs: requires arguments."))
121 (let ((command (find (first global-args) *mcvs-command-table*
122 :key #'first
123 :test #'string=)))
124 (when (not command)
125 (error "mcvs: ~a is not a recognized mcvs command."
126 (first global-args)))
127 (destructuring-bind (name func noarg-opts arg-opts) command
128 (declare (ignore name))
129 (multiple-value-bind (command-options command-args)
130 (parse-opt (rest global-args)
131 noarg-opts arg-opts "mcvs")
132 (funcall func global-options command-options command-args))))))
133 nil)
134
135 (defun mcvs-debug-shell ()
136 (let ((counter 0))
137 (loop
138 (format t "~&mcvs[~a]> " (incf counter))
139 (let ((line (string-trim #(#\space #\tab) (read-line))))
140 (can-restart-here ("Return to mcvs debug shell.~%")
141 (cond
142 ((zerop (length line)))
143 ((string-equal line "exit")
144 (return-from mcvs-debug-shell))
145 ((char-equal (char line 0) #\!)
146 (print (eval (read-from-string (subseq line 1)))))
147 (t (mcvs-execute (split-words line #(#\space #\tab))))))))))
148
149 #+clisp
150 (defun mcvs ()
151 (if (catch 'mcvs-terminate (mcvs-execute ext:*args*))
152 (exit 1)
153 (exit 0)))

  ViewVC Help
Powered by ViewVC 1.1.5