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

Contents of /meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Tue Mar 12 19:54:58 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.13: +4 -4 lines
* update.lisp (mcvs-update): Changing level of chatter messages.
* move.lisp (mcvs-move): Likewise.
* add.lisp (mcvs-add): Likewise.
* remove.lisp (mcvs-remove): Likewise.
* checkout.lisp (mcvs-checkout): Likewise.
* generic.lisp (mcvs-generic): Likewise.
* import.lisp (mcvs-import): Likewise.
* mapping.lisp (mapping-dupe-check): Likewise.
(mapping-update): Likewise.
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.7 (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.8 (destination-file-object (no-existence-error (stat destination)))
29 kaz 1.11 (destination-file-exists (or (mapping-lookup filemap destination)
30 kaz 1.8 (and destination-file-object
31     (not (directory-p
32     destination-file-object)))))
33 kaz 1.1 (destination-dir-exists (and (not destination-file-exists)
34 kaz 1.11 (or (mapping-prefix-lookup filemap
35 kaz 1.8 destination)
36     (directory-p
37     destination-file-object)))))
38 kaz 1.1 (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 kaz 1.4 (defun mcvs-move (args)
48     (when (< (length args) 2)
49     (error "mcvs-move: requires at least two arguments."))
50 kaz 1.1 (in-sandbox-root-dir
51 kaz 1.14 (chatter-debug "Renaming.~%")
52 kaz 1.10 (let ((filemap (mapping-read *mcvs-map*))
53 kaz 1.4 (sources (mapcar #'sandbox-translate-path (butlast args)))
54     (destination (sandbox-translate-path (first (last args)))))
55 kaz 1.1
56 kaz 1.2 (when (path-prefix-equal *mcvs-dir* destination)
57 kaz 1.9 (error "mcvs-move: destination path ~a is in a reserved Meta-CVS area."
58 kaz 1.2 destination))
59    
60 kaz 1.13 (let ((edited-filemap (move-guts filemap sources destination))
61     (restore-map t))
62 kaz 1.14 (chatter-debug "Synchronizing.~%")
63 kaz 1.13 (mapping-synchronize)
64     (unwind-protect
65     (progn
66     (mapping-write edited-filemap *mcvs-map* :sort-map t)
67 kaz 1.14 (chatter-debug "Updating file structure.~%")
68 kaz 1.13 (when (mapping-update)
69     (setf restore-map nil)))
70     (when restore-map
71 kaz 1.14 (chatter-debug "Undoing move.~%")
72 kaz 1.13 (mapping-write filemap *mcvs-map*)))))
73 kaz 1.1 (values)))
74 kaz 1.2
75 kaz 1.6 (defun mcvs-move-wrapper (cvs-options cvs-command-options mcvs-args)
76     (when (or cvs-options cvs-command-options)
77 kaz 1.2 (error
78     #.(concatenate 'string
79     "mcvs-move: CVS options specified, "
80     "but this operation does not invoke CVS.")))
81 kaz 1.4 (mcvs-move mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5