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

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Sat Mar 8 02:43:16 2008 UTC (6 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.27: +23 -14 lines
Implement -x option.
Allow repetitions of -i.

* code/main.lisp (*global-options*): Add "x" as a 1 arg option.
(*usage*): Describe -x in help text.
(execute): Execute all forms in the newly introduced *exec-list*
before invoking the command (if there is one). Only complain about a
missing command if the *exec-list* is empty.

* code/options.lisp (*exec-list*): New dynamic variable.
(filter-mcvs-options): Look for -x and -i options in the options,
remove them, and turn them into items in the *exec-list*.
The arguments of -x are parsed as Lisp using read-from-string.
The -i arguments are turned into (LOAD ...) forms.
(process-cvs-options): The -i option is no longer handled here.
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.24 (in-package :meta-cvs)
6 kaz 1.1
7 kaz 1.15 (defvar *print-usage* nil)
8 kaz 1.9 (defvar *nometa-option* nil)
9     (defvar *meta-option* nil)
10     (defvar *metaonly-option* nil)
11 kaz 1.15 (defvar *dry-run-option* nil)
12 kaz 1.17 (defvar *nesting-escape-option* 0)
13 kaz 1.25 (defvar *nofilt-option* nil)
14 kaz 1.28 (defvar *exec-list* nil)
15 kaz 1.7
16 kaz 1.10 (defun option-spec-expand (num-args string-list)
17     (mapcar #'(lambda (string) (list string num-args))
18     string-list))
19    
20     (defmacro option-spec (&rest option-specs)
21     `(append ,@(mapcar #'(lambda (spec)
22     (destructuring-bind (number word &rest strings) spec
23     (when (not (string= (symbol-name word) "ARG"))
24     (error "OPTIONS: word \"ARG\" expected."))
25     `(option-spec-expand ,number ',strings)))
26     option-specs)))
27    
28     (defmacro define-option-constant (var &rest option-specs)
29     `(defconstant ,var (option-spec ,@option-specs)))
30    
31     (defun parse-opt (arguments option-spec)
32     (flet ((process-option (arg)
33     (let* ((split-opt (split-fields arg #(#\=)))
34     (opt-name (first split-opt))
35     (opt-arg (second split-opt))
36     (spec (find opt-name option-spec
37     :test #'string=
38     :key #'first)))
39     (when (null spec)
40 kaz 1.13 (error "unknown option ~a." opt-name))
41 kaz 1.10 (when opt-arg
42     (push opt-arg arguments))
43     (let ((num-req-params (second spec))
44     (opt-args ()))
45     (dotimes (i num-req-params)
46     (let ((opt-arg (pop arguments)))
47     (when (null opt-arg)
48 kaz 1.13 (error "option ~a requires ~a parameter~:p."
49 kaz 1.10 opt-name num-req-params))
50     (push opt-arg opt-args)))
51     (cons opt-name (nreverse opt-args))))))
52     (let ((parsed-options ()))
53 kaz 1.1 (loop
54 kaz 1.10 (if (null arguments)
55     (return))
56     (let ((arg (pop arguments)))
57     (cond
58     ((string= arg "--")
59     (return))
60     ((and (> (length arg) 2) (string= (subseq arg 0 2) "--"))
61     (push (process-option (subseq arg 2)) parsed-options))
62     ((and (> (length arg) 1) (char= (char arg 0) #\-))
63     (let ((num-chars (- (length arg) 1))
64     (last-iter (- (length arg) 2)))
65     (dotimes (i num-chars)
66     (let ((option (subseq arg (+ i 1) (+ i 2)))
67     (arg (subseq arg (+ i 2))))
68     (when (< i last-iter)
69     (push arg arguments))
70     (let ((result (process-option option)))
71     (push result parsed-options)
72     (when (and (second result)
73     (/= i (- (length arg) 2)))
74     (return))
75     (when (< i last-iter)
76     (pop arguments)))))))
77     (t (push arg arguments)
78     (return)))))
79     (values (nreverse parsed-options) arguments))))
80    
81 kaz 1.1 (defun format-opt (options)
82     "Convert list of options as produced by parse-opt back into a list
83     of strings."
84     (mapcan #'(lambda (option-list)
85     (let ((option (first option-list))
86     (arg (rest option-list)))
87     (if (> (length option) 1)
88     (cons (format nil "--~a" option) arg)
89 kaz 1.18 (if (= (length arg) 1)
90     (list (format nil "-~a~a" option (first arg)))
91     (cons (format nil "-~a" option) arg)))))
92     options))
93 kaz 1.7
94 kaz 1.15 (defun filter-mcvs-options (opts)
95 kaz 1.7 "Processes and removes any Meta-CVS-specific options."
96 kaz 1.9 (find-bind (:test #'string= :key #'first)
97 kaz 1.28 (remainder
98     (meta "meta")
99     (metaonly "metaonly")
100     (nometa "nometa")
101     (ec "error-continue")
102     (et "error-terminate")
103     (nesting-escape "up")
104     (debug "debug")
105     (nofilt "nofilt"))
106 kaz 1.9 opts
107     (when (and meta nometa)
108 kaz 1.13 (error "cannot specify both --nometa and --meta"))
109 kaz 1.9 (when (and metaonly nometa)
110 kaz 1.13 (error "cannot specify both --nometa and --metaonly"))
111 kaz 1.9 (setf *meta-option* meta)
112     (setf *metaonly-option* metaonly)
113     (setf *nometa-option* nometa)
114 kaz 1.17 (when nesting-escape
115     (unless (setf *nesting-escape-option*
116     (parse-integer (second nesting-escape)
117     :junk-allowed t))
118     (error "--up option takes integer argument"))
119     (unless (>= *nesting-escape-option* 0)
120     (error "--up argument must be nonnegative")))
121 kaz 1.13 (when debug
122 kaz 1.27 (setf *chatter-level* *chatter-debug*))
123 kaz 1.25 (setf *nofilt-option* nofilt)
124 kaz 1.12 (cond
125 kaz 1.26 (ec (setf *error-treatment* :continue))
126     (et (setf *error-treatment* :terminate)))
127 kaz 1.28 (let ((*package* (find-package :mcvs)))
128     (loop for (option . value) in remainder
129     if (string= option "i")
130     collect `(load ,(first value)) into exec-list
131     else if (string= option "x")
132     collect (read-from-string (first value)) into exec-list
133     else
134     collect `(,option ,@value) into rem-list
135     finally
136     (setf *exec-list* exec-list)
137     (return rem-list)))))
138 kaz 1.15
139     (defun process-cvs-options (opts)
140     "Take care of any CVS options that must also be interpreted by Meta-CVS."
141     (find-bind (:test #'string= :key #'first)
142     ((help-long "help") (help "H") (quiet "q")
143     (very-quiet "Q") (version "v") (version-long "version")
144 kaz 1.28 (editor "e") (dry-run "n"))
145 kaz 1.15 opts
146     (when (or help-long help)
147     (setf *print-usage* t))
148     (when (or version version-long)
149     (let* ((vers (split-words "$Name: $" "$:- "))
150     (major (third vers))
151 kaz 1.16 (minor (fourth vers))
152     (patch (fifth vers)))
153     (if (and major minor patch)
154 kaz 1.22 (format t "Meta-CVS version ~a.~a.~a Copyright 2004 Kaz Kylheku~%"
155 kaz 1.16 major minor patch)
156 kaz 1.22 (format t "Meta-CVS unknown version Copyright 2004 Kaz Kylheku~%"))
157 kaz 1.26 (throw 'terminate nil)))
158 kaz 1.15 (when editor
159 kaz 1.27 (setf *edit-program* (second editor)))
160 kaz 1.15 (cond
161 kaz 1.27 (very-quiet (setf *chatter-level* *chatter-silent*))
162     (quiet (setf *chatter-level* *chatter-terse*)))
163 kaz 1.15 (when dry-run
164 kaz 1.28 (setf *dry-run-option* t)))
165 kaz 1.15 opts)
166    
167     (defun filter-global-options (opts)
168     (process-cvs-options (filter-mcvs-options opts)))
169    
170     (defmacro honor-dry-run (vars &rest forms)
171     `(cond
172     (*dry-run-option*
173     (chatter-debug
174     "Because of -n option, not executing ~s with bindings ~s.~%"
175     ',forms
176     (list ,@(mapcar #'(lambda (var) `(list ',var ,var)) vars))))
177     (t ,@forms)))

  ViewVC Help
Powered by ViewVC 1.1.5