/[meta-cvs]/meta-cvs/F-300FB44635F94930416CE1B06097B230.lisp
ViewVC logotype

Contents of /meta-cvs/F-300FB44635F94930416CE1B06097B230.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Thu Oct 31 04:46:39 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0-3
Changes since 1.6: +1 -1 lines
Merging from mcvs-1-0-branch.

* code/prop.lisp (mcvs-prop): If there are no options specified,
don't do anything.
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 "chatter")
8 (require "mcvs-package")
9 (provide "prop")
10
11 (in-package "META-CVS")
12
13 (defun mcvs-prop (prop-options files)
14 (in-sandbox-root-dir
15 (let (entries-to-process
16 (filemap (mapping-read *mcvs-map*)))
17 (chatter-debug "Preparing file list.~%")
18
19 (if (null files)
20 (setf entries-to-process
21 (mapping-prefix-matches filemap
22 (sandbox-translate-path ".")))
23 (dolist (file files)
24 (can-restart-here ("Continue preparing file list.")
25 (let* ((full-name (sandbox-translate-path file))
26 (abs-name (canonicalize-path
27 (real-to-abstract-path full-name)))
28 (entries (mapping-prefix-matches filemap abs-name)))
29 (if (not entries)
30 (error "~a is not known to Meta-CVS." full-name)
31 (setf entries-to-process (nconc entries-to-process entries)))))))
32
33 (when (and entries-to-process prop-options)
34 ;; do the property update
35 (chatter-debug "Updating properties.~%")
36 (dolist (entry entries-to-process)
37 (with-slots (raw-plist) entry
38 (loop for (option prop-name value) in prop-options do
39 (let ((indicator (intern (string-upcase prop-name) "KEYWORD")))
40 (cond
41 ((string= option "set")
42 (setf (getf raw-plist indicator) t))
43 ((string= option "clear")
44 (setf (getf raw-plist indicator) nil))
45 ((string= option "value")
46 (setf (getf raw-plist indicator) (read-from-string value)))
47 ((string= option "remove")
48 (remf raw-plist indicator)))
49 (mapping-entry-parse-plist entry)))))
50 (chatter-debug "Writing out map.~%")
51 (mapping-write filemap *mcvs-map*)
52 (chatter-debug "Updating file structure.~%")
53 (mapping-update)
54 (chatter-debug "Synchronizing.~%")
55 (mapping-synchronize))))
56 (values))
57
58 (defun mcvs-prop-wrapper (mcvs-opts command-opts command-args)
59 (declare (ignore mcvs-opts))
60 (mcvs-prop command-opts command-args))

  ViewVC Help
Powered by ViewVC 1.1.5