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

Diff of /meta-cvs/F-36433FEEE65F109159A4ADF217F5145C

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10.6.1 by kaz, Sun Aug 25 19:13:48 2002 UTC revision 1.24 by kaz, Tue Nov 28 07:47:21 2006 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5  (require "system")  (in-package :meta-cvs)
 (require "mapping")  
 (require "options")  
 (provide "filt")  
6    
7  (defun make-filt-hash (mapping)  (defun make-filt-hash (mapping)
8    (let ((h (make-hash-table :test #'equal)))    (let ((h (make-hash-table :test #'equal)))
# Line 15  Line 12 
12          (declare (ignore suffix))          (declare (ignore suffix))
13          (setf (gethash nosuffix h) entry)))))          (setf (gethash nosuffix h) entry)))))
14    
15  (defun filt-select-map (filt-options)  (defun filt-select-map (filt-options &key remote-module)
16    (find-bind (:test #'string= :key #'first :take #'second)    (find-bind (:test #'string= :key #'first :take #'second)
17               ((revision "r") (date "D") (extra-r "r") (extra-d "D"))               ((revision "r") (date "D") (extra-r "r") (extra-d "D"))
18               filt-options               filt-options
19      (cond      (cond
20        ((or extra-r extra-d)        ((or extra-r extra-d)
21           (error "mcvs-filt: only one date or revision may be specified."))           (error "only one date or revision may be specified."))
22        ((or revision date)        ((or revision date remote-module)
23           (with-input-from-program (stream `("cvs" "-Q" "up" "-p"           (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)                                              ,@(format-opt filt-options)
28                                              ,*mcvs-map*))                                              ,(if remote-module
29             (let ((map (read stream nil :error)))                                                 (format nil "~a/~a"
30               (if (eq map :error)                                                         remote-module
31                 (error "mcvs-filt: didn't obtain valid map from CVS.")                                                         *map-file*)
32                  map))))                                                 *map-file*)))
33        (t (mapping-read *mcvs-map-local*)))))             (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 mcvs-filt (filt-options)  (defun filt-loop (filehash)
40    (in-sandbox-root-dir    (loop
41      (let* ((filemap (filt-select-map filt-options))      (let ((line (read-line *standard-input* nil)))
42             (filehash (make-filt-hash filemap)))        (when (null line)
43            (return (values)))
44        (loop        (loop
45          (let ((line (read-line t nil)))          (let ((f-start (search "F-" line :test #'char=))
46            (when (null line)                (embedded-in-path (search "/F-" line :test #'char=))
47              (return (values)))                (cvs-backup-notation (search ".#F-" line :test #'char=)))
48            (loop            (flet ((is-hex-digit (x)
49              (let ((f-start (search "F-" line)))                     (or (digit-char-p x)
50                (flet ((is-hex-digit (x)                         (find x "ABCDEF"))))
51                         (or (digit-char-p x)              (cond
52                             (find x "ABCDEF"))))                ((and embedded-in-path (< embedded-in-path f-start))
53                  (when (not f-start)                  (write-string (subseq line 0 (+ embedded-in-path 3)))
54                    (write-line line)                  (setf line (subseq line (+ embedded-in-path 3))))
55                    (return))                ((and cvs-backup-notation (< cvs-backup-notation f-start))
56                  (write-string (substring line 0 f-start))                  (write-string (subseq line 0 cvs-backup-notation))
57                  (setf line (substring line (+ f-start 2)))                  (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)                  (when (< (length line) 32)
64                    (write-string "F-")                    (write-string "F-")
65                    (write-line line)                    (write-line line)
66                    (return))                    (return))
67                  (cond                  (cond
68                    ((notevery #'is-hex-digit (substring line 0 32))                    ((notevery #'is-hex-digit (subseq line 0 32))
69                       (write-string "F-")                       (write-string "F-")
70                       (setf line (substring line 2)))                       (setf line (subseq line 2)))
71                    (t (let* ((f-digits (substring line 0 32))                    (t (let* ((f-digits (subseq line 0 32))
72                              (entry (gethash (format nil "F-~a" f-digits)                              (entry (gethash (format nil "F-~a" f-digits)
73                                              filehash))                                              filehash))
74                              (suffix (suffix (mapping-entry-id entry))))                              (suffix (and entry
75                         (setf line (substring line 32))                                           (suffix (mapping-entry-id entry)))))
76                           (setf line (subseq line 32))
77                         (cond                         (cond
78                           ((not entry)                           ((null entry)
79                              (write-string "F-")                              (write-string "F-")
80                              (write-string f-digits))                              (write-string f-digits))
81                           ((and suffix                           ((and suffix
82                                 (or (< (length line) (1+ (length suffix)))                                 (or (< (length line) (1+ (length suffix)))
83                                     (not (path-equal (substring line 1                                     (not (path-equal (subseq line 1
84                                                                 (1+ (length suffix)))                                                                 (1+ (length suffix)))
85                                                      suffix))))                                                      suffix))))
86                              (write-string "F-")                              (write-string "F-")
# Line 77  Line 88 
88                           (t (write-string (mapping-entry-path entry))                           (t (write-string (mapping-entry-path entry))
89                              (when suffix                              (when suffix
90                                (setf line                                (setf line
91                                      (substring line                                      (subseq line
92                                                 (1+ (length suffix))))))))))))))))))                                                 (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 mcvs-filt-wrapper (cvs-options cvs-command-options mcvs-args)  (defun filt-wrapper (cvs-options cvs-command-options mcvs-args)
105    (declare (ignore cvs-options))    (declare (ignore cvs-options))
106    (when mcvs-args    (when mcvs-args
107      (error "mcvs-filt: no arguments permitted."))      (error "no arguments permitted."))
108    (mcvs-filt cvs-command-options))    (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)))

Legend:
Removed from v.1.10.6.1  
changed lines
  Added in v.1.24

  ViewVC Help
Powered by ViewVC 1.1.5