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

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.23: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: Likewise.
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
14 (defun option-spec-expand (num-args string-list)
15 (mapcar #'(lambda (string) (list string num-args))
16 string-list))
17
18 (defmacro option-spec (&rest option-specs)
19 `(append ,@(mapcar #'(lambda (spec)
20 (destructuring-bind (number word &rest strings) spec
21 (when (not (string= (symbol-name word) "ARG"))
22 (error "OPTIONS: word \"ARG\" expected."))
23 `(option-spec-expand ,number ',strings)))
24 option-specs)))
25
26 (defmacro define-option-constant (var &rest option-specs)
27 `(defconstant ,var (option-spec ,@option-specs)))
28
29 (defun parse-opt (arguments option-spec)
30 (flet ((process-option (arg)
31 (let* ((split-opt (split-fields arg #(#\=)))
32 (opt-name (first split-opt))
33 (opt-arg (second split-opt))
34 (spec (find opt-name option-spec
35 :test #'string=
36 :key #'first)))
37 (when (null spec)
38 (error "unknown option ~a." opt-name))
39 (when opt-arg
40 (push opt-arg arguments))
41 (let ((num-req-params (second spec))
42 (opt-args ()))
43 (dotimes (i num-req-params)
44 (let ((opt-arg (pop arguments)))
45 (when (null opt-arg)
46 (error "option ~a requires ~a parameter~:p."
47 opt-name num-req-params))
48 (push opt-arg opt-args)))
49 (cons opt-name (nreverse opt-args))))))
50 (let ((parsed-options ()))
51 (loop
52 (if (null arguments)
53 (return))
54 (let ((arg (pop arguments)))
55 (cond
56 ((string= arg "--")
57 (return))
58 ((and (> (length arg) 2) (string= (subseq arg 0 2) "--"))
59 (push (process-option (subseq arg 2)) parsed-options))
60 ((and (> (length arg) 1) (char= (char arg 0) #\-))
61 (let ((num-chars (- (length arg) 1))
62 (last-iter (- (length arg) 2)))
63 (dotimes (i num-chars)
64 (let ((option (subseq arg (+ i 1) (+ i 2)))
65 (arg (subseq arg (+ i 2))))
66 (when (< i last-iter)
67 (push arg arguments))
68 (let ((result (process-option option)))
69 (push result parsed-options)
70 (when (and (second result)
71 (/= i (- (length arg) 2)))
72 (return))
73 (when (< i last-iter)
74 (pop arguments)))))))
75 (t (push arg arguments)
76 (return)))))
77 (values (nreverse parsed-options) arguments))))
78
79 (defun format-opt (options)
80 "Convert list of options as produced by parse-opt back into a list
81 of strings."
82 (mapcan #'(lambda (option-list)
83 (let ((option (first option-list))
84 (arg (rest option-list)))
85 (if (> (length option) 1)
86 (cons (format nil "--~a" option) arg)
87 (if (= (length arg) 1)
88 (list (format nil "-~a~a" option (first arg)))
89 (cons (format nil "-~a" option) arg)))))
90 options))
91
92 (defun filter-mcvs-options (opts)
93 "Processes and removes any Meta-CVS-specific options."
94 (find-bind (:test #'string= :key #'first)
95 (remainder (meta "meta")
96 (metaonly "metaonly")
97 (nometa "nometa")
98 (ec "error-continue")
99 (et "error-terminate")
100 (nesting-escape "up")
101 (debug "debug"))
102 opts
103 (when (and meta nometa)
104 (error "cannot specify both --nometa and --meta"))
105 (when (and metaonly nometa)
106 (error "cannot specify both --nometa and --metaonly"))
107 (setf *meta-option* meta)
108 (setf *metaonly-option* metaonly)
109 (setf *nometa-option* nometa)
110 (when nesting-escape
111 (unless (setf *nesting-escape-option*
112 (parse-integer (second nesting-escape)
113 :junk-allowed t))
114 (error "--up option takes integer argument"))
115 (unless (>= *nesting-escape-option* 0)
116 (error "--up argument must be nonnegative")))
117 (when debug
118 (setf *mcvs-chatter-level* *mcvs-debug*))
119 (cond
120 (ec (setf *mcvs-error-treatment* :continue))
121 (et (setf *mcvs-error-treatment* :terminate)))
122 remainder))
123
124 (defun process-cvs-options (opts)
125 "Take care of any CVS options that must also be interpreted by Meta-CVS."
126 (find-bind (:test #'string= :key #'first)
127 ((help-long "help") (help "H") (quiet "q")
128 (very-quiet "Q") (version "v") (version-long "version")
129 (editor "e") (interpret-file "i") (dry-run "n"))
130 opts
131 (when (or help-long help)
132 (setf *print-usage* t))
133 (when (or version version-long)
134 (let* ((vers (split-words "$Name: $" "$:- "))
135 (major (third vers))
136 (minor (fourth vers))
137 (patch (fifth vers)))
138 (if (and major minor patch)
139 (format t "Meta-CVS version ~a.~a.~a Copyright 2004 Kaz Kylheku~%"
140 major minor patch)
141 (format t "Meta-CVS unknown version Copyright 2004 Kaz Kylheku~%"))
142 (throw 'mcvs-terminate nil)))
143 (when editor
144 (setf *mcvs-editor* (second editor)))
145 (cond
146 (very-quiet (setf *mcvs-chatter-level* *mcvs-silent*))
147 (quiet (setf *mcvs-chatter-level* *mcvs-terse*)))
148 (when dry-run
149 (setf *dry-run-option* t))
150 (when interpret-file
151 (load (second interpret-file))
152 (throw 'mcvs-terminate nil)))
153 opts)
154
155 (defun filter-global-options (opts)
156 (process-cvs-options (filter-mcvs-options opts)))
157
158 (defmacro honor-dry-run (vars &rest forms)
159 `(cond
160 (*dry-run-option*
161 (chatter-debug
162 "Because of -n option, not executing ~s with bindings ~s.~%"
163 ',forms
164 (list ,@(mapcar #'(lambda (var) `(list ',var ,var)) vars))))
165 (t ,@forms)))

  ViewVC Help
Powered by ViewVC 1.1.5