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

Contents of /meta-cvs/F-AFC09F145399B1273F4BF98702F5BE8C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Sat Aug 31 20:53:13 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-22, mcvs-0-23, mcvs-0-95, mcvs-0-96
Changes since 1.26: +4 -1 lines
Merging symlink-branch to main trunk.
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-after default-include-meta-files
14 need-update-after no-fix-empty-file-list)
15 (in-sandbox-root-dir
16 (let (files-to-process
17 (filemap (mapping-read *mcvs-map-local*))
18 (do-meta-files (and (or *metaonly-option* *meta-option*
19 default-include-meta-files)
20 (not (and (null files)
21 no-fix-empty-file-list
22 (not *metaonly-option*)))
23 (not *nometa-option*))))
24
25 (unless (or *metaonly-option*)
26 (chatter-debug "Preparing file list.~%")
27
28 (if (null files)
29 (unless no-fix-empty-file-list
30 (setf files-to-process
31 (mapping-prefix-matches filemap
32 (sandbox-translate-path "."))))
33 (dolist (file files)
34 (can-restart-here ("Continue preparing file list.")
35 (let* ((full-name (sandbox-translate-path file))
36 (abs-name (real-to-abstract-path full-name))
37 (entries (mapping-prefix-matches filemap abs-name)))
38 (if (not entries)
39 (error "mcvs: ~a is not known to Meta-CVS." full-name)
40 (setf files-to-process (nconc files-to-process entries))))))))
41
42 (setf files-to-process (mapping-extract-kind files-to-process :file))
43
44 (when (or files-to-process
45 do-meta-files
46 no-fix-empty-file-list)
47 (chatter-debug "Synchronizing.~%")
48 (mapping-synchronize)
49
50 (current-dir-restore
51 (chdir *mcvs-dir*)
52 (chatter-debug "Invoking CVS.~%")
53 (execute-program-xargs `("cvs" ,@(format-opt cvs-options)
54 ,cvs-command ,@(format-opt command-options)
55 ,@command-args)
56 `(,@(when do-meta-files
57 (let (metas)
58 (when (exists ".cvsignore")
59 (push ".cvsignore" metas))
60 (when (exists *mcvs-types-name*)
61 (push *mcvs-types-name* metas))
62 (cons *mcvs-map-name* metas)))
63 ,@(mapcar #'(lambda (x)
64 (basename
65 (mapping-entry-id x)))
66 files-to-process))))
67 (when (and do-meta-files need-update-after)
68 (chatter-debug "Updating file structure.~%")
69 (mapping-update))
70 (when need-sync-after
71 (chatter-debug "Synchronizing again.~%")
72 (mapping-synchronize))))
73 (values)))
74
75 (defun mcvs-commit-wrapper (cvs-options cvs-command-options mcvs-args)
76 (mcvs-generic "commit" cvs-options cvs-command-options nil mcvs-args
77 :default-include-meta-files t
78 :no-fix-empty-file-list t))
79
80 (defun mcvs-diff-wrapper (cvs-options cvs-command-options mcvs-args)
81 (mcvs-generic "diff" cvs-options cvs-command-options nil mcvs-args))
82
83 (defun mcvs-tag-wrapper (cvs-options cvs-command-options mcvs-args)
84 (if (null mcvs-args)
85 (error "mcvs-tag: specify tag optionally followed by files."))
86 (mcvs-generic "tag" cvs-options
87 cvs-command-options (list (first mcvs-args)) (rest mcvs-args)
88 :default-include-meta-files t))
89
90 (defun mcvs-log-wrapper (cvs-options cvs-command-options mcvs-args)
91 (mcvs-generic "log" cvs-options cvs-command-options nil mcvs-args))
92
93 (defun mcvs-status-wrapper (cvs-options cvs-command-options mcvs-args)
94 (mcvs-generic "status" cvs-options cvs-command-options nil mcvs-args))
95
96 (defun mcvs-annotate-wrapper (cvs-options cvs-command-options mcvs-args)
97 (mcvs-generic "annotate" cvs-options cvs-command-options nil mcvs-args))

  ViewVC Help
Powered by ViewVC 1.1.5