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

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (hide annotations)
Sun Sep 8 20:23:21 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24
Changes since 1.20: +1 -1 lines
Another stupid error.

* code/create.lisp (mcvs-create): Fix use to unbound
variable file-info which should be fi.
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 kaz 1.21 fi))
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