/[meta-cvs]/meta-cvs/F-36433FEEE65F109159A4ADF217F5145C
ViewVC logotype

Contents of /meta-cvs/F-36433FEEE65F109159A4ADF217F5145C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Wed Apr 16 05:12:21 2003 UTC (11 years ago) by kaz
Branch: MAIN
Changes since 1.16: +78 -57 lines
Merging from mcvs-1-0-branch.

New command, remote-filt.

* code/mcvs-main.lisp (*remote-filt-options*): New option constant.
(*mcvs-command-table*): Entries for new command added.
(*usage*): Help text added.

* code/filt.lisp (filt-select-map): New keyword parameter for
specifing repository module. CVS up -p or co -p command generated
accordingly. Also, little glitch fixed: the local case descends
into the MCVS directory, to avoid a warning message that occurs
when CVS is used in server mode.
(mcvs-filt-loop): New function, contains most of the old mcvs-filt
function body.
(mcvs-filt): Calls new mcvs-filt-loop to do actual filtering work.
(mcvs-remote-filt, mcvs-remote-filt-wrapper): New functions.

* code/clisp-unix.lisp (with-input-from-program): Macro changed
to include debug tracing of the invoked command.
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     (require "system")
6     (require "mapping")
7 kaz 1.8 (require "options")
8 kaz 1.16 (require "mcvs-package")
9 kaz 1.1 (provide "filt")
10    
11 kaz 1.16 (in-package "META-CVS")
12    
13 kaz 1.6 (defun make-filt-hash (mapping)
14     (let ((h (make-hash-table :test #'equal)))
15     (dolist (entry mapping h)
16     (multiple-value-bind (suffix nosuffix)
17 kaz 1.11 (suffix (mapping-entry-id entry))
18 kaz 1.6 (declare (ignore suffix))
19     (setf (gethash nosuffix h) entry)))))
20    
21 kaz 1.17 (defun filt-select-map (filt-options &key remote-module)
22 kaz 1.8 (find-bind (:test #'string= :key #'first :take #'second)
23 kaz 1.10 ((revision "r") (date "D") (extra-r "r") (extra-d "D"))
24 kaz 1.8 filt-options
25     (cond
26 kaz 1.10 ((or extra-r extra-d)
27 kaz 1.13 (error "only one date or revision may be specified."))
28 kaz 1.17 ((or revision date remote-module)
29     (unless remote-module
30     (chdir *mcvs-dir*))
31     (with-input-from-program (stream `("cvs" "-Q"
32     ,(if remote-module "co" "up") "-p"
33 kaz 1.8 ,@(format-opt filt-options)
34 kaz 1.17 ,(if remote-module
35     (format nil "~a/~a"
36     remote-module
37     *mcvs-map-name*)
38     *mcvs-map-name*)))
39     (handler-case
40     (mapping-read stream)
41     (error ()
42     (error "unable to retrieve specified revision of map file.")))))
43 kaz 1.8 (t (mapping-read *mcvs-map-local*)))))
44    
45 kaz 1.17 (defun mcvs-filt-loop (filehash)
46     (loop
47     (let ((line (read-line t nil)))
48     (when (null line)
49     (return (values)))
50     (loop
51     (let ((f-start (search "F-" line :test #'char=))
52     (mcvs-dir (search "MCVS/F-" line :test #'char=)))
53     (flet ((is-hex-digit (x)
54     (or (digit-char-p x)
55     (find x "ABCDEF"))))
56     (cond
57     ((and mcvs-dir (or (and f-start (< mcvs-dir f-start))
58     (not f-start)))
59     (write-string (subseq line 0 (+ mcvs-dir 7)))
60     (setf line (subseq line (+ mcvs-dir 7))))
61     (f-start
62     (write-string (subseq line 0 f-start))
63     (setf line (subseq line (+ f-start 2)))
64     (when (< (length line) 32)
65     (write-string "F-")
66     (write-line line)
67     (return))
68     (cond
69     ((notevery #'is-hex-digit (subseq line 0 32))
70     (write-string "F-")
71     (setf line (subseq line 2)))
72     (t (let* ((f-digits (subseq line 0 32))
73     (entry (gethash (format nil "F-~a" f-digits)
74     filehash))
75     (suffix (and entry
76     (suffix (mapping-entry-id entry)))))
77     (setf line (subseq line 32))
78     (cond
79     ((null entry)
80     (write-string "F-")
81     (write-string f-digits))
82     ((and suffix
83     (or (< (length line) (1+ (length suffix)))
84     (not (path-equal (subseq line 1
85     (1+ (length suffix)))
86     suffix))))
87     (write-string "F-")
88     (write-string f-digits))
89     (t (write-string (mapping-entry-path entry))
90     (when suffix
91     (setf line
92     (subseq line
93     (1+ (length suffix)))))))))))
94     (t (write-line line)
95     (return)))))))))
96    
97 kaz 1.8 (defun mcvs-filt (filt-options)
98 kaz 1.1 (in-sandbox-root-dir
99 kaz 1.17 (mcvs-filt-loop (make-filt-hash (filt-select-map filt-options)))))
100    
101     (defun mcvs-remote-filt (filt-options module)
102     (mcvs-filt-loop (make-filt-hash (filt-select-map filt-options
103     :remote-module module))))
104 kaz 1.1
105     (defun mcvs-filt-wrapper (cvs-options cvs-command-options mcvs-args)
106 kaz 1.8 (declare (ignore cvs-options))
107 kaz 1.1 (when mcvs-args
108 kaz 1.13 (error "no arguments permitted."))
109 kaz 1.8 (mcvs-filt cvs-command-options))
110 kaz 1.17
111     (defun mcvs-remote-filt-wrapper (cvs-options cvs-command-options mcvs-args)
112     (declare (ignore cvs-options))
113     (unless (= (length mcvs-args) 1)
114     (error "module name required."))
115     (mcvs-remote-filt cvs-command-options (first mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5