ViewVC logotype

Diff of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

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

revision by kaz, Fri Apr 5 00:02:06 2002 UTC revision 1.39 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
5  (require "system")  (in-package :meta-cvs)
 (require "mapping")  
 (require "chatter")  
 (require "dirwalk")  
 (require "seqfuncs")  
 (require "options")  
 (require "types")  
 (provide "add")  
7  (defun mcvs-add (recursivep cvs-options add-options files)  (defun add (recursivep cvs-options add-options files)
8    (in-sandbox-root-dir    (in-sandbox-root-dir
9      (let* ((filemap (mapping-read *mcvs-map*))      (let* ((filemap (mapping-read *map-path*))
10             (types-exists (exists *mcvs-types*))             (saved-filemap (copy-list filemap))
11             (types (and types-exists (types-read *mcvs-types*)))             (types-exists (exists *types-path*))
12               (types (and types-exists (types-read *types-path*)))
13             new-map-entries new-types)             new-map-entries new-types)
15        (chatter-debug "Mapping.~%")        (chatter-debug "Mapping.~%")
17        (dolist (file files)        (dolist (file files)
18          (let (expanded-paths)          (let (expanded-paths)
19            (if recursivep            (can-restart-here ("Continue processing arguments after ~a." file)
20              (for-each-path (full-name (sandbox-translate-path file))              (if recursivep
21                (push (canonicalize-path full-name) expanded-paths))                (for-each-path (full-name (sandbox-translate-path file))
22              (push (sandbox-translate-path file) expanded-paths))                  (push (canonicalize-path full-name) expanded-paths))
23                  (push (sandbox-translate-path file) expanded-paths)))
24            (nreverse expanded-paths)            (nreverse expanded-paths)
26            (dolist (full-name expanded-paths)            (dolist (full-name expanded-paths)
27              (can-restart-here ("Continue adding files.")              (can-restart-here ("Continue mapping files.")
28                (cond                (let ((abs-name (real-to-abstract-path full-name))
29                  ((path-prefix-equal *mcvs-dir* full-name)                      (file-info (stat full-name)))
30                    (error "mcvs-add: path ~a is in a reserved Meta-CVS area."                  (cond
31                           full-name))                    ((path-prefix-equal *admin-dir* full-name)
32                  ((mapping-lookup filemap full-name)                      (error "cannot add ~a: path is in a reserved Meta-CVS area."
33                    (chatter-info "mcvs-add: ~a already added.~%" full-name))                             full-name))
34                  ((directory-p full-name)                    ((mapping-lookup filemap abs-name)
35                    (when (not recursivep)                      (chatter-info "~a already added.~%" full-name))
36                      (error "mcvs-add: ~a, is a directory, use -R to add." full-name)))                    ((directory-p file-info)
37                  ((not (regular-p full-name))                      (when (not recursivep)
38                    (error "mcvs-add: cannot add ~a, not regular file."                        (error "cannot add ~a: it is a directory, use -R to add." full-name)))
39                           full-name))                    ((regular-p file-info)
40                  (t                      (let* ((suffix (suffix full-name))
41                    (let* ((suffix (suffix full-name))                             (f-file (mapping-generate-id :suffix suffix)))
42                           (f-file (mapping-generate-name suffix)))                        (when suffix
43                      (when suffix                              (setf new-types (adjoin (list suffix :default)
44                            (setf new-types (adjoin (list suffix :default)                                                      new-types :test #'equal)))
45                                                    new-types :test #'equal)))                        (push (make-mapping-entry :kind :file
46                      (push (list f-file full-name) new-map-entries))))))))                                                  :id f-file
47                                                    :path abs-name
48                                                    :executable (executable-p
49                                                                  file-info))
50                                new-map-entries)))
51                      ((symlink-p file-info)
52                        (let ((id (mapping-generate-id :no-dir t :prefix "S-")))
53                          (push (make-mapping-entry :kind :symlink
54                                                    :id id
55                                                    :path abs-name
56                                                    :target (readlink full-name))
57                                new-map-entries)))
58                      (t
59                        (error "cannot add ~a: not regular file or symlink."
60                               full-name))))))))
62        (setf new-types (set-difference        (setf new-types (set-difference
63                          new-types types :key #'first :test #'string=))                          new-types types :key #'first :test #'string=))
65        (unwind-protect        (let ((*dry-run-option* nil))
66          (setf new-types (types-let-user-edit new-types *mcvs-new-types*))          (unwind-protect
67          (ignore-errors (unlink *mcvs-new-types*)))            (setf new-types (types-let-user-edit new-types *types-new-path*))
68              (ignore-errors (unlink *types-new-path*))))
70        (setf new-map-entries (types-remove-ignores new-types new-map-entries))        (setf new-map-entries (types-remove-ignores new-types new-map-entries))
71        (setf new-map-entries (types-remove-ignores types new-map-entries))        (setf new-map-entries (types-remove-ignores types new-map-entries))
73        (when new-map-entries        (when new-map-entries
74          (dolist (map-entry new-map-entries)          (dolist (map-entry new-map-entries)
75            (destructuring-bind (f-file path-name) map-entry            (with-slots (kind id path) map-entry
76              (push map-entry filemap)              (push map-entry filemap)
77              (chatter-info "mapping ~a <- ~a~%" f-file path-name)              (let ((real-name (abstract-to-real-path path)))
78              (link path-name f-file)))                (chatter-info "mapping ~a <- ~a~%" id real-name)
79                  (if (eq kind :file)
80                    (link real-name id)))))
82          (mapping-write filemap *mcvs-map* :sort-map t)          (mapping-write filemap *map-path* :sort-map t)
84          (when (setf types (append types new-types))          (when (setf types (append types new-types))
85            (types-write types *mcvs-types*))            (types-write types *types-path*))
87          (chatter-debug "Recording adds.~%")          (setf new-map-entries (mapping-extract-kind new-map-entries :file))
89          (let ((add-args (types-make-cvs-adds types new-map-entries))          (let ((add-commands (types-make-cvs-adds types new-map-entries))
90                cvs-adds)                (restore-needed t))
91            (dolist (add-args add-args)            (unwind-protect
92              (push `("cvs" ,@(format-opt cvs-options)              (loop
93                      "add" ,@(format-opt add-options)                (restart-case
94                      ,@add-args) cvs-adds))                  (current-dir-restore
95            (when (and types (not types-exists))                    (chdir *admin-dir*)
96              (push `("cvs" ,@(format-opt cvs-options)                    (chatter-debug "Invoking CVS.~%")
97                      "add" ,*mcvs-types-name*) cvs-adds))                    (dolist (add-args add-commands)
98            (nreverse cvs-adds)                      (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
99            (with-open-file (f *mcvs-add-local*                                                    "add" ,@(format-opt add-options)
100                               :direction :input                                                    ,@add-args)))
101                               :if-does-not-exist nil)                        (error "CVS add failed.")))
102              (when f                    (when (and types (not types-exists) (not *dry-run-option*))
103                (setf cvs-adds (append cvs-adds (read f)))))                      (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
104                                                      "add" ,*types-file*)))
105            (with-open-file (f *mcvs-add-local*                        (error "CVS add failed.")))
106                               :direction :output)                    (setf restore-needed nil)
107              (prin1 cvs-adds f)                    (return))
108              (terpri f)))                  (retry ()
109                      :report "Try invoking CVS again.")))
110          (chatter-debug "Synchronizing.~%")              (when restore-needed
111          (mapping-synchronize)                (chatter-terse "Undoing changes to map.~%")
112                  (mapping-write saved-filemap *map-path*)
113                  (ignore-errors
114                    (dolist (entry new-map-entries)
115                      (unlink (mapping-entry-id entry)))))))
117          (chatter-debug "Updating file structure.~%")          (chatter-debug "Updating file structure.~%")
118          (mapping-update))))          (mapping-update))))
119    (values))    (values))
121  (defun complete-local-adds ()  (defun add-wrapper (cvs-options cvs-command-options mcvs-args)
     (chdir *mcvs-dir*)  
       (let ((overall-success t)  
             (add-list (with-open-file (f *mcvs-add-local-name*  
                                          :direction :input  
                                          :if-does-not-exist nil)  
                         (if f  
                           (read f)))))  
         (dolist (cvs-add add-list)  
           (when (not (loop  
                          (if (not (execute-program cvs-add))  
                            (error "CVS add failed.")  
                            (return t))  
                          (retry ()  
                            :report "try invoking CVS again.")  
                          (continue ()  
                            :report "attempt to do any remaining adds."  
                            (return nil)))))  
             (setf overall-success nil)))  
         (if overall-success  
           (no-existence-error (unlink *mcvs-add-local-name*)))))))  
 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)  
