/[meta-cvs]/meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B
ViewVC logotype

Diff of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

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

revision 1.29.2.6 by kaz, Thu Apr 24 04:06:37 2003 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
4    
5  (require "system")  (in-package :meta-cvs)
 (require "mapping")  
 (require "chatter")  
 (require "dirwalk")  
 (require "seqfuncs")  
 (require "options")  
 (require "types")  
 (provide "add")  
6    
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             (saved-filemap (copy-list filemap))             (saved-filemap (copy-list filemap))
11             (types-exists (exists *mcvs-types*))             (types-exists (exists *types-path*))
12             (types (and types-exists (types-read *mcvs-types*)))             (types (and types-exists (types-read *types-path*)))
13             new-map-entries new-types)             new-map-entries new-types)
14    
15        (chatter-debug "Mapping.~%")        (chatter-debug "Mapping.~%")
# Line 35  Line 28 
28                (let ((abs-name (real-to-abstract-path full-name))                (let ((abs-name (real-to-abstract-path full-name))
29                      (file-info (stat full-name)))                      (file-info (stat full-name)))
30                  (cond                  (cond
31                    ((path-prefix-equal *mcvs-dir* full-name)                    ((path-prefix-equal *admin-dir* full-name)
32                      (error "cannot add ~a: path is in a reserved Meta-CVS area."                      (error "cannot add ~a: path is in a reserved Meta-CVS area."
33                             full-name))                             full-name))
34                    ((mapping-lookup filemap abs-name)                    ((mapping-lookup filemap abs-name)
# Line 71  Line 64 
64    
65        (let ((*dry-run-option* nil))        (let ((*dry-run-option* nil))
66          (unwind-protect          (unwind-protect
67            (setf new-types (types-let-user-edit new-types *mcvs-new-types*))            (setf new-types (types-let-user-edit new-types *types-new-path*))
68            (ignore-errors (unlink *mcvs-new-types*))))            (ignore-errors (unlink *types-new-path*))))
69    
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))
# Line 86  Line 79 
79                (if (eq kind :file)                (if (eq kind :file)
80                  (link real-name id)))))                  (link real-name id)))))
81    
82          (mapping-write filemap *mcvs-map* :sort-map t)          (mapping-write filemap *map-path* :sort-map t)
83    
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*))
86    
87          (setf new-map-entries (mapping-extract-kind new-map-entries :file))          (setf new-map-entries (mapping-extract-kind new-map-entries :file))
88    
# Line 99  Line 92 
92              (loop              (loop
93                (restart-case                (restart-case
94                  (current-dir-restore                  (current-dir-restore
95                    (chdir *mcvs-dir*)                    (chdir *admin-dir*)
96                    (chatter-debug "Invoking CVS.~%")                    (chatter-debug "Invoking CVS.~%")
97                    (dolist (add-args add-commands)                    (dolist (add-args add-commands)
98                      (when (not (execute-program `("cvs" ,@(format-opt cvs-options)                      (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
# Line 108  Line 101 
101                        (error "CVS add failed.")))                        (error "CVS add failed.")))
102                    (when (and types (not types-exists) (not *dry-run-option*))                    (when (and types (not types-exists) (not *dry-run-option*))
103                      (when (not (execute-program `("cvs" ,@(format-opt cvs-options)                      (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
104                                                    "add" ,*mcvs-types-name*)))                                                    "add" ,*types-file*)))
105                        (error "CVS add failed.")))                        (error "CVS add failed.")))
106                    (setf restore-needed nil)                    (setf restore-needed nil)
107                    (return))                    (return))
# Line 116  Line 109 
109                    :report "Try invoking CVS again.")))                    :report "Try invoking CVS again.")))
110              (when restore-needed              (when restore-needed
111                (chatter-terse "Undoing changes to map.~%")                (chatter-terse "Undoing changes to map.~%")
112                (mapping-write saved-filemap *mcvs-map*)                (mapping-write saved-filemap *map-path*)
113                (ignore-errors                (ignore-errors
114                  (dolist (entry new-map-entries)                  (dolist (entry new-map-entries)
115                    (unlink (mapping-entry-id entry)))))))                    (unlink (mapping-entry-id entry)))))))
# Line 125  Line 118 
118          (mapping-update))))          (mapping-update))))
119    (values))    (values))
120    
121  (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)  (defun 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)))
126    
127  (defconstant *add-help*  (defconstant *add-help*
128  "Syntax:  "Syntax:

Legend:
Removed from v.1.29.2.6  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5