/[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.1 - (hide annotations)
Mon Jul 1 20:47:31 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
Adding purge command.

* mcvs-main.lisp (*purge-options*): New constant.
(*mcvs-command-table*): New entry.
(*usage*): Update.

* purge.lisp: New file.
(mcvs-purge, mcvs-purge-wrapper): New functions.
1 kaz 1.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     (remaining-options (dry-run-only "n"))
13     purge-options
14     (declare (ignore remaining-options))
15     (in-sandbox-root-dir
16     (let ((filemap (mapping-read *mcvs-map* :sanity-check t))
17     (to-be-removed ())
18     (f-hash (make-hash-table :test #'equal)))
19     (dolist (entry filemap)
20     (setf (gethash (first entry) f-hash) entry))
21     (for-each-file-info (fi *mcvs-dir*)
22     (let ((base (basename (file-name fi))))
23     (multiple-value-bind (suffix name) (suffix base)
24     (declare (ignore suffix))
25     (when (and (= (length name) 34)
26     (string= (subseq name 0 2) "F-")
27     (not (gethash (file-name fi) f-hash)))
28     (push base to-be-removed)))))
29     (when to-be-removed
30     (cond
31     (dry-run-only
32     (dolist (tbr to-be-removed)
33     (chatter-info "* purging ~a~%" tbr)))
34     (t (chdir *mcvs-dir*)
35     (chatter-debug "Invoking CVS.~%")
36     (unless (execute-program-xargs `("cvs" ,@(format-opt global-options)
37     "rm" "-f")
38     to-be-removed)
39     (error "CVS rm failed."))))))))
40     (values))
41    
42     (defun mcvs-purge-wrapper (global-options command-options args)
43     (when args
44     (error "mcvs-purge: no arguments permitted."))
45     (mcvs-purge global-options command-options))

  ViewVC Help
Powered by ViewVC 1.1.5