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

Contents of /meta-cvs/F-36433FEEE65F109159A4ADF217F5145C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Sat Mar 9 23:07:35 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.5: +37 -14 lines
Fix mcvs filt so it handles suffixed F- files properly.

* filt.lisp (make-filt-hash): New function.
(mcvs-filt): After matching hex digits, also check for
a suffix match.
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     (provide "filt")
8    
9 kaz 1.6 (defun make-filt-hash (mapping)
10     (let ((h (make-hash-table :test #'equal)))
11     (dolist (entry mapping h)
12     (multiple-value-bind (suffix nosuffix)
13     (suffix (first entry))
14     (declare (ignore suffix))
15     (setf (gethash nosuffix h) entry)))))
16    
17 kaz 1.1 (defun mcvs-filt ()
18     (in-sandbox-root-dir
19 kaz 1.6 (let* ((filemap (mapping-read *mcvs-map-local*))
20     (filehash (make-filt-hash filemap)))
21 kaz 1.1 (loop
22     (let ((line (read-line t nil)))
23     (when (null line)
24     (return (values)))
25     (loop
26     (let ((f-start (search "F-" line)))
27     (flet ((is-hex-digit (x)
28     (or (digit-char-p x)
29 kaz 1.2 (find x "ABCDEF"))))
30 kaz 1.1 (when (not f-start)
31     (write-line line)
32     (return))
33     (write-string (substring line 0 f-start))
34     (setf line (substring line (+ f-start 2)))
35 kaz 1.6 (when (< (length line) 32)
36 kaz 1.1 (write-string "F-")
37     (write-line line)
38     (return))
39 kaz 1.6 (cond
40     ((notevery #'is-hex-digit (substring line 0 32))
41     (write-string "F-")
42     (setf line (substring line 2)))
43     (t (let* ((f-digits (substring line 0 32))
44     (entry (gethash (format nil "F-~a" f-digits)
45     filehash))
46     (suffix (suffix (first entry))))
47     (setf line (substring line 32))
48     (cond
49     ((not entry)
50     (write-string "F-")
51     (write-string f-digits)
52     (return))
53     ((and suffix
54     (or (< (length line) (1+ (length suffix)))
55     (not (path-equal (substring line 1
56     (1+ (length suffix)))
57     suffix))))
58     (write-string "F-")
59     (write-string f-digits))
60     (t (write-string (second entry))
61     (when suffix
62     (setf line
63     (substring line
64     (1+ (length suffix))))))))))))))))))
65 kaz 1.1
66     (defun mcvs-filt-wrapper (cvs-options cvs-command-options mcvs-args)
67     (declare (ignore cvs-options cvs-command-options))
68     (when mcvs-args
69     (error "mcvs-filt: no arguments permitted."))
70     (mcvs-filt))

  ViewVC Help
Powered by ViewVC 1.1.5