/[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 - (show 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 ;;; 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 (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 (suffix (mapping-entry-id entry))
12 (declare (ignore suffix))
13 (setf (gethash nosuffix h) entry)))))
14
15 (defun filt-select-map (filt-options &key remote-module)
16 (find-bind (:test #'string= :key #'first :take #'second)
17 ((revision "r") (date "D") (extra-r "r") (extra-d "D"))
18 filt-options
19 (cond
20 ((or extra-r extra-d)
21 (error "only one date or revision may be specified."))
22 ((or revision date remote-module)
23 (unless remote-module
24 (chdir *admin-dir*))
25 (with-input-from-program (stream `("cvs" "-Q"
26 ,(if remote-module "co" "up") "-p"
27 ,@(format-opt filt-options)
28 ,(if remote-module
29 (format nil "~a/~a"
30 remote-module
31 *map-file*)
32 *map-file*)))
33 (handler-case
34 (mapping-read stream)
35 (error ()
36 (error "unable to retrieve specified revision of map file.")))))
37 (t (mapping-read *map-local-path*)))))
38
39 (defun filt-loop (filehash)
40 (loop
41 (let ((line (read-line *standard-input* nil)))
42 (when (null line)
43 (return (values)))
44 (loop
45 (let ((f-start (search "F-" line :test #'char=))
46 (embedded-in-path (search "/F-" line :test #'char=))
47 (cvs-backup-notation (search ".#F-" line :test #'char=)))
48 (flet ((is-hex-digit (x)
49 (or (digit-char-p x)
50 (find x "ABCDEF"))))
51 (cond
52 ((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 (write-string *admin-dir*)
58 (write-string "/.#F-")
59 (setf line (subseq line (+ cvs-backup-notation 4))))
60 (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 (defun filt (filt-options)
97 (in-sandbox-root-dir
98 (filt-loop (make-filt-hash (filt-select-map filt-options)))))
99
100 (defun remote-filt (filt-options module)
101 (filt-loop (make-filt-hash (filt-select-map filt-options
102 :remote-module module))))
103
104 (defun filt-wrapper (cvs-options cvs-command-options mcvs-args)
105 (declare (ignore cvs-options))
106 (when mcvs-args
107 (error "no arguments permitted."))
108 (filt cvs-command-options))
109
110 (defun remote-filt-wrapper (cvs-options cvs-command-options mcvs-args)
111 (declare (ignore cvs-options))
112 (unless (= (length mcvs-args) 1)
113 (error "module name required."))
114 (remote-filt cvs-command-options (first mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5