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

Contents of /meta-cvs/F-A7A64FB1054A27E5F51A7E95C6A80309

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Sat Jul 6 17:15:02 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-20, symlink-branch~branch-point, mcvs-0-22, mcvs-0-23, mcvs-0-21, mcvs-0-19, mcvs-0-18, symlink-branch~merged-to-HEAD-0
Branch point for: symlink-branch
Changes since 1.22: +13 -8 lines
Merging from partial-sandbox-branch.
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 "dirwalk")
6 (require "chatter")
7 (require "sync")
8 (require "options")
9 (require "find-bind")
10 (provide "checkout")
11
12 (defun mcvs-checkout (module &optional subdir cvs-options checkout-options
13 &key no-generate)
14 ;; checkout module from cvs
15 (find-bind (:key #'first :test #'string= :take #'second)
16 (cvs-checkout-options (dir "d" (or subdir module)))
17 checkout-options
18 (let ((checkout-dir (canonicalize-path dir))
19 path checkout-okay created-dir created-mcvs-dir)
20 (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
26 (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
30 (chatter-debug "Invoking CVS.~%")
31 (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
37 (unless (ignore-errors (stat *mcvs-dir*))
38 (error "mcvs-checkout: checkout failed to create ~a directory."
39 *mcvs-dir*))
40
41 (setf created-mcvs-dir t)
42 (mapping-write nil *mcvs-map-local*)
43 (if subdir
44 (displaced-path-write (concatenate 'string
45 (canonicalize-path subdir)
46 *path-sep*)))
47 (unless no-generate
48 (in-sandbox-root-dir
49 (chatter-debug "Generating file structure.~%")
50 (mapping-update)))
51 (chatter-info "Checkout to directory ~a completed.~%" checkout-dir)
52 (setf checkout-okay t))
53 (unless checkout-okay
54 (when created-mcvs-dir
55 (delete-recursive (path-cat checkout-dir *mcvs-dir*)))
56 (when created-dir
57 (delete-recursive checkout-dir))))
58 (values))))
59
60 (defun mcvs-checkout-wrapper (cvs-options cvs-command-options mcvs-args)
61 (if (< (length mcvs-args) 1)
62 (error "mcvs-checkout: specify module, and optional subdirectory."))
63 (destructuring-bind (module &optional subdir &rest superfluous) mcvs-args
64 (when superfluous
65 (error "mcvs-checkout: specify one module and optional subdirectory to check out."))
66 (mcvs-checkout module subdir cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5