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

Contents of /meta-cvs/F-255EFD9E99EDDE6614CF2CD912CA4E5C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sat Jan 26 01:40:34 2002 UTC (12 years, 3 months ago) by kaz
Branch: MAIN
Changes since 1.2: +1 -1 lines
Bugfix.
1 (require "system")
2 (require "mapping")
3 (require "chatter")
4 (provide "move")
5
6 (defun simple-rename (filemap source dest-file)
7 (let ((dir-expansion (filemap-extract-paths
8 (filemap-prefix-matches filemap source))))
9 (if (second dir-expansion)
10 (filemap-rename-files filemap dir-expansion source dest-file)
11 (filemap-rename-files filemap (list source) source dest-file))))
12
13 (defun simple-move-to-dir (filemap source dest-dir)
14 (let ((dir-expansion (filemap-extract-paths
15 (filemap-prefix-matches filemap source))))
16 (if (second dir-expansion)
17 (filemap-rename-files filemap dir-expansion source dest-dir)
18 (multiple-value-bind (base dir) (basename source)
19 (if dir
20 (if (path-equal dest-dir *this-dir*)
21 (filemap-rename-files filemap (list source) source base)
22 (filemap-rename-files filemap (list source) dir dest-dir))
23 (filemap-rename-files filemap (list source) 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-exists (filemap-lookup filemap destination))
29 (destination-dir-exists (and (not destination-file-exists)
30 (filemap-prefix-lookup filemap
31 destination))))
32 (if two-args
33 (if destination-dir-exists
34 (simple-move-to-dir filemap (first sources) destination)
35 (simple-rename filemap (first sources) destination))
36 (if destination-file-exists
37 (error "mcvs-move: cannot move multiple to ~a." destination)
38 (dolist (source sources filemap)
39 (setf filemap (simple-move-to-dir filemap source destination)))))))
40
41 (defun mcvs-move (arg1 arg2 &rest args)
42 (in-sandbox-root-dir
43 (chatter-info "Renaming.~%")
44 (let* ((filemap (with-open-file (file *mcvs-map* :direction :input)
45 (read file)))
46 (files (cons arg1 (cons arg2 args)))
47 (sources (mapcar #'sandbox-translate-path (butlast files)))
48 (destination (sandbox-translate-path (first (last files)))))
49
50 (when (path-prefix-equal *mcvs-dir* destination)
51 (error "mcvs-move: destination path ~a is in a MCVS meta-data area."
52 destination))
53
54 (setf filemap (move-guts filemap sources destination))
55
56 (chatter-info "Synchronizing.~%")
57 (mapping-synchronize)
58 (with-open-file (file *mcvs-map* :direction :output)
59 (let ((*print-right-margin* 1))
60 (prin1 (filemap-sort filemap) file)
61 (terpri file)))
62 (chatter-info "Updating file structure.~%")
63 (mapping-update))
64 (values)))
65
66 (defun mcvs-move-wrapper (cvs-options cvs-specific-options mcvs-args)
67 (when (or cvs-options cvs-specific-options)
68 (error
69 #.(concatenate 'string
70 "mcvs-move: CVS options specified, "
71 "but this operation does not invoke CVS.")))
72 (apply #'mcvs-move mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5