Commit | Line | Data |
---|---|---|
89328d24 MW |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> | |
ab83105b | 3 | ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> |
89328d24 MW |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix build cvs) | |
21 | #:use-module (guix build utils) | |
22 | #:use-module (ice-9 regex) | |
23 | #:use-module (ice-9 ftw) | |
24 | #:export (cvs-fetch)) | |
25 | ||
26 | ;;; Commentary: | |
27 | ;;; | |
28 | ;;; This is the build-side support code of (guix cvs-download). It allows a | |
29 | ;;; CVS repository to be checked out at a specific revision or date. | |
30 | ;;; | |
31 | ;;; Code: | |
32 | ||
33 | (define (find-cvs-directories) | |
34 | (define (enter? path st result) | |
35 | (not (string-suffix? "/CVS" path))) | |
36 | (define (leaf path st result) result) | |
37 | (define (down path st result) result) | |
38 | (define (up path st result) result) | |
39 | (define (skip path st result) | |
40 | (if (and (string-suffix? "/CVS" path) | |
41 | (eqv? 'directory (stat:type st))) | |
42 | (cons path result) | |
43 | result)) | |
44 | (define (error path st errno result) | |
45 | (format (current-error-port) "cvs-fetch: ~a: ~a~%" | |
46 | path (strerror errno))) | |
47 | (sort (file-system-fold enter? leaf down up skip error '() "." lstat) | |
48 | string<?)) | |
49 | ||
50 | (define* (cvs-fetch cvs-root-directory module revision directory | |
51 | #:key (cvs-command "cvs")) | |
52 | "Fetch REVISION from MODULE of CVS-ROOT-DIRECTORY into DIRECTORY. REVISION | |
53 | must either be a date in ISO-8601 format (e.g. \"2012-12-21\") or a CVS tag. | |
54 | Return #t on success, #f otherwise." | |
f4033fb5 LC |
55 | ;; Use "-z0" because enabling compression leads to hangs during checkout on |
56 | ;; certain repositories, such as | |
57 | ;; ":pserver:anonymous@cvs.savannah.gnu.org:/sources/gnustandards". | |
54fcecdb MW |
58 | (invoke cvs-command "-z0" |
59 | "-d" cvs-root-directory | |
60 | "checkout" | |
61 | (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision) | |
62 | "-D" "-r") | |
63 | revision | |
64 | module) | |
ab83105b | 65 | |
54fcecdb MW |
66 | ;; Copy rather than rename in case MODULE and DIRECTORY are on |
67 | ;; different devices. | |
68 | (copy-recursively module directory) | |
69 | ||
70 | (with-directory-excursion directory | |
71 | (for-each delete-file-recursively (find-cvs-directories))) | |
72 | #t) | |
89328d24 MW |
73 | |
74 | ;;; cvs.scm ends here |