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

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Sat Mar 8 03:27:57 2008 UTC (6 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-1-98, HEAD
Changes since 1.28: +2 -2 lines
Update copyright year.
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 (in-package :meta-cvs)
6
7 (defvar *print-usage* nil)
8 (defvar *nometa-option* nil)
9 (defvar *meta-option* nil)
10 (defvar *metaonly-option* nil)
11 (defvar *dry-run-option* nil)
12 (defvar *nesting-escape-option* 0)
13 (defvar *nofilt-option* nil)
14 (defvar *exec-list* nil)
15
16 (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 (error "unknown option ~a." opt-name))
41 (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 (error "option ~a requires ~a parameter~:p."
49 opt-name num-req-params))
50 (push opt-arg opt-args)))
51 (cons opt-name (nreverse opt-args))))))
52 (let ((parsed-options ()))
53 (loop
54 (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 (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 (if (= (length arg) 1)
90 (list (format nil "-~a~a" option (first arg)))
91 (cons (format nil "-~a" option) arg)))))
92 options))
93
94 (defun filter-mcvs-options (opts)
95 "Processes and removes any Meta-CVS-specific options."
96 (find-bind (:test #'string= :key #'first)
97 (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 opts
107 (when (and meta nometa)
108 (error "cannot specify both --nometa and --meta"))
109 (when (and metaonly nometa)
110 (error "cannot specify both --nometa and --metaonly"))
111 (setf *meta-option* meta)
112 (setf *metaonly-option* metaonly)
113 (setf *nometa-option* nometa)
114 (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 (when debug
122 (setf *chatter-level* *chatter-debug*))
123 (setf *nofilt-option* nofilt)
124 (cond
125 (ec (setf *error-treatment* :continue))
126 (et (setf *error-treatment* :terminate)))
127 (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
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 (editor "e") (dry-run "n"))
145 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 (minor (fourth vers))
152 (patch (fifth vers)))
153 (if (and major minor patch)
154 (format t "Meta-CVS version ~a.~a.~a Copyright 2008 Kaz Kylheku~%"
155 major minor patch)
156 (format t "Meta-CVS unknown version Copyright 2008 Kaz Kylheku~%"))
157 (throw 'terminate nil)))
158 (when editor
159 (setf *edit-program* (second editor)))
160 (cond
161 (very-quiet (setf *chatter-level* *chatter-silent*))
162 (quiet (setf *chatter-level* *chatter-terse*)))
163 (when dry-run
164 (setf *dry-run-option* t)))
165 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