/[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.9 - (show annotations)
Tue Nov 28 04:12:08 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.8: +3 -3 lines
Getting rid of mcvs- prefixes.

* code/package.lisp (defpackage): shadow the merge symbol.

* code/purge.lisp (mcvs-purge): renamed to purge
(mcvs-purge-wrapper): renamed to purge-wrapper

* code/restore.lisp (mcvs-restore): renamed to restore
(mcvs-restore-wrapper): renamed to restore-wrapper

* code/update.lisp (mcvs-update): renamed to update
(mcvs-update-wrapper): renamed to update-wrapper

* code/main.lisp (mcvs-help): renamed to help
(*mcvs-command-table*): renamed to *command-table*
(mcvs-terminate catch): renamed to terminate.

* code/execute.lisp (mcvs-execute): renamed to execute

* code/move.lisp (mcvs-move): renamed to move
(mcvs-move-wrapper): renamed to move-wrapper

* code/grab.lisp (mcvs-grab): renamed to grab
(mcvs-grab-wrapper): renamed to grab-wrapper

* code/prop.lisp (mcvs-prop): renamed to prop
(mcvs-prop-wrapper): renamed to prop-wrapper

* code/filt.lisp (mcvs-filt-loop): renamed to filt-loop
(mcvs-filt): renamed to filt
(mcvs-remote-filt): renamed to remote-filt
(mcvs-filt-wrapper): renamed to filt-wrapper
(mcvs-remote-filt-wrapper): renamed to remote-filt-wrapper

* code/branch.lisp (mcvs-branch): renamed to branch
(mcvs-branch-wrapper): renamed to branch-wrapper
(mcvs-merge): renamed to merge
(mcvs-list-branches): renamed to list-branches
(mcvs-merge-wrapper): renamed to merge-wrapper
(mcvs-remerge-wrapper): renamed to remerge-wrapper
(mcvs-list-branches-wrapper): renamed to list-branches-wrapper
(mcvs-switch-wrapper): renamed to switch-wrapper

* code/link.lisp (mcvs-link): renamed to ln
(mcvs-link-wrapper): renamed to link-wrapper

* code/watch.lisp (mcvs-watch): renamed to watch
(mcvs-watch-wrapper): renamed to watch-wrapper

* code/add.lisp (mcvs-add): renamed to add
(mcvs-add-wrapper): renamed to add-wrapper

* code/remove.lisp (mcvs-remove): renamed to rm
(mcvs-remove-wrapper): renamed to remove-wrapper

* code/convert.lisp (mcvs-convert): renamed to convert
(mcvs-convert-wrapper): renamed to convert-wrapper

* code/error.lisp (mcvs-terminate): renamed to terminate
(mcvs-error-handler): renamed to error-handler
(*mcvs-error-treatment*): renamed to *error-treatment*
(*mcvs-errors-occured-p*): renamed to *errors-occured-p*

* code/checkout.lisp (mcvs-checkout): renamed to checkout
(mcvs-checkout-wrapper): renamed to checkout-wrapper
(mcvs-export-wrapper): renamed to export-wrapper

* code/generic.lisp (mcvs-generic): renamed to generic
(mcvs-commit-wrapper): renamed to commit-wrapper
(mcvs-diff-wrapper): renamed to diff-wrapper
(mcvs-tag-wrapper): renamed to tag-wrapper
(mcvs-log-wrapper): renamed to log-wrapper
(mcvs-status-wrapper): renamed to status-wrapper
(mcvs-annotate-wrapper): renamed to annotate-wrapper
(mcvs-watchers-wrapper): renamed to watchers-wrapper
(mcvs-edit-wrapper): renamed to edit-wrapper
(mcvs-unedit-wrapper): renamed to unedit-wrapper
(mcvs-editors-wrapper): renamed to editors-wrapper
(mcvs-sync-to-wrapper): renamed to sync-to-wrapper
(mcvs-sync-from-wrapper): renamed to sync-from-wrapper

* code/create.lisp (mcvs-create): renamed to create
(mcvs-create-wrapper): renamed to create-wrapper

* code/remap.lisp (mcvs-remap): renamed to remap
(mcvs-remap-wrapper): renamed to remap-wrapper

* code/mapping.lisp (mcvs-locate): renamed to locate
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 (in-package :meta-cvs)
6
7 (defun ln (target name)
8 (when (or (string= "" target)
9 (string= "" name))
10 (error "empty path names are invalid."))
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
26 ;; In case a link clobbers some object that has local edits,
27 ;; we need to synchronize it to the MCVS directory.
28 (chatter-debug "Synchronizing.~%")
29 (mapping-synchronize :direction :left)
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 (values))
78
79 (defun 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 (ln (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 name, containing the target path.
93 Note the braindamaged reverse syntax, which is deliberately 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