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

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations)
Mon Feb 4 06:34:55 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-4
Changes since 1.22: +3 -3 lines
Oops, fix wrong options in command table.
1 kaz 1.16 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.7 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "import")
6     (require "checkout")
7     (require "add")
8 kaz 1.3 (require "remove")
9 kaz 1.4 (require "move")
10 kaz 1.1 (require "update")
11     (require "commit")
12 kaz 1.12 (require "filt")
13 kaz 1.21 (require "generic")
14 kaz 1.8 (require "split")
15     (require "restart")
16 kaz 1.10 (require "options")
17 kaz 1.6 (provide "mcvs-main")
18 kaz 1.5
19 kaz 1.11 (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 kaz 1.17 (return))))))))
58 kaz 1.11 ((: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 kaz 1.17 (return)))
65     (throw 'mcvs-terminate t))))
66 kaz 1.11
67 kaz 1.18 (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 kaz 1.19 ("C" "context" "D" "F" "horizon-lines" "ifdef"
90 kaz 1.18 "ignore-matching-lines" "L" "label"
91     "line-format" "new-group-format"
92     "new-line-format" "old-group-format"
93 kaz 1.19 "old-line-format" "r" "show-function-line"
94 kaz 1.18 "unchanged-group-format" "unchanged-line-format"
95     "U" "unified" "W" "width")))
96 kaz 1.21 (defconstant *tag-options* '(("l" "d" "f" "b" "F" "c") ("r" "D")))
97 kaz 1.22 (defconstant *log-options* '(("R" "h" "t" "N" "b") ("r" "d" "s" "w")))
98     (defconstant *status-options* '(("v") ()))
99     (defconstant *annotate-options* '("f") ("r" "D"))
100 kaz 1.18
101 kaz 1.5 (defconstant *mcvs-command-table*
102 kaz 1.18 `(("import" ,#'mcvs-import-wrapper ,@*import-options*)
103     ("checkout" ,#'mcvs-checkout-wrapper ,@*checkout-options*)
104     ("co" ,#'mcvs-checkout-wrapper ,@*checkout-options*)
105     ("add" ,#'mcvs-add-wrapper ,@*add-options*)
106     ("remove" ,#'mcvs-remove-wrapper ,@*remove-options*)
107     ("rm" ,#'mcvs-remove-wrapper ,@*remove-options*)
108     ("move" ,#'mcvs-move-wrapper nil nil)
109     ("mv" ,#'mcvs-move-wrapper nil nil)
110     ("update" ,#'mcvs-update-wrapper ,@*update-options*)
111     ("up" ,#'mcvs-update-wrapper ,@*update-options*)
112     ("commit" ,#'mcvs-commit-wrapper ,@*commit-options*)
113     ("ci" ,#'mcvs-commit-wrapper ,@*commit-options*)
114     ("diff" ,#'mcvs-diff-wrapper ,@*diff-options*)
115 kaz 1.21 ("tag" ,#'mcvs-tag-wrapper ,@*tag-options*)
116 kaz 1.23 ("log" ,#'mcvs-log-wrapper ,@*log-options*)
117     ("status" ,#'mcvs-status-wrapper ,@*status-options*)
118     ("annotate" ,#'mcvs-annotate-wrapper ,@*annotate-options*)
119 kaz 1.18 ("filt" ,#'mcvs-filt-wrapper nil nil)
120     ("fi" ,#'mcvs-filt-wrapper nil nil)))
121 kaz 1.5
122     (defun mcvs-execute (args)
123 kaz 1.11 (handler-bind ((error #'mcvs-top-error-handler))
124 kaz 1.18 (multiple-value-bind (global-options global-args)
125     (parse-opt args *cvs-options*
126     *cvs-options-arg* "mcvs")
127     (when (not (first global-args))
128     (error "mcvs: requires arguments."))
129     (let ((command (find (first global-args) *mcvs-command-table*
130     :key #'first
131     :test #'string=)))
132 kaz 1.11 (when (not command)
133 kaz 1.18 (error "mcvs: ~a is not a recognized mcvs command."
134     (first global-args)))
135     (destructuring-bind (name func noarg-opts arg-opts) command
136     (declare (ignore name))
137     (multiple-value-bind (command-options command-args)
138     (parse-opt (rest global-args)
139     noarg-opts arg-opts "mcvs")
140     (funcall func global-options command-options command-args))))))
141     nil)
142 kaz 1.5
143 kaz 1.8 (defun mcvs-debug-shell ()
144     (let ((counter 0))
145     (loop
146     (format t "~&mcvs[~a]> " (incf counter))
147     (let ((line (string-trim #(#\space #\tab) (read-line))))
148 kaz 1.9 (can-restart-here ("Return to mcvs debug shell.~%")
149 kaz 1.8 (cond
150 kaz 1.9 ((zerop (length line)))
151 kaz 1.8 ((string-equal line "exit")
152     (return-from mcvs-debug-shell))
153     ((char-equal (char line 0) #\!)
154     (print (eval (read-from-string (subseq line 1)))))
155     (t (mcvs-execute (split-words line #(#\space #\tab))))))))))
156 kaz 1.10
157 kaz 1.5 #+clisp
158     (defun mcvs ()
159 kaz 1.20 (exit (catch 'mcvs-terminate (mcvs-execute ext:*args*))))

  ViewVC Help
Powered by ViewVC 1.1.5