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

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Sat Aug 31 20:53:13 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-22, mcvs-0-23
Changes since 1.18: +27 -11 lines
Merging symlink-branch to main trunk.
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 filemap)
37 (when suffix
38 (setf types (adjoin (list suffix :default)
39 types :test #'equal)))))
40 ((symlink-p fi)
41 (let ((path (canonicalize-path (file-name fi)))
42 (id (mapping-generate-id :prefix "S-" :no-dir t)))
43 (chatter-info "~a <- ~a~%" id path)
44 (push (make-mapping-entry :kind :symlink
45 :id id
46 :path path
47 :target (readlink path))
48 filemap)))))
49
50
51 ;; Write out types to file and allow user to edit.
52 (setf types (types-let-user-edit types *mcvs-types*))
53
54 ;; User has edited, so now we must honor all of the :IGNORE
55 ;; entries in the types, and remove the matching files from the
56 ;; mapping.
57 (setf filemap (types-remove-ignores types filemap))
58
59 ;; Create F-files by hard linking
60 (dolist (entry filemap)
61 (with-slots (kind id path) entry
62 (when (eq kind :file)
63 (link path id))))
64
65 ;; Write out mapping.
66 (mapping-write filemap *mcvs-map* :sort-map t)
67
68 ;; Create .cvsignore file.
69 (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)
70 :name ".cvsignore")
71 :direction :output)
72 (write-line *mcvs-map-local-name* f))
73
74 (loop
75 (restart-case
76 (current-dir-restore
77 (chdir *mcvs-dir*)
78 (chatter-debug "Invoking CVS.~%")
79
80 (if (not (execute-program `("cvs" ,@(format-opt global-options)
81 "import" "-I" "!"
82 ,@(format-opt command-options)
83 ,@(types-to-import-wrapper-args types)
84 ,module "Created-by-Meta-CVS" ,release)))
85 (error "CVS import failed."))
86 (return))
87 (retry ()
88 :report "Try invoking CVS again.")))))
89 (chatter-debug "removing ~a directory~%" *mcvs-dir*)
90 (delete-recursive *mcvs-dir*))
91 (values))
92
93 (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)
94 (if (< (length mcvs-args) 2)
95 (error "mcvs-create: specify module and release tag."))
96 (destructuring-bind (module release &rest superfluous) mcvs-args
97 (when superfluous
98 (error "mcvs-create: specify only module and release tag."))
99 (mcvs-create module release cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5