122    (multiple-value-bind (recursivep rest-add-options)    (multiple-value-bind (recursivep rest-add-options)
123                         (separate "R" cvs-command-options                         (separate "R" cvs-command-options
124                                       :key #'first :test #'string=)                                       :key #'first :test #'string=)
125      (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))      (add recursivep cvs-options rest-add-options mcvs-args)))
127    (defconstant *add-help*
128    "Syntax:
130      mcvs add [ options ] objects ...
132    Options:
134  (defun mcvs-commit-wrapper (cvs-options cvs-command-options mcvs-args)    -R                Recursive behavior: recursively add the contents
135    (complete-local-adds)                      of all objects that are directories. By default,
136    (mcvs-generic "commit" cvs-options cvs-command-options nil mcvs-args))                      trying to add a directory signals a continuable error.
137      -m \"text ...\"     Use the specified text for the creation message.
138      -k key-expansion  Add the file with the specified RCS expansion mode.
140    Semantics:
142      The add command brings local filesystem objects under version control.
143      The changes are not immediately incorporated into the repository; rather,
144      the addition a local change that is ``scheduled'' until the next commit
145      operation.
147      Objects that can be added are files and symbolic links. Directories are not
148      versioned objects in Meta-CVS; instead, files and symbolic links have a
149      pathname property which gives rise to the existence of directories in the
150      sandbox. The only significant consequence of this design choice is that empty
151      directories have no direct representation in Meta-CVS.
153      If any added files have suffixes that were not previously added to the
154      project before, Meta-CVS will pop up a text editor to allow you to edit
155      a specification that assigns to each new file type its CVS expansion
156      mode.")

Removed from v.  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5