/[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.1 by kaz, Sat Oct 26 18:54:43 2002 UTC revision 1.26.2.2 by kaz, Thu Feb 27 05:59:39 2003 UTC
# Line 16  Line 16 
16      (if (not created)      (if (not created)
17        (error "A ~a directory already exists here." *mcvs-dir*)))        (error "A ~a directory already exists here." *mcvs-dir*)))
18    
19    (unwind-protect    (let ((preserve-mcvs-dir nil))
20      (progn      (unwind-protect
21        (let (filemap types)        (progn
22          (chatter-debug "Mapping.~%")          (let (filemap types)
23              (chatter-debug "Mapping.~%")
24          ;; Gather up list of files to import, and build up mapping,  
25          ;; as well as list of suffixes (file types).            ;; Gather up list of files to import, and build up mapping,
26          (for-each-file-info (fi ".")            ;; as well as list of suffixes (file types).
27            (cond            (for-each-file-info (fi ".")
28              ((regular-p fi)              (cond
29                 (let* ((path (canonicalize-path (file-name fi)))                ((regular-p fi)
30                        (suffix (suffix (file-name fi)))                   (let* ((path (canonicalize-path (file-name fi)))
31                        (file (mapping-generate-id :suffix suffix)))                          (suffix (suffix (file-name fi)))
32                   (chatter-info "~a <- ~a~%" file path)                          (file (mapping-generate-id :suffix suffix)))
33                   (push (make-mapping-entry :kind :file                     (chatter-info "~a <- ~a~%" file path)
34                                             :id file                     (push (make-mapping-entry :kind :file
35                                             :path path                                               :id file
36                                             :executable (executable-p                                               :path path
37                                                           fi))                                               :executable (executable-p
38                         filemap)                                                             fi))
39                   (when suffix                           filemap)
40                     (setf types (adjoin (list suffix :default)                     (when suffix
41                                         types :test #'equal)))))                       (setf types (adjoin (list suffix :default)
42              ((symlink-p fi)                                           types :test #'equal)))))
43                 (let ((path (canonicalize-path (file-name fi)))                ((symlink-p fi)
44                       (id (mapping-generate-id :prefix "S-" :no-dir t)))                   (let ((path (canonicalize-path (file-name fi)))
45                   (chatter-info "~a <- ~a~%" id path)                         (id (mapping-generate-id :prefix "S-" :no-dir t)))
46                   (push (make-mapping-entry :kind :symlink                     (chatter-info "~a <- ~a~%" id path)
47                                             :id id                     (push (make-mapping-entry :kind :symlink
48                                             :path path                                               :id id
49                                             :target (readlink path))                                               :path path
50                         filemap)))))                                               :target (readlink path))
51                             filemap)))))
52    
53          ;; Write out types to file and allow user to edit.  
54          (setf types (types-let-user-edit types *mcvs-types*))            ;; Write out types to file and allow user to edit.
55              (setf types (types-let-user-edit types *mcvs-types*))
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            ;; Detect backup files or other crud written by
58          ;; mapping.            ;; user's text editor.
59          (setf filemap (types-remove-ignores types filemap))            (current-dir-restore
60                (chdir *mcvs-dir*)
61          ;; Create F-files by hard linking              (let (crud)
62          (dolist (entry filemap)                (for-each-path (p ".")
63            (with-slots (kind id path) entry                  (let ((cp (canonicalize-path p)))
64              (when (eq kind :file)                    (unless (or (path-equal cp *mcvs-types-name*)
65                (link path id))))                                (path-equal cp *this-dir*))
66                        (push cp crud))))
67          ;; Write out mapping.                (when crud
68          (mapping-write filemap *mcvs-map* :sort-map t)                  (setf preserve-mcvs-dir t)
69                    (block nil
70          ;; Create .cvsignore file.                    (restart-bind
71          (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)                      ((continue
72                                            :name ".cvsignore")                         #'(lambda ()
73                             :direction :output)                             (return))
74            (write-line *mcvs-map-local-name* f)                         :report-function
75            (write-line *mcvs-displaced-name* f))                         #'(lambda (stream)
76                               (write-string "Delete the unexpected files."
77          (loop                                           stream)))
78            (restart-case                       (show
79              (current-dir-restore                         #'(lambda ()
80                (chdir *mcvs-dir*)                             (dolist (cp crud)
81                (chatter-debug "Invoking CVS.~%")                               (write-line cp)))
82                           :report-function
83                (if (not (execute-program `("cvs" ,@(format-opt global-options)                         #'(lambda (stream)
84                                           "import" "-I" "!"                             (write-string "List the names of the unexpected files."
85                                           ,@(format-opt command-options)                                           stream))))
86                                           ,@(types-to-import-wrapper-args types)                      (error "Unexpected files found in ~a directory. (Text editor backups?)"
87                                           ,module "Created-by-Meta-CVS" ,release)))                             *mcvs-dir*)))
88                  (error "CVS import failed."))                  (dolist (cp crud)
89                (return))                    (unlink cp))
90              (retry ()                  (setf preserve-mcvs-dir nil))))
91                :report "Try invoking CVS again.")))))  
92      (chatter-debug "removing ~a directory~%" *mcvs-dir*)            ;; User has edited, so now we must honor all of the :IGNORE
93      (delete-recursive *mcvs-dir*))            ;; entries in the types, and remove the matching files from the
94              ;; mapping.
95              (setf filemap (types-remove-ignores types filemap))
96    
97              ;; Create F-files by hard linking
98              (dolist (entry filemap)
99                (with-slots (kind id path) entry
100                  (when (eq kind :file)
101                    (link path id))))
102    
103              ;; Write out mapping.
104              (mapping-write filemap *mcvs-map* :sort-map t)
105    
106              ;; Create .cvsignore file.
107              (with-open-file (f (make-pathname :directory `(:relative ,*mcvs-dir*)
108                                                :name ".cvsignore")
109                                 :direction :output)
110                (write-line *mcvs-map-local-name* f)
111                (write-line *mcvs-displaced-name* f))
112    
113              (loop
114                (restart-case
115                  (current-dir-restore
116                    (chdir *mcvs-dir*)
117                    (chatter-debug "Invoking CVS.~%")
118    
119                    (if (not (execute-program `("cvs" ,@(format-opt global-options)
120                                               "import" "-I" "!"
121                                               ,@(format-opt command-options)
122                                               ,@(types-to-import-wrapper-args types)
123                                               ,module "Created-by-Meta-CVS" ,release)))
124                      (error "CVS import failed."))
125                    (return))
126                  (retry ()
127                    :report "Try invoking CVS again.")))))
128          (if preserve-mcvs-dir
129            (chatter-info "not removing ~a directory~%" *mcvs-dir*)
130            (progn
131              (chatter-debug "removing ~a directory~%" *mcvs-dir*)
132              (delete-recursive *mcvs-dir*)))))
133    (values))    (values))
134    
135  (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)  (defun mcvs-create-wrapper (cvs-options cvs-command-options mcvs-args)

Legend:
Removed from v.1.26.2.1  
changed lines
  Added in v.1.26.2.2

  ViewVC Help
Powered by ViewVC 1.1.5