/[meta-cvs]/meta-cvs/F-0BAB20DD5AC6CA222E7E6E3055487AB2.lisp
ViewVC logotype

Contents of /meta-cvs/F-0BAB20DD5AC6CA222E7E6E3055487AB2.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Oct 5 18:09:48 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-98, mcvs-1-0-branch~branch-point, mcvs-0-97
Branch point for: mcvs-1-0-branch
Changes since 1.3: +1 -1 lines
Error messages no longer specify prefixes like "mcvs:" or
"mcvs-remove:".

When no restarts are available, the error handler now adds the "mcvs:"
prefix when dumping the error text to the standard error stream,
and also adds a terminating newline.

The inability to write to the MAP file is converted to a more
informative error message.

New --debug option is supported to set the chatter level to 3.
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 "dirwalk")
7 (require "mapping")
8 (require "find-bind")
9
10 (defun mcvs-purge (global-options purge-options)
11 (find-bind (:key #'first :test #'string= :take #'second)
12 ((dry-run-only "n"))
13 purge-options
14 (in-sandbox-root-dir
15 (let* ((filemap (mapping-read *mcvs-map* :sanity-check t))
16 (to-be-removed (mapping-removed-files filemap)))
17 (when to-be-removed
18 (cond
19 (dry-run-only
20 (dolist (tbr to-be-removed)
21 (chatter-info "* purging ~a~%" tbr)))
22 (t (chdir *mcvs-dir*)
23 (chatter-debug "Invoking CVS.~%")
24 (unless (execute-program-xargs `("cvs" ,@(format-opt global-options)
25 "rm" "-f")
26 (mapcar #'basename to-be-removed))
27 (error "CVS rm failed."))))))))
28 (values))
29
30 (defun mcvs-purge-wrapper (global-options command-options args)
31 (when args
32 (error "no arguments permitted."))
33 (mcvs-purge global-options command-options))

  ViewVC Help
Powered by ViewVC 1.1.5