/[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 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 0  Line 1 
1    ;;; This source file is part of the Meta-CVS program,
2    ;;; which is distributed under the GNU license.
3    ;;; Copyright 2002 Kaz Kylheku
4    
5    (require "system")
6    (require "mapping")
7    (require "chatter")
8    (provide "link")
9    
10    (defun mcvs-link (target name)
11      (in-sandbox-root-dir
12        (let* ((mapping (mapping-read *mcvs-map*))
13               (real-name (sandbox-translate-path name))
14               (abs-name (real-to-abstract-path real-name))
15               (trailing-slash (string= (char name (1- (length name))) *path-sep*))
16               (file-info (no-existence-error (stat real-name)))
17               (in-map (mapping-lookup mapping abs-name))
18               (prefix-in-map (mapping-prefix-lookup mapping abs-name))
19               (is-non-dir (or in-map (and file-info (not (directory-p file-info)))))
20               (is-dir (and (not is-non-dir)
21                            (or prefix-in-map (directory-p file-info) trailing-slash)))
22               (need-new-entry t))
23          (when (path-prefix-equal *mcvs-dir* abs-name)
24             (error "path ~a is in a reserved Meta-CVS area." abs-name))
25          (chatter-debug "Synchronizing.~%")
26          (mapping-synchronize)
27    
28          (flet ((edit-map (entry)
29                   (with-slots (path kind (tgt target)) entry
30                     (chatter-debug "Clobbering existing object ~a.~%" path)
31                     (unlink (abstract-to-real-path path))
32                     (cond
33                       ((eq kind :symlink)
34                          (chatter-debug "Editing existing link.~%")
35                          (setf tgt target)
36                          (setf need-new-entry nil)
37                          (symlink target (abstract-to-real-path path)))
38                       (t (setf mapping
39                                (remove entry mapping
40                                        :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))
75    
76    (defun mcvs-link-wrapper (global-options command-options args)
77      (declare (ignore global-options command-options))
78      (when (/= (length args) 2)
79        (error "specify link target and link name."))
80      (mcvs-link (first args) (second args)))
81    
82    (defconstant *link-help*
83    "Syntax:
84    
85      mcvs link target-path name
86    
87    Semantics:
88    
89      Create a symbolic link with the given, pointing to the given target path.
90      Note the braindamaged reverse syntax, which is designed to be consistent
91      with the Unix ``ln'' command. To make the symbolic link @foo -> bar,
92      use ``mcvs ln bar foo''.
93    
94      Another way to add links is to create a symlink, and then use the add
95      command.")

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

  ViewVC Help
Powered by ViewVC 1.1.5