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

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Thu Jan 31 05:35:01 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-2
Changes since 1.15: +1 -1 lines
MCVS is being renamed to Meta-CVS.
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     #+clisp (exit 1))))))))
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     (format *error-output* "~&mcvs: terminating.~%")
65     #+clisp (exit 1))))))
66    
67 kaz 1.5 (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 kaz 1.12 ("diff" ,#'mcvs-diff-wrapper)
81 kaz 1.14 ("filt" ,#'mcvs-filt-wrapper)
82     ("fi" ,#'mcvs-filt-wrapper)))
83 kaz 1.5
84     (defun mcvs-execute (args)
85 kaz 1.11 (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 kaz 1.15 (when (not command-string)
89     (error "mcvs: requires arguments."))
90 kaz 1.11 (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 kaz 1.5
97 kaz 1.8 (defun mcvs-debug-shell ()
98     (let ((counter 0))
99     (loop
100     (format t "~&mcvs[~a]> " (incf counter))
101     (let ((line (string-trim #(#\space #\tab) (read-line))))
102 kaz 1.9 (can-restart-here ("Return to mcvs debug shell.~%")
103 kaz 1.8 (cond
104 kaz 1.9 ((zerop (length line)))
105 kaz 1.8 ((string-equal line "exit")
106     (return-from mcvs-debug-shell))
107     ((char-equal (char line 0) #\!)
108     (print (eval (read-from-string (subseq line 1)))))
109     (t (mcvs-execute (split-words line #(#\space #\tab))))))))))
110 kaz 1.10
111     (defconstant *cvs-options*
112     '("H" "help" "Q" "q" "f" "l" "n" "t" "r" "v" "--version" "w" "x"))
113    
114     (defconstant *cvs-options-arg*
115     '("b" "d" "e" "z"))
116    
117     (defconstant *cvs-command-options*
118 kaz 1.13 '("A" "f" "H" "help" "l" "n" "P" "p" "R" "u"))
119 kaz 1.10
120     (defconstant *cvs-command-options-arg*
121     '("D" "k" "r" "j" "m"))
122    
123     (defun parse-args (args)
124     (multiple-value-bind (cvs-options args)
125     (parse-opt args *cvs-options* *cvs-options-arg* "mcvs")
126     (let ((command (first args)))
127     (multiple-value-bind (cvs-command-options args)
128     (parse-opt (rest args)
129     *cvs-command-options*
130     *cvs-command-options-arg*
131     "mcvs")
132     (values command cvs-options cvs-command-options args)))))
133    
134 kaz 1.5 #+clisp
135     (defun mcvs ()
136     (mcvs-execute ext:*args*))

  ViewVC Help
Powered by ViewVC 1.1.5