Merge branch 'master' into core-updates

 Conflicts:
	gnu/packages/image.scm
        (incorporated libtiff graft)

3 files changed, 136 insertions, 1 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index ce4708a873..6ef6233346 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -296,6 +296,13 @@ session record port using PORT as its underlying communication port."
   (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
                       (getenv "SSL_CERT_DIR"))))  ;like OpenSSL
 
+(define (set-certificate-credentials-x509-trust-file!* cred file format)
+  "Like 'set-certificate-credentials-x509-trust-file!', but without the file
+name decoding bug described at
+<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
+  (let ((data (call-with-input-file file get-bytevector-all)))
+    (set-certificate-credentials-x509-trust-data! cred data format)))
+
 (define (make-credendials-with-ca-trust-files directory)
   "Return certificate credentials with X.509 authority certificates read from
 DIRECTORY.  Those authority certificates are checked when
@@ -309,7 +316,7 @@ DIRECTORY.  Those authority certificates are checked when
                 (let ((file (string-append directory "/" file)))
                   ;; Protect against dangling symlinks.
                   (when (file-exists? file)
-                    (set-certificate-credentials-x509-trust-file!
+                    (set-certificate-credentials-x509-trust-file!*
                      cred file
                      x509-certificate-format/pem))))
               (or files '()))
diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm
new file mode 100644
index 0000000000..f2a646f6f4
--- /dev/null
+++ b/guix/build/font-build-system.scm
@@ -0,0 +1,72 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2017 Alex Griffin <a@ajgrf.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build font-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (%standard-phases
+            font-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the build procedure for font packages.
+;;
+;; Code:
+
+(define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack))
+
+(define* (unpack #:key source #:allow-other-keys)
+  "Unpack SOURCE into the build directory.  SOURCE may be a compressed
+archive, or a font file."
+  (if (any (cut string-suffix? <> source)
+           (list ".ttf" ".otf"))
+      (begin
+        (mkdir "source")
+        (chdir "source")
+        (copy-file source (strip-store-file-name source))
+        #t)
+      (gnu:unpack #:source source)))
+
+(define* (install #:key outputs #:allow-other-keys)
+  "Install the package contents."
+  (let* ((out (assoc-ref outputs "out"))
+         (source (getcwd))
+         (fonts (string-append out "/share/fonts")))
+    (for-each (cut install-file <> (string-append fonts "/truetype"))
+              (find-files source "\\.(ttf|ttc)$"))
+    (for-each (cut install-file <> (string-append fonts "/opentype"))
+              (find-files source "\\.(otf|otc)$"))
+    #t))
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (replace 'unpack unpack)
+    (delete 'configure)
+    (delete 'check)
+    (delete 'build)
+    (replace 'install install)))
+
+(define* (font-build #:key inputs (phases %standard-phases)
+                      #:allow-other-keys #:rest args)
+  "Build the given font package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; font-build-system.scm ends here
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 0529c228a5..2def2a108f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -62,6 +62,7 @@
             file-system-fragment-size
             file-system-mount-flags
             statfs
+            free-disk-space
 
             processes
             mkdtemp!
@@ -69,6 +70,9 @@
             pivot-root
             fcntl-flock
 
+            set-thread-name
+            thread-name
+
             CLONE_CHILD_CLEARTID
             CLONE_CHILD_SETTID
             CLONE_NEWNS
@@ -694,6 +698,12 @@ mounted at FILE."
                    (list file (strerror err))
                    (list err)))))))
 
+(define (free-disk-space file)
+  "Return the free disk space, in bytes, on the file system that hosts FILE."
+  (let ((fs (statfs file)))
+    (* (file-system-block-size fs)
+       (file-system-blocks-available fs))))
+
 
 ;;;
 ;;; Containers.
@@ -884,6 +894,52 @@ exception if it's already taken."
 
 
 ;;;
+;;; Miscellaneous, aka. 'prctl'.
+;;;
+
+(define %prctl
+  ;; Should it win the API contest against 'ioctl'?  You tell us!
+  (syscall->procedure int "prctl"
+                      (list int unsigned-long unsigned-long
+                            unsigned-long unsigned-long)))
+
+(define PR_SET_NAME 15)                           ;<linux/prctl.h>
+(define PR_GET_NAME 16)
+
+(define %max-thread-name-length
+  ;; Maximum length in bytes of the process name, including the terminating
+  ;; zero.
+  16)
+
+(define (set-thread-name name)
+  "Set the name of the calling thread to NAME.  NAME is truncated to 15
+bytes."
+  (let ((ptr (string->pointer name)))
+    (let-values (((ret err)
+                  (%prctl PR_SET_NAME
+                          (pointer-address ptr) 0 0 0)))
+      (unless (zero? ret)
+        (throw 'set-process-name "set-process-name"
+               "set-process-name: ~A"
+               (list (strerror err))
+               (list err))))))
+
+(define (thread-name)
+  "Return the name of the calling thread as a string."
+  (let ((buf (make-bytevector %max-thread-name-length)))
+    (let-values (((ret err)
+                  (%prctl PR_GET_NAME
+                          (pointer-address (bytevector->pointer buf))
+                          0 0 0)))
+      (if (zero? ret)
+          (bytes->string (bytevector->u8-list buf))
+          (throw 'process-name "process-name"
+                 "process-name: ~A"
+                 (list (strerror err))
+                 (list err))))))
+
+
+;;;
 ;;; Network interfaces.
 ;;;