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

Contents of /meta-cvs/F-36433FEEE65F109159A4ADF217F5145C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Wed Mar 13 21:35:00 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.8: +4 -1 lines
* mcvs-filt.lisp (filt-select-map): Handle error gracefully
when reading map. It's easy to give CVS is a nonexistent tag.
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 (require "system")
6 (require "mapping")
7 (require "options")
8 (provide "filt")
9
10 (defun make-filt-hash (mapping)
11 (let ((h (make-hash-table :test #'equal)))
12 (dolist (entry mapping h)
13 (multiple-value-bind (suffix nosuffix)
14 (suffix (first entry))
15 (declare (ignore suffix))
16 (setf (gethash nosuffix h) entry)))))
17
18 (defun filt-select-map (filt-options)
19 (find-bind (:test #'string= :key #'first :take #'second)
20 ((revision "r") (date "D"))
21 filt-options
22 (cond
23 ((and revision date)
24 (error "mcvs-filt: cannot specify both revision and date."))
25 ((or revision date)
26 (with-input-from-program (stream `("cvs" "-Q" "up" "-p"
27 ,@(format-opt filt-options)
28 ,*mcvs-map*))
29 (let ((map (read stream nil :error)))
30 (if (eq map :error)
31 (error "mcvs-filt: didn't obtain valid map from CVS.")
32 map))))
33 (t (mapping-read *mcvs-map-local*)))))
34
35 (defun mcvs-filt (filt-options)
36 (in-sandbox-root-dir
37 (let* ((filemap (filt-select-map filt-options))
38 (filehash (make-filt-hash filemap)))
39 (loop
40 (let ((line (read-line t nil)))
41 (when (null line)
42 (return (values)))
43 (loop
44 (let ((f-start (search "F-" line)))
45 (flet ((is-hex-digit (x)
46 (or (digit-char-p x)
47 (find x "ABCDEF"))))
48 (when (not f-start)
49 (write-line line)
50 (return))
51 (write-string (substring line 0 f-start))
52 (setf line (substring line (+ f-start 2)))
53 (when (< (length line) 32)
54 (write-string "F-")
55 (write-line line)
56 (return))
57 (cond
58 ((notevery #'is-hex-digit (substring line 0 32))
59 (write-string "F-")
60 (setf line (substring line 2)))
61 (t (let* ((f-digits (substring line 0 32))
62 (entry (gethash (format nil "F-~a" f-digits)
63 filehash))
64 (suffix (suffix (first entry))))
65 (setf line (substring line 32))
66 (cond
67 ((not entry)
68 (write-string "F-")
69 (write-string f-digits))
70 ((and suffix
71 (or (< (length line) (1+ (length suffix)))
72 (not (path-equal (substring line 1
73 (1+ (length suffix)))
74 suffix))))
75 (write-string "F-")
76 (write-string f-digits))
77 (t (write-string (second entry))
78 (when suffix
79 (setf line
80 (substring line
81 (1+ (length suffix))))))))))))))))))
82
83 (defun mcvs-filt-wrapper (cvs-options cvs-command-options mcvs-args)
84 (declare (ignore cvs-options))
85 (when mcvs-args
86 (error "mcvs-filt: no arguments permitted."))
87 (mcvs-filt cvs-command-options))

  ViewVC Help
Powered by ViewVC 1.1.5