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

Diff of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by kaz, Sat Oct 5 18:09:48 2002 UTC revision 1.13.2.9 by kaz, Thu Apr 24 04:02:55 2003 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5    (require "system")
6    (require "chatter")
7  (require "find-bind")  (require "find-bind")
8  (require "split")  (require "split")
9  (require "error")  (require "error")
10  (provide "options")  (provide "options")
11    
12    (defvar *print-usage* nil)
13  (defvar *nometa-option* nil)  (defvar *nometa-option* nil)
14  (defvar *meta-option* nil)  (defvar *meta-option* nil)
15  (defvar *metaonly-option* nil)  (defvar *metaonly-option* nil)
16    (defvar *dry-run-option* nil)
17    (defvar *nesting-escape-option* 0)
18    
19  (defun option-spec-expand (num-args string-list)  (defun option-spec-expand (num-args string-list)
20    (mapcar #'(lambda (string) (list string num-args))    (mapcar #'(lambda (string) (list string num-args))
# Line 84  of strings." Line 89  of strings."
89                      (arg (rest option-list)))                      (arg (rest option-list)))
90                  (if (> (length option) 1)                  (if (> (length option) 1)
91                    (cons (format nil "--~a" option) arg)                    (cons (format nil "--~a" option) arg)
92                    (cons (format nil "-~a" option) arg)))) options))                    (if (= (length arg) 1)
93                        (list (format nil "-~a~a" option (first arg)))
94                        (cons (format nil "-~a" option) arg)))))
95              options))
96    
97  (defun filter-global-options (opts)  (defun filter-mcvs-options (opts)
98  "Processes and removes any Meta-CVS-specific options."  "Processes and removes any Meta-CVS-specific options."
99    (find-bind (:test #'string= :key #'first)    (find-bind (:test #'string= :key #'first)
100               (remainder (meta "meta")               (remainder (meta "meta")
# Line 94  of strings." Line 102  of strings."
102                          (nometa "nometa")                          (nometa "nometa")
103                          (ec "error-continue")                          (ec "error-continue")
104                          (et "error-terminate")                          (et "error-terminate")
105                            (nesting-escape "up")
106                          (debug "debug"))                          (debug "debug"))
107               opts               opts
108      (when (and meta nometa)      (when (and meta nometa)
# Line 103  of strings." Line 112  of strings."
112      (setf *meta-option* meta)      (setf *meta-option* meta)
113      (setf *metaonly-option* metaonly)      (setf *metaonly-option* metaonly)
114      (setf *nometa-option* nometa)      (setf *nometa-option* nometa)
115        (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      (when debug      (when debug
123        (setf *mcvs-chatter-level* *mcvs-debug*))        (setf *mcvs-chatter-level* *mcvs-debug*))
124      (cond      (cond
125        (et (setf *mcvs-error-treatment* :terminate))        (ec (setf *mcvs-error-treatment* :continue))
126        (ec (setf *mcvs-error-treatment* :continue)))        (et (setf *mcvs-error-treatment* :terminate)))
127      remainder))      remainder))
128    
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                  (editor "e") (interpret-file "i") (dry-run "n"))
135                 opts
136        (when (or help-long help)
137          (setf *print-usage* t))
138        (when (or version version-long)
139          (let* ((vers (split-words "$Name$" "$:- "))
140                 (major (third vers))
141                 (minor (fourth vers))
142                 (patch (fifth vers)))
143            (if (and major minor patch)
144              (format t "Meta-CVS version ~a.~a.~a (C) 2002, 2003 Kaz Kylheku~%"
145                      major minor patch)
146              (format t "Meta-CVS unknown version (C) 2002, 2003 Kaz Kylheku~%"))
147            (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        (when dry-run
154          (setf *dry-run-option* t))
155        (when interpret-file
156          (load (second interpret-file))
157          (throw 'mcvs-terminate nil)))
158      opts)
159    
160    (defun filter-global-options (opts)
161      (process-cvs-options (filter-mcvs-options opts)))
162    
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)))

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.13.2.9

  ViewVC Help
Powered by ViewVC 1.1.5