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

Contents of /meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Thu Mar 14 17:02:56 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-9
Changes since 1.15: +1 -1 lines
Whitespace change.
1 kaz 1.9 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.5 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "system")
6     (require "mapping")
7     (require "chatter")
8     (provide "move")
9    
10     (defun simple-rename (filemap source dest-file)
11 kaz 1.11 (let ((dir-expansion (mapping-extract-paths
12     (mapping-prefix-matches filemap source))))
13 kaz 1.12 (mapping-rename-files filemap dir-expansion source dest-file)))
14 kaz 1.1
15     (defun simple-move-to-dir (filemap source dest-dir)
16 kaz 1.11 (let ((dir-expansion (mapping-extract-paths
17     (mapping-prefix-matches filemap source))))
18 kaz 1.7 (multiple-value-bind (base dir) (basename source)
19     (if dir
20     (if (path-equal dest-dir *this-dir*)
21 kaz 1.11 (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 kaz 1.16 (canonicalize-path (path-cat dest-dir base)))))))
25 kaz 1.1
26     (defun move-guts (filemap sources destination)
27     (let* ((two-args (null (second sources)))
28 kaz 1.15 (destination-trailing-slash (string= (char destination
29     (1- (length destination)))
30     *path-sep*))
31 kaz 1.8 (destination-file-object (no-existence-error (stat destination)))
32 kaz 1.11 (destination-file-exists (or (mapping-lookup filemap destination)
33 kaz 1.8 (and destination-file-object
34     (not (directory-p
35     destination-file-object)))))
36 kaz 1.1 (destination-dir-exists (and (not destination-file-exists)
37 kaz 1.11 (or (mapping-prefix-lookup filemap
38 kaz 1.8 destination)
39 kaz 1.15 (directory-p destination-file-object)
40     destination-trailing-slash))))
41 kaz 1.1 (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 kaz 1.4 (defun mcvs-move (args)
51     (when (< (length args) 2)
52     (error "mcvs-move: requires at least two arguments."))
53 kaz 1.1 (in-sandbox-root-dir
54 kaz 1.14 (chatter-debug "Renaming.~%")
55 kaz 1.10 (let ((filemap (mapping-read *mcvs-map*))
56 kaz 1.4 (sources (mapcar #'sandbox-translate-path (butlast args)))
57     (destination (sandbox-translate-path (first (last args)))))
58 kaz 1.1
59 kaz 1.2 (when (path-prefix-equal *mcvs-dir* destination)
60 kaz 1.9 (error "mcvs-move: destination path ~a is in a reserved Meta-CVS area."
61 kaz 1.2 destination))
62    
63 kaz 1.13 (let ((edited-filemap (move-guts filemap sources destination))
64     (restore-map t))
65 kaz 1.14 (chatter-debug "Synchronizing.~%")
66 kaz 1.13 (mapping-synchronize)
67     (unwind-protect
68     (progn
69     (mapping-write edited-filemap *mcvs-map* :sort-map t)
70 kaz 1.14 (chatter-debug "Updating file structure.~%")
71 kaz 1.13 (when (mapping-update)
72     (setf restore-map nil)))
73     (when restore-map
74 kaz 1.14 (chatter-debug "Undoing move.~%")
75 kaz 1.13 (mapping-write filemap *mcvs-map*)))))
76 kaz 1.1 (values)))
77 kaz 1.2
78 kaz 1.6 (defun mcvs-move-wrapper (cvs-options cvs-command-options mcvs-args)
79     (when (or cvs-options cvs-command-options)
80 kaz 1.2 (error
81     #.(concatenate 'string
82     "mcvs-move: CVS options specified, "
83     "but this operation does not invoke CVS.")))
84 kaz 1.4 (mcvs-move mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5