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

Contents of /meta-cvs/F-AFC09F145399B1273F4BF98702F5BE8C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.41 - (show annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.40: +5 -5 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5