/[meta-cvs]/meta-cvs/F-AFC09F145399B1273F4BF98702F5BE8C
ViewVC logotype

Contents of /meta-cvs/F-AFC09F145399B1273F4BF98702F5BE8C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29.2.5 - (show annotations)
Thu Apr 24 04:32:25 2003 UTC (11 years ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-7
Changes since 1.29.2.4: +29 -18 lines
New commands, sync-from-cvs and sync-to-cvs.

* code/mcvs-main.lisp (*sync-to-cvs-options*, *sync-from-cvs-options*):
New option constants.
(*mcvs-command-table*): New entries.
(*usage*): New help text.

* code/generic.lisp (mcvs-generic): New keyword parameter
no-invoke-cvs.
(mcvs-sync-to-wrapper, mcvs-sync-from-wrapper): New functions.
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 "types")
8 (require "chatter")
9 (require "options")
10 (provide "generic")
11
12 (defun mcvs-generic (cvs-command cvs-options command-options command-args
13 files &key need-sync-before need-sync-after
14 default-include-meta-files need-update-after
15 global-if-empty-file-list no-invoke-cvs)
16 (in-sandbox-root-dir
17 (let (files-to-process
18 (filemap (mapping-read *mcvs-map-local*))
19 (do-meta-files (and (or *metaonly-option* *meta-option*
20 default-include-meta-files)
21 (not (and (null files)
22 global-if-empty-file-list
23 (not *metaonly-option*)))
24 (not *nometa-option*))))
25
26 (unless (or *metaonly-option*)
27 (chatter-debug "Preparing file list.~%")
28
29 (if (null files)
30 (unless global-if-empty-file-list
31 (setf files-to-process
32 (mapping-prefix-matches filemap
33 (sandbox-translate-path "."))))
34 (dolist (file files)
35 (can-restart-here ("Continue preparing file list.")
36 (let* ((full-name (sandbox-translate-path file))
37 (abs-name (canonicalize-path
38 (real-to-abstract-path full-name)))
39 (entries (mapping-prefix-matches filemap abs-name)))
40 (if (not entries)
41 (error "~a is not known to Meta-CVS." full-name)
42 (setf files-to-process (nconc files-to-process entries))))))))
43
44 (setf files-to-process (mapping-extract-kind files-to-process :file))
45
46 (when (or files-to-process
47 do-meta-files
48 global-if-empty-file-list)
49 (when need-sync-before
50 (chatter-debug "Synchronizing.~%")
51 (mapping-synchronize :filemap files-to-process
52 :direction :left))
53 (unless no-invoke-cvs
54 (current-dir-restore
55 (chdir *mcvs-dir*)
56 (chatter-debug "Invoking CVS.~%")
57 (execute-program-xargs `("cvs" ,@(format-opt cvs-options)
58 ,cvs-command ,@(format-opt command-options)
59 ,@command-args)
60 `(,@(when do-meta-files
61 (let (metas)
62 (when (exists ".cvsignore")
63 (push ".cvsignore" metas))
64 (when (exists *mcvs-types-name*)
65 (push *mcvs-types-name* metas))
66 (cons *mcvs-map-name* metas)))
67 ,@(mapcar #'(lambda (x)
68 (basename
69 (mapping-entry-id x)))
70 files-to-process)))))
71 (when (and do-meta-files need-update-after)
72 (chatter-debug "Updating file structure.~%")
73 (mapping-update))
74 (when need-sync-after
75 (chatter-debug "Synchronizing again.~%")
76 (mapping-synchronize :filemap files-to-process))))
77 (values)))
78
79 (defun mcvs-commit-wrapper (cvs-options cvs-command-options mcvs-args)
80 (mcvs-generic "commit" cvs-options cvs-command-options nil mcvs-args
81 :need-sync-before t
82 :need-sync-after t
83 :default-include-meta-files t
84 :global-if-empty-file-list t))
85
86 (defun mcvs-diff-wrapper (cvs-options cvs-command-options mcvs-args)
87 (mcvs-generic "diff" cvs-options cvs-command-options nil mcvs-args
88 :need-sync-before t))
89
90 (defun mcvs-tag-wrapper (cvs-options cvs-command-options mcvs-args)
91 (if (null mcvs-args)
92 (error "specify tag optionally followed by files."))
93 (mcvs-generic "tag" cvs-options
94 cvs-command-options (list (first mcvs-args)) (rest mcvs-args)
95 :default-include-meta-files t
96 :global-if-empty-file-list t))
97
98 (defun mcvs-log-wrapper (cvs-options cvs-command-options mcvs-args)
99 (mcvs-generic "log" cvs-options cvs-command-options nil mcvs-args))
100
101 (defun mcvs-status-wrapper (cvs-options cvs-command-options mcvs-args)
102 (mcvs-generic "status" cvs-options cvs-command-options nil mcvs-args
103 :need-sync-before t))
104
105 (defun mcvs-annotate-wrapper (cvs-options cvs-command-options mcvs-args)
106 (mcvs-generic "annotate" cvs-options cvs-command-options nil mcvs-args))
107
108 (defun mcvs-watchers-wrapper (cvs-options cvs-command-options mcvs-args)
109 (mcvs-generic "watchers" cvs-options cvs-command-options nil mcvs-args))
110
111 (defun mcvs-edit-wrapper (cvs-options cvs-command-options mcvs-args)
112 (mcvs-generic "edit" cvs-options cvs-command-options nil mcvs-args
113 :need-sync-before t))
114
115 (defun mcvs-unedit-wrapper (cvs-options cvs-command-options mcvs-args)
116 (mcvs-generic "unedit" cvs-options cvs-command-options nil mcvs-args
117 :need-sync-before t
118 :need-sync-after t))
119
120 (defun mcvs-editors-wrapper (cvs-options cvs-command-options mcvs-args)
121 (mcvs-generic "editors" cvs-options cvs-command-options nil mcvs-args))
122
123 (defun mcvs-sync-to-wrapper (cvs-options cvs-command-options mcvs-args)
124 (mcvs-generic "" cvs-options cvs-command-options nil mcvs-args
125 :need-sync-before t
126 :no-invoke-cvs t))
127
128 (defun mcvs-sync-from-wrapper (cvs-options cvs-command-options mcvs-args)
129 (mcvs-generic "" cvs-options cvs-command-options nil mcvs-args
130 :need-sync-after t
131 :no-invoke-cvs t))

  ViewVC Help
Powered by ViewVC 1.1.5