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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.2.3 - (hide annotations)
Sun Nov 10 06:45:07 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0, mcvs-0-99, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-1, mcvs-1-0-2
Changes since 1.1.2.2: +3 -0 lines
Add test for empty paths.
1 kaz 1.1.2.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 kaz 1.1.2.3 (when (or (string= "" target)
12     (string= "" name))
13     (error "empty path names are invalid."))
14 kaz 1.1.2.1 (in-sandbox-root-dir
15 kaz 1.1.2.2 (let* ((mapping (mapping-read *mcvs-map*))
16     (real-name (sandbox-translate-path name))
17     (abs-name (real-to-abstract-path real-name))
18     (trailing-slash (string= (char name (1- (length name))) *path-sep*))
19     (file-info (no-existence-error (stat real-name)))
20     (in-map (mapping-lookup mapping abs-name))
21     (prefix-in-map (mapping-prefix-lookup mapping abs-name))
22     (is-non-dir (or in-map (and file-info (not (directory-p file-info)))))
23     (is-dir (and (not is-non-dir)
24     (or prefix-in-map (directory-p file-info) trailing-slash)))
25     (need-new-entry t))
26     (when (path-prefix-equal *mcvs-dir* abs-name)
27     (error "path ~a is in a reserved Meta-CVS area." abs-name))
28     (chatter-debug "Synchronizing.~%")
29     (mapping-synchronize)
30    
31     (flet ((edit-map (entry)
32     (with-slots (path kind (tgt target)) entry
33     (chatter-debug "Clobbering existing object ~a.~%" path)
34     (unlink (abstract-to-real-path path))
35     (cond
36     ((eq kind :symlink)
37     (chatter-debug "Editing existing link.~%")
38     (setf tgt target)
39     (setf need-new-entry nil)
40     (symlink target (abstract-to-real-path path)))
41     (t (setf mapping
42     (remove entry mapping
43     :test #'eq))))))
44     (make-new-entry (abs-name)
45     (when need-new-entry
46     (chatter-debug "Making new symlink entry ~a.~%" abs-name)
47     (push (make-mapping-entry :kind :symlink
48     :id (mapping-generate-id :no-dir t :prefix "S-")
49     :path abs-name
50     :target target)
51     mapping))))
52    
53     (cond
54     (in-map
55     (edit-map in-map)
56     (make-new-entry abs-name))
57     (is-dir
58     (let* ((base (basename target))
59     (real-name (canonicalize-path (path-cat real-name base)))
60     (abs-name (canonicalize-path (path-cat abs-name base)))
61     (name (path-cat name base))
62     (file-info (no-existence-error (stat real-name)))
63     (in-map (mapping-lookup mapping abs-name))
64     (prefix-in-map (mapping-prefix-lookup mapping abs-name))
65     (is-non-dir (or in-map (and file-info (not (directory-p file-info)))))
66     (is-dir (and (not is-non-dir)
67     (or prefix-in-map (directory-p file-info)))))
68     (when is-dir
69     (error "~a is a directory." name))
70     (when in-map
71     (edit-map in-map))
72     (make-new-entry abs-name)))
73     (t (make-new-entry abs-name))))
74     (mapping-write mapping *mcvs-map* :sort-map t)
75     (chatter-debug "Updating file structure.~%")
76     (mapping-update)))
77 kaz 1.1.2.1 (values))
78    
79     (defun mcvs-link-wrapper (global-options command-options args)
80     (declare (ignore global-options command-options))
81     (when (/= (length args) 2)
82     (error "specify link target and link name."))
83     (mcvs-link (first args) (second args)))
84    
85     (defconstant *link-help*
86     "Syntax:
87    
88     mcvs link target-path name
89    
90     Semantics:
91    
92     Create a symbolic link with the given, pointing to the given target path.
93     Note the braindamaged reverse syntax, which is designed to be consistent
94     with the Unix ``ln'' command. To make the symbolic link @foo -> bar,
95     use ``mcvs ln bar foo''.
96    
97     Another way to add links is to create a symlink, and then use the add
98     command.")

  ViewVC Help
Powered by ViewVC 1.1.5