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

Contents of /meta-cvs/F-A7A64FB1054A27E5F51A7E95C6A80309

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide annotations)
Tue Jul 2 13:19:50 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: partial-sandbox-branch~branch-point, mcvs-0-17
Branch point for: partial-sandbox-branch
Changes since 1.21: +4 -2 lines
* checkout.lisp (mcvs-checkout): Don't delete the MCVS directory
of an existing checkout.
1 kaz 1.7 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.5 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "dirwalk")
6     (require "chatter")
7     (require "sync")
8 kaz 1.6 (require "options")
9 kaz 1.13 (require "find-bind")
10 kaz 1.1 (provide "checkout")
11    
12 kaz 1.20 (defun mcvs-checkout (module &optional cvs-options checkout-options
13     &key no-generate)
14 kaz 1.1 ;; checkout module from cvs
15 kaz 1.13 (find-bind (:key #'first :test #'string= :take #'second)
16 kaz 1.17 (cvs-checkout-options (dir "d" module))
17 kaz 1.13 checkout-options
18 kaz 1.19 (let ((checkout-dir (canonicalize-path dir))
19 kaz 1.22 path checkout-okay created-dir created-mcvs-dir)
20 kaz 1.19 (multiple-value-setq (path created-dir)
21     (ensure-directories-exist (path-cat checkout-dir *mcvs-dir*)))
22     (unwind-protect
23     (current-dir-restore
24     (chdir checkout-dir)
25 kaz 1.13
26 kaz 1.19 (when (ignore-errors (stat *mcvs-dir*))
27     (error "mcvs-checkout: directory ~a seems to be the root of an existing sandbox."
28     checkout-dir))
29 kaz 1.18
30 kaz 1.19 (chatter-debug "Invoking CVS.~%")
31 kaz 1.20 (unless
32     (execute-program `("cvs" ,@(format-opt cvs-options)
33     "checkout" "-d" ,*mcvs-dir*
34     ,@(format-opt cvs-checkout-options) ,module))
35     (error "CVS checkout failed."))
36 kaz 1.18
37 kaz 1.20 (unless (ignore-errors (stat *mcvs-dir*))
38 kaz 1.19 (error "mcvs-checkout: checkout failed to create ~a directory."
39     *mcvs-dir*))
40 kaz 1.13
41 kaz 1.22 (setf created-mcvs-dir t)
42 kaz 1.21 (mapping-write nil *mcvs-map-local*)
43 kaz 1.20 (unless no-generate
44     (chatter-debug "Generating file structure.~%")
45     (mapping-update))
46     (chatter-info "Checkout to directory ~a completed.~%" checkout-dir)
47 kaz 1.19 (setf checkout-okay t))
48 kaz 1.20 (unless checkout-okay
49 kaz 1.22 (when created-mcvs-dir
50     (delete-recursive (path-cat checkout-dir *mcvs-dir*)))
51 kaz 1.20 (when created-dir
52     (delete-recursive checkout-dir))))
53 kaz 1.17 (values))))
54 kaz 1.2
55 kaz 1.6 (defun mcvs-checkout-wrapper (cvs-options cvs-command-options mcvs-args)
56 kaz 1.12 (if (< (length mcvs-args) 1)
57     (error "mcvs-checkout: specify module."))
58 kaz 1.2 (destructuring-bind (module &rest superfluous) mcvs-args
59     (when superfluous
60     (error "mcvs-checkout: specify one module to check out."))
61 kaz 1.6 (mcvs-checkout module cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5