From e815763e69c621412830cada8ded53ccd1b8247f Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 31 Aug 2012 17:04:53 +0200
Subject: build-system/gnu: Add a `strip' phase.

* guix/build/gnu-build-system.scm (strip): New procedure.
  (%standard-phases): Add it.

* guix/build-system/gnu.scm (gnu-build): New `strip-binaries?',
  `strip-flags', and `strip-directories' keyword parameters.  Pass them
  to BUILDER.
---
 guix/build-system/gnu.scm       |  9 ++++++++-
 guix/build/gnu-build-system.scm | 32 +++++++++++++++++++++++++++++++-
 2 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index fd9a6d026e..7bdd4174bd 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -50,6 +50,10 @@
                     (tests? #t)
                     (parallel-build? #t) (parallel-tests? #t)
                     (patch-shebangs? #t)
+                    (strip-binaries? #t)
+                    (strip-flags ''("--strip-debug"))
+                    (strip-directories ''("lib" "lib64" "libexec"
+                                          "bin" "sbin"))
                     (phases '%standard-phases)
                     (system (%current-system))
                     (modules '((guix build gnu-build-system)
@@ -73,7 +77,10 @@ input derivation INPUTS, using the usual procedure of the GNU Build System."
                   #:tests? ,tests?
                   #:parallel-build? ,parallel-build?
                   #:parallel-tests? ,parallel-tests?
-                  #:patch-shebangs? ,patch-shebangs?)))
+                  #:patch-shebangs? ,patch-shebangs?
+                  #:strip-binaries? ,strip-binaries?
+                  #:strip-flags ,strip-flags
+                  #:strip-directories ,strip-directories)))
 
   (build-expression->derivation store name system
                                 builder
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index a1a0f03467..4a83bd0637 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -160,12 +160,42 @@
              bindirs)
    #t))
 
+(define* (strip #:key outputs (strip-binaries? #t)
+                (strip-flags '("--strip-debug"))
+                (strip-directories '("lib" "lib64" "libexec"
+                                     "bin" "sbin"))
+                #:allow-other-keys)
+  (define (strip-dir dir)
+    (file-system-fold (const #t)
+                      (lambda (path stat result)  ; leaf
+                        (zero? (apply system* "strip"
+                                      (append strip-flags (list path)))))
+                      (const #t)                  ; down
+                      (const #t)                  ; up
+                      (const #t)                  ; skip
+                      (lambda (path stat errno result)
+                        (format (current-error-port)
+                                "strip: failed to access `~a': ~a~%"
+                                path (strerror errno))
+                        #f)
+                      #t
+                      dir))
+
+  (every strip-dir
+         (append-map (match-lambda
+                      ((_ . dir)
+                       (filter-map (lambda (d)
+                                     (let ((sub (string-append dir "/" d)))
+                                       (and (directory-exists? sub) sub)))
+                                   strip-directories)))
+                     outputs)))
+
 (define %standard-phases
   ;; Standard build phases, as a list of symbol/procedure pairs.
   (let-syntax ((phases (syntax-rules ()
                          ((_ p ...) `((p . ,p) ...)))))
     (phases set-paths unpack patch configure build check install
-            patch-shebangs)))
+            patch-shebangs strip)))
 
 
 (define* (gnu-build #:key (source #f) (outputs #f) (inputs #f)
-- 
cgit 1.4.1