/[meta-cvs]/meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490
ViewVC logotype

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13.2.9 - (hide annotations)
Thu Apr 24 04:02:55 2003 UTC (11 years ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-7
Changes since 1.13.2.8: +0 -2 lines
Improved error handling again in a flash of sanity. The whole
idea of ``bail'' as a restart is gone. All code which must perform
some complex cleanup action does so as part of normal unwinding.
And so termination becomes safe.

* code/update.lisp (mcvs-update): Change bail restart to continue.

* code/mcvs-main.lisp (*global-options*): Remove "error-bail".
(*usage*): Remove description of --error-bail.
(mcvs-execute): Bind *mcvs-error-treatment* to :terminate rather
than :bail if controlling TTY cannot be opened.

* code/move.lisp (mcvs-move): Change "Undoing move" error message
to "Undoing changes to map".

* code/add.lisp (mcvs-add): Get rid of bail restart; move cleanup
code into unwind-protect block.

* code/error.lisp (*mcvs-error-treatment*): Touch up docstring.
(mcvs-error-handler): Remove anything having to do with :bail.
Change description of `T' command to suggest that it is safe.

* code/options.lisp (filter-mcvs-options): Remove handling of
"error-bail" option.

* code/mapping.lisp (mapping-update): Get rid of outermost
restart-case, which had just a bail restart. Replace it with
unwind-protect block which does exactly the same restoration.
1 kaz 1.3 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.1 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.13.2.1 (require "system")
6     (require "chatter")
7 kaz 1.9 (require "find-bind")
8 kaz 1.10 (require "split")
9 kaz 1.12 (require "error")
10 kaz 1.1 (provide "options")
11    
12 kaz 1.13.2.1 (defvar *print-usage* nil)
13 kaz 1.9 (defvar *nometa-option* nil)
14     (defvar *meta-option* nil)
15     (defvar *metaonly-option* nil)
16 kaz 1.13.2.2 (defvar *dry-run-option* nil)
17 kaz 1.13.2.5 (defvar *nesting-escape-option* 0)
18 kaz 1.7
19 kaz 1.10 (defun option-spec-expand (num-args string-list)
20     (mapcar #'(lambda (string) (list string num-args))
21     string-list))
22    
23     (defmacro option-spec (&rest option-specs)
24     `(append ,@(mapcar #'(lambda (spec)
25     (destructuring-bind (number word &rest strings) spec
26     (when (not (string= (symbol-name word) "ARG"))
27     (error "OPTIONS: word \"ARG\" expected."))
28     `(option-spec-expand ,number ',strings)))
29     option-specs)))
30    
31     (defmacro define-option-constant (var &rest option-specs)
32     `(defconstant ,var (option-spec ,@option-specs)))
33    
34     (defun parse-opt (arguments option-spec)
35     (flet ((process-option (arg)
36     (let* ((split-opt (split-fields arg #(#\=)))
37     (opt-name (first split-opt))
38     (opt-arg (second split-opt))
39     (spec (find opt-name option-spec
40     :test #'string=
41     :key #'first)))
42     (when (null spec)
43 kaz 1.13 (error "unknown option ~a." opt-name))
44 kaz 1.10 (when opt-arg
45     (push opt-arg arguments))
46     (let ((num-req-params (second spec))
47     (opt-args ()))
48     (dotimes (i num-req-params)
49     (let ((opt-arg (pop arguments)))
50     (when (null opt-arg)
51 kaz 1.13 (error "option ~a requires ~a parameter~:p."
52 kaz 1.10 opt-name num-req-params))
53     (push opt-arg opt-args)))
54     (cons opt-name (nreverse opt-args))))))
55     (let ((parsed-options ()))
56 kaz 1.1 (loop
57 kaz 1.10 (if (null arguments)
58     (return))
59     (let ((arg (pop arguments)))
60     (cond
61     ((string= arg "--")
62     (return))
63     ((and (> (length arg) 2) (string= (subseq arg 0 2) "--"))
64     (push (process-option (subseq arg 2)) parsed-options))
65     ((and (> (length arg) 1) (char= (char arg 0) #\-))
66     (let ((num-chars (- (length arg) 1))
67     (last-iter (- (length arg) 2)))
68     (dotimes (i num-chars)
69     (let ((option (subseq arg (+ i 1) (+ i 2)))
70     (arg (subseq arg (+ i 2))))
71     (when (< i last-iter)
72     (push arg arguments))
73     (let ((result (process-option option)))
74     (push result parsed-options)
75     (when (and (second result)
76     (/= i (- (length arg) 2)))
77     (return))
78     (when (< i last-iter)
79     (pop arguments)))))))
80     (t (push arg arguments)
81     (return)))))
82     (values (nreverse parsed-options) arguments))))
83    
84 kaz 1.1 (defun format-opt (options)
85     "Convert list of options as produced by parse-opt back into a list
86     of strings."
87     (mapcan #'(lambda (option-list)
88     (let ((option (first option-list))
89     (arg (rest option-list)))
90     (if (> (length option) 1)
91     (cons (format nil "--~a" option) arg)
92 kaz 1.13.2.6 (if (= (length arg) 1)
93     (list (format nil "-~a~a" option (first arg)))
94     (cons (format nil "-~a" option) arg)))))
95     options))
96 kaz 1.7
97 kaz 1.13.2.1 (defun filter-mcvs-options (opts)
98 kaz 1.7 "Processes and removes any Meta-CVS-specific options."
99 kaz 1.9 (find-bind (:test #'string= :key #'first)
100     (remainder (meta "meta")
101     (metaonly "metaonly")
102 kaz 1.12 (nometa "nometa")
103     (ec "error-continue")
104 kaz 1.13 (et "error-terminate")
105 kaz 1.13.2.5 (nesting-escape "up")
106 kaz 1.13 (debug "debug"))
107 kaz 1.9 opts
108     (when (and meta nometa)
109 kaz 1.13 (error "cannot specify both --nometa and --meta"))
110 kaz 1.9 (when (and metaonly nometa)
111 kaz 1.13 (error "cannot specify both --nometa and --metaonly"))
112 kaz 1.9 (setf *meta-option* meta)
113     (setf *metaonly-option* metaonly)
114     (setf *nometa-option* nometa)
115 kaz 1.13.2.5 (when nesting-escape
116     (unless (setf *nesting-escape-option*
117     (parse-integer (second nesting-escape)
118     :junk-allowed t))
119     (error "--up option takes integer argument"))
120     (unless (>= *nesting-escape-option* 0)
121     (error "--up argument must be nonnegative")))
122 kaz 1.13 (when debug
123     (setf *mcvs-chatter-level* *mcvs-debug*))
124 kaz 1.12 (cond
125 kaz 1.13.2.8 (ec (setf *mcvs-error-treatment* :continue))
126     (et (setf *mcvs-error-treatment* :terminate)))
127 kaz 1.9 remainder))
128 kaz 1.13.2.1
129     (defun process-cvs-options (opts)
130     "Take care of any CVS options that must also be interpreted by Meta-CVS."
131     (find-bind (:test #'string= :key #'first)
132     ((help-long "help") (help "H") (quiet "q")
133     (very-quiet "Q") (version "v") (version-long "version")
134 kaz 1.13.2.2 (editor "e") (interpret-file "i") (dry-run "n"))
135 kaz 1.13.2.1 opts
136     (when (or help-long help)
137     (setf *print-usage* t))
138     (when (or version version-long)
139 kaz 1.13.2.5 (let* ((vers (split-words "$Name: $" "$:- "))
140 kaz 1.13.2.1 (major (third vers))
141 kaz 1.13.2.4 (minor (fourth vers))
142     (patch (fifth vers)))
143     (if (and major minor patch)
144 kaz 1.13.2.7 (format t "Meta-CVS version ~a.~a.~a (C) 2002, 2003 Kaz Kylheku~%"
145 kaz 1.13.2.4 major minor patch)
146 kaz 1.13.2.7 (format t "Meta-CVS unknown version (C) 2002, 2003 Kaz Kylheku~%"))
147 kaz 1.13.2.1 (throw 'mcvs-terminate nil)))
148     (when editor
149     (setf *mcvs-editor* (second editor)))
150     (cond
151     (very-quiet (setf *mcvs-chatter-level* *mcvs-silent*))
152     (quiet (setf *mcvs-chatter-level* *mcvs-terse*)))
153 kaz 1.13.2.2 (when dry-run
154     (setf *dry-run-option* t))
155 kaz 1.13.2.1 (when interpret-file
156 kaz 1.13.2.2 (load (second interpret-file))
157     (throw 'mcvs-terminate nil)))
158 kaz 1.13.2.1 opts)
159    
160     (defun filter-global-options (opts)
161     (process-cvs-options (filter-mcvs-options opts)))
162 kaz 1.13.2.3
163     (defmacro honor-dry-run (vars &rest forms)
164     `(cond
165     (*dry-run-option*
166     (chatter-debug
167     "Because of -n option, not executing ~s with bindings ~s.~%"
168     ',forms
169     (list ,@(mapcar #'(lambda (var) `(list ',var ,var)) vars))))
170     (t ,@forms)))

  ViewVC Help
Powered by ViewVC 1.1.5