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

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Fri Feb 1 09:16:52 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.18: +2 -2 lines
Forgot a few important diff options.
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.2 (require "diff")
13 kaz 1.12 (require "filt")
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    
97 kaz 1.5 (defconstant *mcvs-command-table*
98 kaz 1.18 `(("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 kaz 1.5
114     (defun mcvs-execute (args)
115 kaz 1.11 (handler-bind ((error #'mcvs-top-error-handler))
116 kaz 1.18 (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 kaz 1.11 (when (not command)
125 kaz 1.18 (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 kaz 1.5
135 kaz 1.8 (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 kaz 1.9 (can-restart-here ("Return to mcvs debug shell.~%")
141 kaz 1.8 (cond
142 kaz 1.9 ((zerop (length line)))
143 kaz 1.8 ((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 kaz 1.10
149 kaz 1.5 #+clisp
150     (defun mcvs ()
151 kaz 1.17 (if (catch 'mcvs-terminate (mcvs-execute ext:*args*))
152     (exit 1)
153     (exit 0)))

  ViewVC Help
Powered by ViewVC 1.1.5