/[meta-cvs]/meta-cvs/F-C232DEE072E25B4F4683B91342CEC065
ViewVC logotype

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Fri Sep 6 02:17:27 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
Changes since 1.19: +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.7 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.4 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "dirwalk")
6 kaz 1.10 (require "system")
7 kaz 1.1 (require "mapping")
8 kaz 1.10 (require "types")
9 kaz 1.1 (require "chatter")
10 kaz 1.6 (require "options")
11 kaz 1.17 (provide "create")
12 kaz 1.1
13 kaz 1.18 (defun mcvs-create (module release &optional global-options command-options)
14 kaz 1.1 (multiple-value-bind (path created) (ensure-directories-exist *mcvs-map*)
15 kaz 1.3 (declare (ignore path))
16 kaz 1.1 (if (not created)
17 kaz 1.17 (error "mcvs-create: A ~a directory already exists here." *mcvs-dir*)))
18 kaz 1.1
19     (unwind-protect
20     (progn
21 kaz 1.10 (let (filemap types)
22 kaz 1.14 (chatter-debug "Mapping.~%")
23 kaz 1.10
24     ;; Gather up list of files to import, and build up mapping,
25     ;; as well as list of suffixes (file types).
26 kaz 1.1 (for-each-file-info (fi ".")
27 kaz 1.19 (cond
28     ((regular-p fi)
29     (let* ((path (canonicalize-path (file-name fi)))
30     (suffix (suffix (file-name fi)))
31     (file (mapping-generate-id :suffix suffix)))
32     (chatter-info "~a <- ~a~%" file path)
33     (push (make-mapping-entry :kind :file
34     :id file
35 kaz 1.20 :path path
36     :executable (executable-p
37     file-info))
38 kaz 1.19 filemap)
39     (when suffix
40     (setf types (adjoin (list suffix :default)
41     types :test #'equal)))))
42     ((symlink-p fi)
43     (let ((path (canonicalize-path (file-name fi)))
44     (id (mapping-generate-id :prefix "S-" :no-dir t)))
45     (chatter-info "~a <- ~a~%" id path)
46     (push (make-mapping-entry :kind :symlink
47     :id id
48     :path path
49     :target (readlink path))
50     filemap)))))
51    
52 kaz 1.10
53     ;; Write out types to file and allow user to edit.
54 kaz 1.13 (setf types (types-let-user-edit types *mcvs-types*))
55 kaz 1.10
56     ;; User has edited, so now we must honor all of the :IGNORE
57     ;; entries in the types, and remove the matching files from the
58     ;; mapping.
59 kaz 1.13 (setf filemap (types-remove-ignores types filemap))
60 kaz 1.10
61     ;; Create F-files by hard linking
62 kaz 1.19 (dolist (entry filemap)
63     (with-slots (kind id path) entry
64     (when (eq kind :file)
65     (link path id))))
66 kaz 1.1
67 kaz 1.15 ;; Write out mapping.
68 kaz 1.10 (mapping-write filemap *mcvs-map* :sort-map t)
69 kaz 1.15
70     ;; Create .cvsignore file.
71     (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)
72     :name ".cvsignore")
73     :direction :output)
74     (write-line *mcvs-map-local-name* f))
75 kaz 1.10
76     (loop
77     (restart-case
78     (current-dir-restore
79     (chdir *mcvs-dir*)
80 kaz 1.14 (chatter-debug "Invoking CVS.~%")
81 kaz 1.1
82 kaz 1.17 (if (not (execute-program `("cvs" ,@(format-opt global-options)
83 kaz 1.16 "import" "-I" "!"
84 kaz 1.17 ,@(format-opt command-options)
85 kaz 1.10 ,@(types-to-import-wrapper-args types)
86 kaz 1.18 ,module "Created-by-Meta-CVS" ,release)))
87 kaz 1.10 (error "CVS import failed."))
88     (return))
89     (retry ()
90     :report "Try invoking CVS again.")))))
91 kaz 1.14 (chatter-debug "removing ~a directory~%" *mcvs-dir*)
92 kaz 1.1 (delete-recursive *mcvs-dir*))
93     (values))
94 kaz 1.2
95 kaz 1.17 (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)
96 kaz 1.18 (if (< (length mcvs-args) 2)
97     (error "mcvs-create: specify module and release tag."))
98     (destructuring-bind (module release &rest superfluous) mcvs-args
99 kaz 1.2 (when superfluous
100 kaz 1.18 (error "mcvs-create: specify only module and release tag."))
101     (mcvs-create module release cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5