/[meta-cvs]/meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B
ViewVC logotype

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Fri Sep 6 02:17:27 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24
Changes since 1.23: +3 -1 lines
Low level support for versioning executable bit.

* code/unix-bindings/unix.lisp (unix-funcs:chmod): New callout
function.

* code/clisp-unix.lisp (executable-p, make-executable,
make-non-executable): New generic functions.
(executable-p (file-info), make-executable (file-info),
make-executable (string), make-non-executable (file-info),
make-non-executable (string)): New methods.

* code/add.lisp (mcvs-add): Record whether new file is
executable or not, by setting executable slot in mapping-entry.

* code/create.lisp (mcvs-create): Likewise.

* code/sync.lisp (synchronize-files): New parameter,
should-be-executable, tells function which way to set
permissions after synchronizing files.

* code/mapping.lisp (mapping-entry): New slot, executable.
(mapping-entry-parse-attributes): New function, parses
new optional property list from :FILE entries in a mapping.
(mapping-convert-in): Parse property list that may be present in fourth
list element of a :FILE entry.
(mapping-convert-out): Write out executable flag as
:EXEC property, if true.
(mapping-synchronize): Pass executable flag down to synchronize-files.
1 kaz 1.10 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.7 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "system")
6     (require "mapping")
7     (require "chatter")
8 kaz 1.4 (require "dirwalk")
9 kaz 1.6 (require "seqfuncs")
10 kaz 1.8 (require "options")
11 kaz 1.18 (require "types")
12 kaz 1.1 (provide "add")
13    
14 kaz 1.6 (defun mcvs-add (recursivep cvs-options add-options files)
15 kaz 1.3 (in-sandbox-root-dir
16 kaz 1.14 (let* ((filemap (mapping-read *mcvs-map*))
17     (saved-filemap (copy-list filemap))
18 kaz 1.18 (types-exists (exists *mcvs-types*))
19     (types (and types-exists (types-read *mcvs-types*)))
20     new-map-entries new-types)
21 kaz 1.1
22 kaz 1.20 (chatter-debug "Mapping.~%")
23 kaz 1.4
24 kaz 1.1 (dolist (file files)
25 kaz 1.4 (let (expanded-paths)
26     (if recursivep
27     (for-each-path (full-name (sandbox-translate-path file))
28 kaz 1.5 (push (canonicalize-path full-name) expanded-paths))
29 kaz 1.4 (push (sandbox-translate-path file) expanded-paths))
30     (nreverse expanded-paths)
31    
32 kaz 1.5 (dolist (full-name expanded-paths)
33 kaz 1.23 (let ((abs-name (real-to-abstract-path full-name))
34     (file-info (stat full-name)))
35 kaz 1.22 (can-restart-here ("Continue adding files.")
36     (cond
37     ((path-prefix-equal *mcvs-dir* full-name)
38     (error "mcvs-add: path ~a is in a reserved Meta-CVS area."
39     full-name))
40     ((mapping-lookup filemap abs-name)
41     (chatter-info "mcvs-add: ~a already added.~%" full-name))
42 kaz 1.23 ((directory-p file-info)
43 kaz 1.22 (when (not recursivep)
44     (error "mcvs-add: ~a, is a directory, use -R to add." full-name)))
45 kaz 1.23 ((regular-p file-info)
46 kaz 1.22 (let* ((suffix (suffix full-name))
47 kaz 1.23 (f-file (mapping-generate-id :suffix suffix)))
48 kaz 1.22 (when suffix
49     (setf new-types (adjoin (list suffix :default)
50     new-types :test #'equal)))
51 kaz 1.23 (push (make-mapping-entry :kind :file
52     :id f-file
53 kaz 1.24 :path abs-name
54     :executable (executable-p
55     file-info))
56 kaz 1.23 new-map-entries)))
57     ((symlink-p file-info)
58     (let ((id (mapping-generate-id :no-dir t :prefix "S-")))
59     (push (make-mapping-entry :kind :symlink
60     :id id
61     :path abs-name
62     :target (readlink full-name))
63     new-map-entries)))
64     (t
65     (error "mcvs-add: cannot add ~a, not regular file or symlink."
66     full-name))))))))
67 kaz 1.18
68     (setf new-types (set-difference
69     new-types types :key #'first :test #'string=))
70    
71     (unwind-protect
72     (setf new-types (types-let-user-edit new-types *mcvs-new-types*))
73     (ignore-errors (unlink *mcvs-new-types*)))
74    
75     (setf new-map-entries (types-remove-ignores new-types new-map-entries))
76 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
77 kaz 1.18
78     (when new-map-entries
79     (dolist (map-entry new-map-entries)
80 kaz 1.23 (with-slots (kind id path) map-entry
81 kaz 1.18 (push map-entry filemap)
82 kaz 1.23 (let ((real-name (abstract-to-real-path path)))
83     (chatter-info "mapping ~a <- ~a~%" id real-name)
84     (if (eq kind :file)
85     (link real-name id)))))
86 kaz 1.18
87     (mapping-write filemap *mcvs-map* :sort-map t)
88    
89     (when (setf types (append types new-types))
90     (types-write types *mcvs-types*))
91    
92 kaz 1.20 (chatter-debug "Synchronizing.~%")
93 kaz 1.1 (mapping-synchronize)
94    
95 kaz 1.23 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
96    
97 kaz 1.18 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
98     (loop
99     (restart-case
100     (current-dir-restore
101     (chdir *mcvs-dir*)
102 kaz 1.20 (chatter-debug "Invoking CVS.~%")
103 kaz 1.18 (dolist (add-args add-commands)
104     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
105     "add" ,@(format-opt add-options)
106     ,@add-args)))
107     (error "CVS add failed.")))
108     (when (and types (not types-exists))
109     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
110     "add" ,*mcvs-types-name*)))
111     (error "CVS add failed.")))
112     (return))
113     (retry ()
114     :report "Try invoking CVS again.")
115     (continue ()
116     :report "Undo everything; restore the mapping."
117 kaz 1.20 (chatter-debug "Restoring map.~%")
118 kaz 1.18 (mapping-write saved-filemap *mcvs-map*)
119     (ignore-errors
120     (dolist (entry new-map-entries)
121 kaz 1.23 (unlink (mapping-entry-id entry))))
122 kaz 1.18 (return)))))
123 kaz 1.14
124 kaz 1.20 (chatter-debug "Updating file structure.~%")
125 kaz 1.1 (mapping-update))))
126     (values))
127 kaz 1.6
128 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
129 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
130 kaz 1.8 (separate "R" cvs-command-options
131 kaz 1.6 :key #'first :test #'string=)
132     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5