guix/build/cvs.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   3 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   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."
  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".
  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)
  65
  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)
  73
  74 ;;; cvs.scm ends here