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

  ViewVC Help
Powered by ViewVC 1.1.5