/[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 - (show 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 ;;; 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 "dirwalk")
6 (require "system")
7 (require "mapping")
8 (require "types")
9 (require "chatter")
10 (require "options")
11 (provide "create")
12
13 (defun mcvs-create (module release &optional global-options command-options)
14 (multiple-value-bind (path created) (ensure-directories-exist *mcvs-map*)
15 (declare (ignore path))
16 (if (not created)
17 (error "mcvs-create: A ~a directory already exists here." *mcvs-dir*)))
18
19 (unwind-protect
20 (progn
21 (let (filemap types)
22 (chatter-debug "Mapping.~%")
23
24 ;; Gather up list of files to import, and build up mapping,
25 ;; as well as list of suffixes (file types).
26 (for-each-file-info (fi ".")
27 (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 :path path
36 :executable (executable-p
37 file-info))
38 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
53 ;; Write out types to file and allow user to edit.
54 (setf types (types-let-user-edit types *mcvs-types*))
55
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 (setf filemap (types-remove-ignores types filemap))
60
61 ;; Create F-files by hard linking
62 (dolist (entry filemap)
63 (with-slots (kind id path) entry
64 (when (eq kind :file)
65 (link path id))))
66
67 ;; Write out mapping.
68 (mapping-write filemap *mcvs-map* :sort-map t)
69
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
76 (loop
77 (restart-case
78 (current-dir-restore
79 (chdir *mcvs-dir*)
80 (chatter-debug "Invoking CVS.~%")
81
82 (if (not (execute-program `("cvs" ,@(format-opt global-options)
83 "import" "-I" "!"
84 ,@(format-opt command-options)
85 ,@(types-to-import-wrapper-args types)
86 ,module "Created-by-Meta-CVS" ,release)))
87 (error "CVS import failed."))
88 (return))
89 (retry ()
90 :report "Try invoking CVS again.")))))
91 (chatter-debug "removing ~a directory~%" *mcvs-dir*)
92 (delete-recursive *mcvs-dir*))
93 (values))
94
95 (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)
96 (if (< (length mcvs-args) 2)
97 (error "mcvs-create: specify module and release tag."))
98 (destructuring-bind (module release &rest superfluous) mcvs-args
99 (when superfluous
100 (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