summaryrefslogtreecommitdiff
path: root/guix/build/gnu-build-system.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-12-01 15:46:26 +0100
committerLudovic Courtès <ludo@gnu.org>2014-12-01 16:50:28 +0100
commit7cc7dec139d4dbbeb93d7fe57740ae5f64200701 (patch)
tree8d6aff41823f6e7c728628bbaf9811fba642a829 /guix/build/gnu-build-system.scm
parent9741aca9a586231423712b99d52346bf3dcdd4e3 (diff)
build-system/gnu: Add 'compress-documentation' phase.
* guix/build/gnu-build-system.scm (compress-documentation): New procedure. (%standard-phases): Add it.
Diffstat (limited to 'guix/build/gnu-build-system.scm')
-rw-r--r--guix/build/gnu-build-system.scm62
1 files changed, 61 insertions, 1 deletions
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 9d97ceb5bb..d3de92b724 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -20,6 +20,7 @@
#:use-module (guix build utils)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -393,6 +394,64 @@ and 'man/'. This phase moves directories to the right place if needed."
(for-each validate-output directories)))
#t)
+(define* (compress-documentation #:key outputs
+ (compress-documentation? #t)
+ (documentation-compressor "gzip")
+ (documentation-compressor-flags
+ '("--best" "--no-name"))
+ (compressed-documentation-extension ".gz")
+ #:allow-other-keys)
+ "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files
+found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with
+DOCUMENTATION-COMPRESSOR-FLAGS."
+ (define (retarget-symlink link)
+ (let ((target (readlink link)))
+ (delete-file link)
+ (symlink (string-append target compressed-documentation-extension)
+ link)))
+
+ (define (has-links? file)
+ ;; Return #t if FILE has hard links.
+ (> (stat:nlink (lstat file)) 1))
+
+ (define (maybe-compress-directory directory regexp)
+ (or (not (directory-exists? directory))
+ (match (find-files directory regexp)
+ (() ;nothing to compress
+ #t)
+ ((files ...) ;one or more files
+ (format #t
+ "compressing documentation in '~a' with ~s and flags ~s~%"
+ directory documentation-compressor
+ documentation-compressor-flags)
+ (call-with-values
+ (lambda ()
+ (partition symbolic-link? files))
+ (lambda (symlinks regular-files)
+ ;; Compress the non-symlink files, and adjust symlinks to refer
+ ;; to the compressed files. Leave files that have hard links
+ ;; unchanged ('gzip' would refuse to compress them anyway.)
+ (and (zero? (apply system* documentation-compressor
+ (append documentation-compressor-flags
+ (remove has-links? regular-files))))
+ (every retarget-symlink
+ (filter (cut string-match regexp <>)
+ symlinks)))))))))
+
+ (define (maybe-compress output)
+ (and (maybe-compress-directory (string-append output "/share/man")
+ "\\.[0-9]+$")
+ (maybe-compress-directory (string-append output "/share/info")
+ "\\.info(-[0-9]+)?$")))
+
+ (if compress-documentation?
+ (match outputs
+ (((names . directories) ...)
+ (every maybe-compress directories)))
+ (begin
+ (format #t "not compressing documentation~%")
+ #t)))
+
(define %standard-phases
;; Standard build phases, as a list of symbol/procedure pairs.
(let-syntax ((phases (syntax-rules ()
@@ -402,7 +461,8 @@ and 'man/'. This phase moves directories to the right place if needed."
patch-source-shebangs configure patch-generated-file-shebangs
build check install
patch-shebangs strip
- validate-documentation-location)))
+ validate-documentation-location
+ compress-documentation)))
(define* (gnu-build #:key (source #f) (outputs #f) (inputs #f)