/[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.3 - (hide annotations)
Mon Nov 4 02:07:35 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0, mcvs-0-99
Changes since 1.13.2.2: +9 -0 lines
More support for -n option.

* code/mcvs-main.lisp (*usage*): Document -n option.

* code/move.lisp (mcvs-move-wrapper): Remove bogus error check
for presence of global options.

* code/options.lisp (honor-dry-run): New macro for conditionally
not executing some forms if it's a dry run, and logging some
debugging information.

* code/sync.lisp (synchronize-files): Honor dry run.

* code/mapping.lisp (mapping-synchronize, mapping-update): Likewise.
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.7
18 kaz 1.10 (defun option-spec-expand (num-args string-list)
19     (mapcar #'(lambda (string) (list string num-args))
20     string-list))
21    
22     (defmacro option-spec (&rest option-specs)
23     `(append ,@(mapcar #'(lambda (spec)
24     (destructuring-bind (number word &rest strings) spec
25     (when (not (string= (symbol-name word) "ARG"))
26     (error "OPTIONS: word \"ARG\" expected."))
27     `(option-spec-expand ,number ',strings)))
28     option-specs)))
29    
30     (defmacro define-option-constant (var &rest option-specs)
31     `(defconstant ,var (option-spec ,@option-specs)))
32    
33     (defun parse-opt (arguments option-spec)
34     (flet ((process-option (arg)
35     (let* ((split-opt (split-fields arg #(#\=)))
36     (opt-name (first split-opt))
37     (opt-arg (second split-opt))
38     (spec (find opt-name option-spec
39     :test #'string=
40     :key #'first)))
41     (when (null spec)
42 kaz 1.13 (error "unknown option ~a." opt-name))
43 kaz 1.10 (when opt-arg
44     (push opt-arg arguments))
45     (let ((num-req-params (second spec))
46     (opt-args ()))
47     (dotimes (i num-req-params)
48     (let ((opt-arg (pop arguments)))
49     (when (null opt-arg)
50 kaz 1.13 (error "option ~a requires ~a parameter~:p."
51 kaz 1.10 opt-name num-req-params))
52     (push opt-arg opt-args)))
53     (cons opt-name (nreverse opt-args))))))
54     (let ((parsed-options ()))
55 kaz 1.1 (loop
56 kaz 1.10 (if (null arguments)
57     (return))
58     (let ((arg (pop arguments)))
59     (cond
60     ((string= arg "--")
61     (return))
62     ((and (> (length arg) 2) (string= (subseq arg 0 2) "--"))
63     (push (process-option (subseq arg 2)) parsed-options))
64     ((and (> (length arg) 1) (char= (char arg 0) #\-))
65     (let ((num-chars (- (length arg) 1))
66     (last-iter (- (length arg) 2)))
67     (dotimes (i num-chars)
68     (let ((option (subseq arg (+ i 1) (+ i 2)))
69     (arg (subseq arg (+ i 2))))
70     (when (< i last-iter)
71     (push arg arguments))
72     (let ((result (process-option option)))
73     (push result parsed-options)
74     (when (and (second result)
75     (/= i (- (length arg) 2)))
76     (return))
77     (when (< i last-iter)
78     (pop arguments)))))))
79     (t (push arg arguments)
80     (return)))))
81     (values (nreverse parsed-options) arguments))))
82    
83 kaz 1.1 (defun format-opt (options)
84     "Convert list of options as produced by parse-opt back into a list
85     of strings."
86     (mapcan #'(lambda (option-list)
87     (let ((option (first option-list))
88     (arg (rest option-list)))
89     (if (> (length option) 1)
90     (cons (format nil "--~a" option) arg)
91     (cons (format nil "-~a" option) arg)))) options))
92 kaz 1.7
93 kaz 1.13.2.1 (defun filter-mcvs-options (opts)
94 kaz 1.7 "Processes and removes any Meta-CVS-specific options."
95 kaz 1.9 (find-bind (:test #'string= :key #'first)
96     (remainder (meta "meta")
97     (metaonly "metaonly")
98 kaz 1.12 (nometa "nometa")
99     (ec "error-continue")
100 kaz 1.13 (et "error-terminate")
101     (debug "debug"))
102 kaz 1.9 opts
103     (when (and meta nometa)
104 kaz 1.13 (error "cannot specify both --nometa and --meta"))
105 kaz 1.9 (when (and metaonly nometa)
106 kaz 1.13 (error "cannot specify both --nometa and --metaonly"))
107 kaz 1.9 (setf *meta-option* meta)
108     (setf *metaonly-option* metaonly)
109     (setf *nometa-option* nometa)
110 kaz 1.13 (when debug
111     (setf *mcvs-chatter-level* *mcvs-debug*))
112 kaz 1.12 (cond
113     (et (setf *mcvs-error-treatment* :terminate))
114     (ec (setf *mcvs-error-treatment* :continue)))
115 kaz 1.9 remainder))
116 kaz 1.13.2.1
117     (defun process-cvs-options (opts)
118     "Take care of any CVS options that must also be interpreted by Meta-CVS."
119     (find-bind (:test #'string= :key #'first)
120     ((help-long "help") (help "H") (quiet "q")
121     (very-quiet "Q") (version "v") (version-long "version")
122 kaz 1.13.2.2 (editor "e") (interpret-file "i") (dry-run "n"))
123 kaz 1.13.2.1 opts
124     (when (or help-long help)
125     (setf *print-usage* t))
126     (when (or version version-long)
127     (let* ((vers (split-words "$Name: $" "$:- "))
128     (major (third vers))
129     (minor (fourth vers)))
130     (if (and major minor)
131     (format t "Meta-CVS version ~a.~a (c) 2002 Kaz Kylheku~%"
132     major minor)
133     (format t "Meta-CVS unknown version (c) 2002 Kaz Kylheku~%"))
134     (throw 'mcvs-terminate nil)))
135     (when editor
136     (setf *mcvs-editor* (second editor)))
137     (cond
138     (very-quiet (setf *mcvs-chatter-level* *mcvs-silent*))
139     (quiet (setf *mcvs-chatter-level* *mcvs-terse*)))
140 kaz 1.13.2.2 (when dry-run
141     (setf *dry-run-option* t))
142 kaz 1.13.2.1 (when interpret-file
143 kaz 1.13.2.2 (load (second interpret-file))
144     (throw 'mcvs-terminate nil)))
145 kaz 1.13.2.1 opts)
146    
147     (defun filter-global-options (opts)
148     (process-cvs-options (filter-mcvs-options opts)))
149 kaz 1.13.2.3
150     (defmacro honor-dry-run (vars &rest forms)
151     `(cond
152     (*dry-run-option*
153     (chatter-debug
154     "Because of -n option, not executing ~s with bindings ~s.~%"
155     ',forms
156     (list ,@(mapcar #'(lambda (var) `(list ',var ,var)) vars))))
157     (t ,@forms)))

  ViewVC Help
Powered by ViewVC 1.1.5