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

Contents of /meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show annotations)
Mon Jul 8 05:50:17 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-20, symlink-branch~branch-point, mcvs-0-22, mcvs-0-23, mcvs-0-21, mcvs-0-95, mcvs-0-96, mcvs-0-19, symlink-branch~merged-to-HEAD-0
Branch point for: symlink-branch
Changes since 1.20: +4 -2 lines
* move.lisp (move-guts): When moving multiple sources to
a target directory, provide a restart to skip a bad source.
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 (require "restart")
9 (provide "move")
10
11 (defun source-check (expansion source)
12 (let ((real (abstract-to-real-path source)))
13 (when (path-prefix-equal *mcvs-dir* real)
14 (error "mcvs-move: source path ~a is in a reserved Meta-CVS area." real))
15 (when (not expansion)
16 (if (exists real)
17 (error "mcvs-move: ~a is local, not versioned under Meta-CVS." real)
18 (error "mcvs-move: ~a does not exist." real)))))
19
20 (defun simple-rename (filemap source dest-file)
21 (let ((dir-expansion (mapping-extract-paths
22 (mapping-prefix-matches filemap source))))
23 (source-check dir-expansion source)
24 (mapping-rename-files filemap dir-expansion source dest-file)))
25
26 (defun simple-move-to-dir (filemap source dest-dir)
27 (let ((dir-expansion (mapping-extract-paths
28 (mapping-prefix-matches filemap source))))
29 (source-check dir-expansion source)
30 (multiple-value-bind (base dir) (basename source)
31 (if dir
32 (if (path-equal dest-dir *this-dir*)
33 (mapping-rename-files filemap dir-expansion source base)
34 (mapping-rename-files filemap dir-expansion dir dest-dir))
35 (mapping-rename-files filemap dir-expansion source
36 (canonicalize-path (path-cat dest-dir base)))))))
37
38 (defun move-guts (filemap sources destination)
39 (let* ((two-args (null (second sources)))
40 (destination-trailing-slash (string= (char destination
41 (1- (length destination)))
42 *path-sep*))
43 (dest-real-path (abstract-to-real-path (canonicalize-path destination)))
44 (destination-file-object (no-existence-error (stat dest-real-path)))
45 (destination-file-exists (or (mapping-lookup filemap destination)
46 (and destination-file-object
47 (not (directory-p
48 destination-file-object)))))
49 (destination-dir-exists (and (not destination-file-exists)
50 (or (mapping-prefix-lookup filemap
51 destination)
52 (directory-p destination-file-object)
53 destination-trailing-slash))))
54 (if two-args
55 (if destination-dir-exists
56 (simple-move-to-dir filemap (first sources) destination)
57 (simple-rename filemap (first sources) destination))
58 (if destination-file-exists
59 (error "mcvs-move: cannot move multiple to ~a." destination)
60 (dolist (source sources filemap)
61 (can-restart-here ("Skip ~a and continue renaming." source)
62 (setf filemap (simple-move-to-dir filemap source destination))))))))
63
64 (defun mcvs-move (args)
65 (when (< (length args) 2)
66 (error "mcvs-move: requires at least two arguments."))
67 (in-sandbox-root-dir
68 (chatter-debug "Renaming.~%")
69 (let ((filemap (mapping-read *mcvs-map*))
70 (sources (mapcar #'real-to-abstract-path
71 (mapcar #'sandbox-translate-path (butlast args))))
72 (destination (real-to-abstract-path
73 (sandbox-translate-path (first (last args))))))
74
75 (let ((dest-real (abstract-to-real-path destination)))
76 (when (path-prefix-equal *mcvs-dir* dest-real)
77 (error "mcvs-move: destination path ~a is in a reserved Meta-CVS area."
78 dest-real)))
79
80 (let ((edited-filemap (move-guts filemap sources destination))
81 (restore-map t))
82 (chatter-debug "Synchronizing.~%")
83 (mapping-synchronize)
84 (unwind-protect
85 (progn
86 (mapping-write edited-filemap *mcvs-map* :sort-map t)
87 (chatter-debug "Updating file structure.~%")
88 (when (mapping-update)
89 (setf restore-map nil)))
90 (when restore-map
91 (chatter-debug "Undoing move.~%")
92 (mapping-write filemap *mcvs-map*)))))
93 (values)))
94
95 (defun mcvs-move-wrapper (cvs-options cvs-command-options mcvs-args)
96 (when (or cvs-options cvs-command-options)
97 (error
98 #.(concatenate 'string
99 "mcvs-move: CVS options specified, "
100 "but this operation does not invoke CVS.")))
101 (mcvs-move mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5