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

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (hide annotations)
Thu Feb 27 06:01:28 2003 UTC (11 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.28: +114 -75 lines
Merging from mcvs-1-0-branch.

* code/create.lisp (mcvs-create): After the TYPES file is
edited, scan the MCVS directory for unexpected files.
The intent is to detect text editor backups. If any are
found, some interactive error handling lets the user acknowledge
their deletion. If they are not deleted, then cvs import will
bring them into the repository. This behavior was discovered
by Johannes Grødem who suggested that it could be handled.
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.28 (require "mcvs-package")
12 kaz 1.17 (provide "create")
13 kaz 1.28
14     (in-package "META-CVS")
15 kaz 1.1
16 kaz 1.18 (defun mcvs-create (module release &optional global-options command-options)
17 kaz 1.1 (multiple-value-bind (path created) (ensure-directories-exist *mcvs-map*)
18 kaz 1.3 (declare (ignore path))
19 kaz 1.1 (if (not created)
20 kaz 1.25 (error "A ~a directory already exists here." *mcvs-dir*)))
21 kaz 1.1
22 kaz 1.29 (let ((preserve-mcvs-dir nil))
23     (unwind-protect
24     (progn
25     (let (filemap types)
26     (chatter-debug "Mapping.~%")
27    
28     ;; Gather up list of files to import, and build up mapping,
29     ;; as well as list of suffixes (file types).
30     (for-each-file-info (fi ".")
31     (cond
32     ((regular-p fi)
33     (let* ((path (canonicalize-path (file-name fi)))
34     (suffix (suffix (file-name fi)))
35     (file (mapping-generate-id :suffix suffix)))
36     (chatter-info "~a <- ~a~%" file path)
37     (push (make-mapping-entry :kind :file
38     :id file
39     :path path
40     :executable (executable-p
41     fi))
42     filemap)
43     (when suffix
44     (setf types (adjoin (list suffix :default)
45     types :test #'equal)))))
46     ((symlink-p fi)
47     (let ((path (canonicalize-path (file-name fi)))
48     (id (mapping-generate-id :prefix "S-" :no-dir t)))
49     (chatter-info "~a <- ~a~%" id path)
50     (push (make-mapping-entry :kind :symlink
51     :id id
52     :path path
53     :target (readlink path))
54     filemap)))))
55    
56    
57     ;; Write out types to file and allow user to edit.
58     (setf types (types-let-user-edit types *mcvs-types*))
59    
60     ;; Detect backup files or other crud written by
61     ;; user's text editor.
62     (current-dir-restore
63     (chdir *mcvs-dir*)
64     (let (crud)
65     (for-each-path (p ".")
66     (let ((cp (canonicalize-path p)))
67     (unless (or (path-equal cp *mcvs-types-name*)
68     (path-equal cp *this-dir*))
69     (push cp crud))))
70     (when crud
71     (setf preserve-mcvs-dir t)
72     (block nil
73     (restart-bind
74     ((continue
75     #'(lambda ()
76     (return))
77     :report-function
78     #'(lambda (stream)
79     (write-string "Delete the unexpected files."
80     stream)))
81     (show
82     #'(lambda ()
83     (dolist (cp crud)
84     (write-line cp)))
85     :report-function
86     #'(lambda (stream)
87     (write-string "List the names of the unexpected files."
88     stream))))
89     (error "Unexpected files found in ~a directory. (Text editor backups?)"
90     *mcvs-dir*)))
91     (dolist (cp crud)
92     (unlink cp))
93     (setf preserve-mcvs-dir nil))))
94    
95     ;; User has edited, so now we must honor all of the :IGNORE
96     ;; entries in the types, and remove the matching files from the
97     ;; mapping.
98     (setf filemap (types-remove-ignores types filemap))
99    
100     ;; Create F-files by hard linking
101     (dolist (entry filemap)
102     (with-slots (kind id path) entry
103     (when (eq kind :file)
104     (link path id))))
105    
106     ;; Write out mapping.
107     (mapping-write filemap *mcvs-map* :sort-map t)
108    
109     ;; Create .cvsignore file.
110     (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)
111     :name ".cvsignore")
112     :direction :output)
113     (write-line *mcvs-map-local-name* f)
114     (write-line *mcvs-displaced-name* f))
115    
116     (loop
117     (restart-case
118     (current-dir-restore
119     (chdir *mcvs-dir*)
120     (chatter-debug "Invoking CVS.~%")
121    
122     (if (not (execute-program `("cvs" ,@(format-opt global-options)
123     "import" "-I" "!"
124     ,@(format-opt command-options)
125     ,@(types-to-import-wrapper-args types)
126     ,module "Created-by-Meta-CVS" ,release)))
127     (error "CVS import failed."))
128     (return))
129     (retry ()
130     :report "Try invoking CVS again.")))))
131     (if preserve-mcvs-dir
132     (chatter-info "not removing ~a directory~%" *mcvs-dir*)
133     (progn
134     (chatter-debug "removing ~a directory~%" *mcvs-dir*)
135     (delete-recursive *mcvs-dir*)))))
136 kaz 1.1 (values))
137 kaz 1.2
138 kaz 1.17 (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)
139 kaz 1.18 (if (< (length mcvs-args) 2)
140 kaz 1.25 (error "specify module and release tag."))
141 kaz 1.18 (destructuring-bind (module release &rest superfluous) mcvs-args
142 kaz 1.2 (when superfluous
143 kaz 1.25 (error "specify only module and release tag."))
144 kaz 1.18 (mcvs-create module release cvs-options cvs-command-options)))
145 kaz 1.22
146     (defconstant *create-help*
147     "Syntax:
148    
149     mcvs create [ options ] module-name release-tag
150    
151     Options:
152    
153     -d Use a file's modification time as time of creation.
154 kaz 1.23 -k subst-mode Set default RCS keyword substitution mode.
155     -I ignore-spec Specify files to ignore in addition to whatever
156 kaz 1.27 is specified interactively. May cause problems;
157     since Meta-CVS will map these files anwyay.
158 kaz 1.23 -b branch-num Vendor branch number for CVS import. Deprecated
159 kaz 1.27 brain-damage; you should never need this.
160 kaz 1.23 -m \"text ...\" Log message.
161     -W wrap-spec CVS wrappers specification line. Keep in mind that
162 kaz 1.27 Meta-CVS preserves suffixes only; CVS sees a
163     name like \"F-D3BC...30D5.html\".
164 kaz 1.23 Semantics:
165    
166     The create command makes a new Meta-CVS module from the files and symbolic
167     links in the current directory, and all of its subdirectories. To work with
168     the newly created module, you must check it out to create a working copy.
169 kaz 1.24 The release-tag symbolically identifies the original baseline.
170    
171     There are some interactive steps involved. If any of the files have
172     suffixes, like .c or .html, Meta-CVS will identify and tabulate them.
173     A text editor will pop up presenting you with an opportunity to edit
174     a symbolic specification that assigns to each file type a CVS keyword
175     expansion mode.")

  ViewVC Help
Powered by ViewVC 1.1.5