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

Diff of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.26.2.4 by kaz, Tue Apr 22 05:53:42 2003 UTC revision 1.35 by kaz, Tue Nov 28 07:47:22 2006 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5  (require "dirwalk")  (in-package :meta-cvs)
 (require "system")  
 (require "mapping")  
 (require "types")  
 (require "chatter")  
 (require "options")  
 (require "restart")  
 (provide "create")  
6    
7  (defun mcvs-create (module release &optional global-options command-options)  (defun create (module release &optional global-options command-options)
8    (multiple-value-bind (path created) (ensure-directories-exist *mcvs-map*)    (multiple-value-bind (path created) (ensure-directories-exist *map-path*)
9      (declare (ignore path))      (declare (ignore path))
10      (if (not created)      (if (not created)
11        (error "A ~a directory already exists here." *mcvs-dir*)))        (error "A ~a directory already exists here." *admin-dir*)))
12    
13    (let ((preserve-mcvs-dir nil))    (let ((preserve-mcvs-dir nil))
14      (unwind-protect      (unwind-protect
# Line 53  Line 46 
46    
47    
48            ;; Write out types to file and allow user to edit.            ;; Write out types to file and allow user to edit.
49            (setf types (types-let-user-edit types *mcvs-types*))            (setf types (types-let-user-edit types *types-path*))
50    
51            ;; Detect backup files or other crud written by            ;; Detect backup files or other crud written by
52            ;; user's text editor.            ;; user's text editor.
53            (current-dir-restore            (current-dir-restore
54              (chdir *mcvs-dir*)              (chdir *admin-dir*)
55              (let (crud)              (let (crud)
56                (for-each-path (p ".")                (for-each-path (p ".")
57                  (let ((cp (canonicalize-path p)))                  (let ((cp (canonicalize-path p)))
58                    (unless (or (path-equal cp *mcvs-types-name*)                    (unless (or (path-equal cp *types-file*)
59                                (path-equal cp *this-dir*))                                (path-equal cp *this-dir*))
60                      (push cp crud))))                      (push cp crud))))
61                (when crud                (when crud
62                  (setf preserve-mcvs-dir t)                  (setf preserve-mcvs-dir t)
63                  (super-restart-case                  (super-restart-case
64                    (error "Unexpected files found in ~a directory. (Text editor backups?)"                    (error "Unexpected files found in ~a directory. (Text editor backups?)"
65                           *mcvs-dir*)                           *admin-dir*)
66                    (continue ()                    (continue ()
67                      :report "Delete the unexpected files."                      :report "Delete the unexpected files."
68                      (unwind))                      (unwind))
# Line 93  Line 86 
86                  (link path id))))                  (link path id))))
87    
88            ;; Write out mapping.            ;; Write out mapping.
89            (mapping-write filemap *mcvs-map* :sort-map t)            (mapping-write filemap *map-path* :sort-map t)
90    
91            ;; Create .cvsignore file.            ;; Create .cvsignore file.
92            (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)            (with-open-file (f (make-pathname :directory `(:relative ,*admin-dir*)
93                                              :name ".cvsignore")                                              :name ".cvsignore")
94                               :direction :output)                               :direction :output)
95              (write-line *mcvs-map-local-name* f)              (write-line *map-local-file* f)
96              (write-line *mcvs-displaced-name* f))              (write-line *displaced-file* f))
97    
98            (loop            (loop
99              (restart-case              (restart-case
100                (current-dir-restore                (current-dir-restore
101                  (chdir *mcvs-dir*)                  (chdir *admin-dir*)
102                  (chatter-debug "Invoking CVS.~%")                  (chatter-debug "Invoking CVS.~%")
103    
104                  (if (not (execute-program `("cvs" ,@(format-opt global-options)                  (if (not (execute-program `("cvs" ,@(format-opt global-options)
# Line 118  Line 111 
111                (retry ()                (retry ()
112                  :report "Try invoking CVS again.")))))                  :report "Try invoking CVS again.")))))
113        (if preserve-mcvs-dir        (if preserve-mcvs-dir
114          (chatter-info "not removing ~a directory~%" *mcvs-dir*)          (chatter-info "not removing ~a directory~%" *admin-dir*)
115          (progn          (progn
116            (chatter-debug "removing ~a directory~%" *mcvs-dir*)            (chatter-debug "removing ~a directory~%" *admin-dir*)
117            (delete-recursive *mcvs-dir*)))))            (delete-recursive *admin-dir*)))))
118    (values))    (values))
119    
120  (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)  (defun create-wrapper (cvs-options cvs-command-options mcvs-args)
121    (if (< (length mcvs-args) 2)    (if (< (length mcvs-args) 2)
122      (error "specify module and release tag."))      (error "specify module and release tag."))
123    (destructuring-bind (module release &rest superfluous) mcvs-args    (destructuring-bind (module release &rest superfluous) mcvs-args
124      (when superfluous      (when superfluous
125        (error "specify only module and release tag."))        (error "specify only module and release tag."))
126      (mcvs-create module release cvs-options cvs-command-options)))      (create module release cvs-options cvs-command-options)))
127    
128  (defconstant *create-help*  (defconstant *create-help*
129  "Syntax:  "Syntax:

Legend:
Removed from v.1.26.2.4  
changed lines
  Added in v.1.35

  ViewVC Help
Powered by ViewVC 1.1.5