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

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Mon Jan 28 01:11:36 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.13: +2 -1 lines
Add "fi" shorthand for "filt".
1 ;;; This source file is part of the MCVS 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 #+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 (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 (when (null args)
87 (error "mcvs: requires arguments."))
88 (multiple-value-bind (command-string cvs-options cvs-command-options
89 mcvs-args) (parse-args args)
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
97 (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 (can-restart-here ("Return to mcvs debug shell.~%")
103 (cond
104 ((zerop (length line)))
105 ((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
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 '("A" "f" "H" "help" "l" "n" "P" "p" "R" "u"))
119
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 #+clisp
135 (defun mcvs ()
136 (mcvs-execute ext:*args*))

  ViewVC Help
Powered by ViewVC 1.1.5