/[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.2 - (show annotations)
Sun Nov 10 06:40:47 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.1.2.1: +62 -29 lines
* code/link.lisp (mcvs-link): Revamped link command to behave properly
when the destination object is a directory. It must create the link in
that directory, rather than try to create a link with that name.
Plus handles various tricky cases. Trailing slash in destination name,
destination that is a directory within target directory, attempted
link creation in MCVS etc.
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.")

  ViewVC Help
Powered by ViewVC 1.1.5