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

Contents of /meta-cvs/F-233AD6EEE14894A7303F09519A2AB734

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Sun Feb 10 05:50:00 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-6, mcvs-0-5
Changes since 1.27: +2 -1 lines
* error.lisp (*mcvs-errors-occured-p*): New special variable.
(mcvs-error-handler): Set *mcvs-errors-occured-p* to T.
* mcvs-main.lisp (mcvs): Take *mcvs-errors-occured-p* into
account in computing termination status.
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 "filt")
13 (require "generic")
14 (require "convert")
15 (require "split")
16 (require "restart")
17 (require "error")
18 (require "options")
19 (provide "mcvs-main")
20
21 (defconstant *cvs-options*
22 '("H" "help" "Q" "q" "r" "w" "l" "n" "t" "v" "f" "a" "version"))
23
24 (defconstant *cvs-options-arg* '("T" "e" "d" "z" "s"))
25
26 (defconstant *import-options* '(("d") ("k" "I" "b" "m" "W")))
27 (defconstant *checkout-options* '(("A" "N" "f") ("r" "D" "d" "k" "j")))
28 (defconstant *add-options* '(() ("k" "m")))
29 (defconstant *remove-options* '(("R") ()))
30 (defconstant *update-options* '(("A" "f") ("k" "r" "D" "j" "I" "W")))
31 (defconstant *commit-options* '(("f") ("F" "m" "r")))
32 (defconstant *diff-options* '(("a" "b" "B" "brief" "c" "d" "e" "ed"
33 "expand-tabs" "f" "forward-ed" "H" "i"
34 "ignore-all-space" "ignore-blank-lines"
35 "ignore-case" "ignore-space-change"
36 "initial-tab" "l" "left-column" "minimal"
37 "n" "N" "new-file" "p" "P" "--paginate" "q"
38 "rcs" "report-identical-files" "s"
39 "show-c-function" "side-by-side"
40 "speed-large-files" "suppress-common-lines"
41 "t" "T" "text" "u" "unidirectional-new-file"
42 "w" "y")
43 ("C" "context" "D" "F" "horizon-lines" "ifdef"
44 "ignore-matching-lines" "L" "label"
45 "line-format" "new-group-format"
46 "new-line-format" "old-group-format"
47 "old-line-format" "r" "show-function-line"
48 "unchanged-group-format" "unchanged-line-format"
49 "U" "unified" "W" "width")))
50 (defconstant *tag-options* '(("l" "d" "f" "b" "F" "c") ("r" "D")))
51 (defconstant *log-options* '(("R" "h" "t" "N" "b") ("r" "d" "s" "w")))
52 (defconstant *status-options* '(("v") ()))
53 (defconstant *annotate-options* '(("f") ("r" "D")))
54 (defconstant *convert-options* '(() ()))
55
56 (defconstant *mcvs-command-table*
57 `(("import" ,#'mcvs-import-wrapper ,@*import-options*)
58 ("checkout" ,#'mcvs-checkout-wrapper ,@*checkout-options*)
59 ("co" ,#'mcvs-checkout-wrapper ,@*checkout-options*)
60 ("add" ,#'mcvs-add-wrapper ,@*add-options*)
61 ("remove" ,#'mcvs-remove-wrapper ,@*remove-options*)
62 ("rm" ,#'mcvs-remove-wrapper ,@*remove-options*)
63 ("move" ,#'mcvs-move-wrapper nil nil)
64 ("mv" ,#'mcvs-move-wrapper nil nil)
65 ("update" ,#'mcvs-update-wrapper ,@*update-options*)
66 ("up" ,#'mcvs-update-wrapper ,@*update-options*)
67 ("commit" ,#'mcvs-commit-wrapper ,@*commit-options*)
68 ("ci" ,#'mcvs-commit-wrapper ,@*commit-options*)
69 ("diff" ,#'mcvs-diff-wrapper ,@*diff-options*)
70 ("tag" ,#'mcvs-tag-wrapper ,@*tag-options*)
71 ("log" ,#'mcvs-log-wrapper ,@*log-options*)
72 ("status" ,#'mcvs-status-wrapper ,@*status-options*)
73 ("stat" ,#'mcvs-status-wrapper ,@*status-options*)
74 ("annotate" ,#'mcvs-annotate-wrapper ,@*annotate-options*)
75 ("filt" ,#'mcvs-filt-wrapper nil nil)
76 ("fi" ,#'mcvs-filt-wrapper nil nil)
77 ("convert" ,#'mcvs-convert-wrapper ,@*convert-options*)))
78
79 (defun mcvs-execute (args)
80 (handler-bind ((error #'mcvs-error-handler))
81 (multiple-value-bind (global-options global-args)
82 (parse-opt args *cvs-options*
83 *cvs-options-arg* "mcvs")
84 (when (not (first global-args))
85 (error "mcvs: requires arguments."))
86 (let ((command (find (first global-args) *mcvs-command-table*
87 :key #'first
88 :test #'string=)))
89 (when (not command)
90 (error "mcvs: ~a is not a recognized mcvs command."
91 (first global-args)))
92 (destructuring-bind (name func noarg-opts arg-opts) command
93 (declare (ignore name))
94 (multiple-value-bind (command-options command-args)
95 (parse-opt (rest global-args)
96 noarg-opts arg-opts "mcvs")
97 (funcall func global-options command-options command-args))))))
98 nil)
99
100 (defun mcvs-debug-shell ()
101 (let ((counter 0)
102 (*mcvs-error-treatment* :decline))
103 (loop
104 (format t "~&mcvs[~a]> " (incf counter))
105 (let ((line (string-trim #(#\space #\tab) (read-line))))
106 (can-restart-here ("Return to mcvs debug shell.~%")
107 (cond
108 ((zerop (length line)))
109 ((string-equal line "exit")
110 (return-from mcvs-debug-shell))
111 ((char-equal (char line 0) #\!)
112 (print (eval (read-from-string (subseq line 1)))))
113 (t (mcvs-execute (split-words line #(#\space #\tab))))))))))
114
115 #+clisp
116 (defun mcvs ()
117 (exit (catch 'mcvs-terminate (or (mcvs-execute ext:*args*)
118 *mcvs-errors-occured-p*))))

  ViewVC Help
Powered by ViewVC 1.1.5