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

Contents of /meta-cvs/F-36433FEEE65F109159A4ADF217F5145C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Sat Oct 5 18:09:48 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0-branch~branch-point, mcvs-0-97
Branch point for: mcvs-1-0-branch
Changes since 1.12: +3 -3 lines
Error messages no longer specify prefixes like "mcvs:" or
"mcvs-remove:".

When no restarts are available, the error handler now adds the "mcvs:"
prefix when dumping the error text to the standard error stream,
and also adds a terminating newline.

The inability to write to the MAP file is converted to a more
informative error message.

New --debug option is supported to set the chatter level to 3.
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 kaz 1.8 (require "options")
8 kaz 1.1 (provide "filt")
9    
10 kaz 1.6 (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 kaz 1.11 (suffix (mapping-entry-id entry))
15 kaz 1.6 (declare (ignore suffix))
16     (setf (gethash nosuffix h) entry)))))
17    
18 kaz 1.8 (defun filt-select-map (filt-options)
19     (find-bind (:test #'string= :key #'first :take #'second)
20 kaz 1.10 ((revision "r") (date "D") (extra-r "r") (extra-d "D"))
21 kaz 1.8 filt-options
22     (cond
23 kaz 1.10 ((or extra-r extra-d)
24 kaz 1.13 (error "only one date or revision may be specified."))
25 kaz 1.8 ((or revision date)
26     (with-input-from-program (stream `("cvs" "-Q" "up" "-p"
27     ,@(format-opt filt-options)
28     ,*mcvs-map*))
29 kaz 1.9 (let ((map (read stream nil :error)))
30     (if (eq map :error)
31 kaz 1.13 (error "didn't obtain valid map from CVS.")
32 kaz 1.9 map))))
33 kaz 1.8 (t (mapping-read *mcvs-map-local*)))))
34    
35     (defun mcvs-filt (filt-options)
36 kaz 1.1 (in-sandbox-root-dir
37 kaz 1.8 (let* ((filemap (filt-select-map filt-options))
38 kaz 1.6 (filehash (make-filt-hash filemap)))
39 kaz 1.1 (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 kaz 1.2 (find x "ABCDEF"))))
48 kaz 1.1 (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 kaz 1.6 (when (< (length line) 32)
54 kaz 1.1 (write-string "F-")
55     (write-line line)
56     (return))
57 kaz 1.6 (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 kaz 1.12 (suffix (and entry
65     (suffix (mapping-entry-id entry)))))
66 kaz 1.6 (setf line (substring line 32))
67     (cond
68 kaz 1.12 ((null entry)
69 kaz 1.6 (write-string "F-")
70 kaz 1.7 (write-string f-digits))
71 kaz 1.6 ((and suffix
72     (or (< (length line) (1+ (length suffix)))
73     (not (path-equal (substring line 1
74     (1+ (length suffix)))
75     suffix))))
76     (write-string "F-")
77     (write-string f-digits))
78 kaz 1.11 (t (write-string (mapping-entry-path entry))
79 kaz 1.6 (when suffix
80     (setf line
81     (substring line
82     (1+ (length suffix))))))))))))))))))
83 kaz 1.1
84     (defun mcvs-filt-wrapper (cvs-options cvs-command-options mcvs-args)
85 kaz 1.8 (declare (ignore cvs-options))
86 kaz 1.1 (when mcvs-args
87 kaz 1.13 (error "no arguments permitted."))
88 kaz 1.8 (mcvs-filt cvs-command-options))

  ViewVC Help
Powered by ViewVC 1.1.5