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

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (hide annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.34: +14 -14 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5