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

Contents of /meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Sat Feb 2 11:39:36 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-3, mcvs-0-5, mcvs-0-4, latest-patch
Changes since 1.11: +1 -4 lines
* mapping.lisp (mapping-update): When moving files, ensure
that the target is unlinked if it exists.

* move.lisp (simple-rename): No longer do target unlinking
here. Also bugfix: it wasn't handling renames of directories
containing just one file.
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 (path-cat dest-dir base))))))
25
26 (defun move-guts (filemap sources destination)
27 (let* ((two-args (null (second sources)))
28 (destination-file-object (no-existence-error (stat destination)))
29 (destination-file-exists (or (mapping-lookup filemap destination)
30 (and destination-file-object
31 (not (directory-p
32 destination-file-object)))))
33 (destination-dir-exists (and (not destination-file-exists)
34 (or (mapping-prefix-lookup filemap
35 destination)
36 (directory-p
37 destination-file-object)))))
38 (if two-args
39 (if destination-dir-exists
40 (simple-move-to-dir filemap (first sources) destination)
41 (simple-rename filemap (first sources) destination))
42 (if destination-file-exists
43 (error "mcvs-move: cannot move multiple to ~a." destination)
44 (dolist (source sources filemap)
45 (setf filemap (simple-move-to-dir filemap source destination)))))))
46
47 (defun mcvs-move (args)
48 (when (< (length args) 2)
49 (error "mcvs-move: requires at least two arguments."))
50 (in-sandbox-root-dir
51 (chatter-info "Renaming.~%")
52 (let ((filemap (mapping-read *mcvs-map*))
53 (sources (mapcar #'sandbox-translate-path (butlast args)))
54 (destination (sandbox-translate-path (first (last args)))))
55
56 (when (path-prefix-equal *mcvs-dir* destination)
57 (error "mcvs-move: destination path ~a is in a reserved Meta-CVS area."
58 destination))
59
60 (setf filemap (move-guts filemap sources destination))
61
62 (chatter-info "Synchronizing.~%")
63 (mapping-synchronize)
64 (mapping-write filemap *mcvs-map* :sort-map t)
65 (chatter-info "Updating file structure.~%")
66 (mapping-update))
67 (values)))
68
69 (defun mcvs-move-wrapper (cvs-options cvs-command-options mcvs-args)
70 (when (or cvs-options cvs-command-options)
71 (error
72 #.(concatenate 'string
73 "mcvs-move: CVS options specified, "
74 "but this operation does not invoke CVS.")))
75 (mcvs-move mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5