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

Contents of /meta-cvs/F-36433FEEE65F109159A4ADF217F5145C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Tue Nov 28 07:47:21 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.23: +5 -5 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5