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

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Sat Jun 29 16:26:52 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-20, symlink-branch~branch-point, partial-sandbox-branch~branch-point, mcvs-0-21, partial-sandbox-branch~merged-to-HEAD-0, mcvs-0-17, mcvs-0-19, mcvs-0-18
Branch point for: symlink-branch, partial-sandbox-branch
Changes since 1.17: +7 -8 lines
* create.lisp (mcvs-create): Take out vendor branch parameter,
use "Created-by-Meta-CVS" as the vendor tag.
(mcvs-create-wrapper): Take out vendor branch parameter.
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 (when (regular-p fi)
28 (let* ((path (canonicalize-path (file-name fi)))
29 (suffix (suffix (file-name fi)))
30 (file (mapping-generate-name suffix)))
31 (chatter-info "~a <- ~a~%" file path)
32 (push (list file path) filemap)
33 (when suffix
34 (setf types (adjoin (list suffix :default)
35 types :test #'equal))))))
36
37 ;; Write out types to file and allow user to edit.
38 (setf types (types-let-user-edit types *mcvs-types*))
39
40 ;; User has edited, so now we must honor all of the :IGNORE
41 ;; entries in the types, and remove the matching files from the
42 ;; mapping.
43 (setf filemap (types-remove-ignores types filemap))
44
45 ;; Create F-files by hard linking
46 (dolist (item filemap)
47 (link (second item) (first item)))
48
49 ;; Write out mapping.
50 (mapping-write filemap *mcvs-map* :sort-map t)
51
52 ;; Create .cvsignore file.
53 (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)
54 :name ".cvsignore")
55 :direction :output)
56 (write-line *mcvs-map-local-name* f))
57
58 (loop
59 (restart-case
60 (current-dir-restore
61 (chdir *mcvs-dir*)
62 (chatter-debug "Invoking CVS.~%")
63
64 (if (not (execute-program `("cvs" ,@(format-opt global-options)
65 "import" "-I" "!"
66 ,@(format-opt command-options)
67 ,@(types-to-import-wrapper-args types)
68 ,module "Created-by-Meta-CVS" ,release)))
69 (error "CVS import failed."))
70 (return))
71 (retry ()
72 :report "Try invoking CVS again.")))))
73 (chatter-debug "removing ~a directory~%" *mcvs-dir*)
74 (delete-recursive *mcvs-dir*))
75 (values))
76
77 (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)
78 (if (< (length mcvs-args) 2)
79 (error "mcvs-create: specify module and release tag."))
80 (destructuring-bind (module release &rest superfluous) mcvs-args
81 (when superfluous
82 (error "mcvs-create: specify only module and release tag."))
83 (mcvs-create module release cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5