/[meta-cvs]/meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C
ViewVC logotype

Contents of /meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Tue Mar 12 21:00:19 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-8
Changes since 1.14: +6 -3 lines
Fix trailing slash bug in mcvs mv.

* move.lisp (simple-move-to-dir): Canonicalize path after catenating
destination and file base name. This nukes a double slash if
we move to a name with a trailing slash.
(move-guts): Treat a destination name that has a trailing slash
as a directory, unless it exists already as a non-directory.
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 "move")
9
10 (defun simple-rename (filemap source dest-file)
11 (let ((dir-expansion (mapping-extract-paths
12 (mapping-prefix-matches filemap source))))
13 (mapping-rename-files filemap dir-expansion source dest-file)))
14
15 (defun simple-move-to-dir (filemap source dest-dir)
16 (let ((dir-expansion (mapping-extract-paths
17 (mapping-prefix-matches filemap source))))
18 (multiple-value-bind (base dir) (basename source)
19 (if dir
20 (if (path-equal dest-dir *this-dir*)
21 (mapping-rename-files filemap dir-expansion source base)
22 (mapping-rename-files filemap dir-expansion dir dest-dir))
23 (mapping-rename-files filemap dir-expansion source
24 (canonicalize-path(path-cat dest-dir base)))))))
25
26 (defun move-guts (filemap sources destination)
27 (let* ((two-args (null (second sources)))
28 (destination-trailing-slash (string= (char destination
29 (1- (length destination)))
30 *path-sep*))
31 (destination-file-object (no-existence-error (stat destination)))
32 (destination-file-exists (or (mapping-lookup filemap destination)
33 (and destination-file-object
34 (not (directory-p
35 destination-file-object)))))
36 (destination-dir-exists (and (not destination-file-exists)
37 (or (mapping-prefix-lookup filemap
38 destination)
39 (directory-p destination-file-object)
40 destination-trailing-slash))))
41 (if two-args
42 (if destination-dir-exists
43 (simple-move-to-dir filemap (first sources) destination)
44 (simple-rename filemap (first sources) destination))
45 (if destination-file-exists
46 (error "mcvs-move: cannot move multiple to ~a." destination)
47 (dolist (source sources filemap)
48 (setf filemap (simple-move-to-dir filemap source destination)))))))
49
50 (defun mcvs-move (args)
51 (when (< (length args) 2)
52 (error "mcvs-move: requires at least two arguments."))
53 (in-sandbox-root-dir
54 (chatter-debug "Renaming.~%")
55 (let ((filemap (mapping-read *mcvs-map*))
56 (sources (mapcar #'sandbox-translate-path (butlast args)))
57 (destination (sandbox-translate-path (first (last args)))))
58
59 (when (path-prefix-equal *mcvs-dir* destination)
60 (error "mcvs-move: destination path ~a is in a reserved Meta-CVS area."
61 destination))
62
63 (let ((edited-filemap (move-guts filemap sources destination))
64 (restore-map t))
65 (chatter-debug "Synchronizing.~%")
66 (mapping-synchronize)
67 (unwind-protect
68 (progn
69 (mapping-write edited-filemap *mcvs-map* :sort-map t)
70 (chatter-debug "Updating file structure.~%")
71 (when (mapping-update)
72 (setf restore-map nil)))
73 (when restore-map
74 (chatter-debug "Undoing move.~%")
75 (mapping-write filemap *mcvs-map*)))))
76 (values)))
77
78 (defun mcvs-move-wrapper (cvs-options cvs-command-options mcvs-args)
79 (when (or cvs-options cvs-command-options)
80 (error
81 #.(concatenate 'string
82 "mcvs-move: CVS options specified, "
83 "but this operation does not invoke CVS.")))
84 (mcvs-move mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5