/[meta-cvs]/meta-cvs/F-5E30677BF94A6FA7AD45BAA270984CFA.lisp
ViewVC logotype

Diff of /meta-cvs/F-5E30677BF94A6FA7AD45BAA270984CFA.lisp

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

revision 1.1.2.1 by kaz, Sun Oct 27 00:25:39 2002 UTC revision 1.1.2.2 by kaz, Sun Nov 10 06:40:47 2002 UTC
# Line 9  Line 9 
9    
10  (defun mcvs-link (target name)  (defun mcvs-link (target name)
11    (in-sandbox-root-dir    (in-sandbox-root-dir
12      (let ((mapping (mapping-read *mcvs-map*))      (let* ((mapping (mapping-read *mcvs-map*))
13            (name (real-to-abstract-path (sandbox-translate-path name))))             (real-name (sandbox-translate-path name))
14        (let ((existing (mapping-lookup mapping name))             (abs-name (real-to-abstract-path real-name))
15              (need-new-entry t))             (trailing-slash (string= (char name (1- (length name))) *path-sep*))
16          (chatter-debug "Synchronizing.~%")             (file-info (no-existence-error (stat real-name)))
17          (mapping-synchronize)             (in-map (mapping-lookup mapping abs-name))
18          (when existing             (prefix-in-map (mapping-prefix-lookup mapping abs-name))
19            (with-slots (path kind (tgt target)) existing             (is-non-dir (or in-map (and file-info (not (directory-p file-info)))))
20              (chatter-debug "Clobbering existing object.~%")             (is-dir (and (not is-non-dir)
21              (unlink (abstract-to-real-path path))                          (or prefix-in-map (directory-p file-info) trailing-slash)))
22              (cond             (need-new-entry t))
23                ((eq kind :symlink)        (when (path-prefix-equal *mcvs-dir* abs-name)
24                   (chatter-debug "Editing existing link.~%")           (error "path ~a is in a reserved Meta-CVS area." abs-name))
25                   (setf tgt target)        (chatter-debug "Synchronizing.~%")
26                   (setf need-new-entry nil)        (mapping-synchronize)
27                   (symlink target (abstract-to-real-path path)))  
28                (t (setf mapping        (flet ((edit-map (entry)
29                         (remove name mapping                 (with-slots (path kind (tgt target)) entry
30                                 :test #'path-equal                   (chatter-debug "Clobbering existing object ~a.~%" path)
31                                 :key #'mapping-entry-path))))))                   (unlink (abstract-to-real-path path))
32          (when need-new-entry                   (cond
33            (push (make-mapping-entry :kind :symlink                     ((eq kind :symlink)
34                                      :id (mapping-generate-id :no-dir t :prefix "S-")                        (chatter-debug "Editing existing link.~%")
35                                      :path name                        (setf tgt target)
36                                      :target target)                        (setf need-new-entry nil)
37                  mapping))                        (symlink target (abstract-to-real-path path)))
38          (mapping-write mapping *mcvs-map* :sort-map t)                     (t (setf mapping
39          (chatter-debug "Updating file structure.~%")                              (remove entry mapping
40          (mapping-update))))                                      :test #'eq))))))
41                 (make-new-entry (abs-name)
42                   (when need-new-entry
43                     (chatter-debug "Making new symlink entry ~a.~%" abs-name)
44                     (push (make-mapping-entry :kind :symlink
45                                               :id (mapping-generate-id :no-dir t :prefix "S-")
46                                               :path abs-name
47                                               :target target)
48                           mapping))))
49    
50            (cond
51              (in-map
52                 (edit-map in-map)
53                 (make-new-entry abs-name))
54              (is-dir
55                 (let* ((base (basename target))
56                        (real-name (canonicalize-path (path-cat real-name base)))
57                        (abs-name (canonicalize-path (path-cat abs-name base)))
58                        (name (path-cat name base))
59                        (file-info (no-existence-error (stat real-name)))
60                        (in-map (mapping-lookup mapping abs-name))
61                        (prefix-in-map (mapping-prefix-lookup mapping abs-name))
62                        (is-non-dir (or in-map (and file-info (not (directory-p file-info)))))
63                        (is-dir (and (not is-non-dir)
64                                     (or prefix-in-map (directory-p file-info)))))
65                   (when is-dir
66                      (error "~a is a directory." name))
67                   (when in-map
68                     (edit-map in-map))
69                   (make-new-entry abs-name)))
70              (t (make-new-entry abs-name))))
71          (mapping-write mapping *mcvs-map* :sort-map t)
72          (chatter-debug "Updating file structure.~%")
73          (mapping-update)))
74    (values))    (values))
75    
76  (defun mcvs-link-wrapper (global-options command-options args)  (defun mcvs-link-wrapper (global-options command-options args)

Legend:
Removed from v.1.1.2.1  
changed lines
  Added in v.1.1.2.2

  ViewVC Help
Powered by ViewVC 1.1.5