From 3d90fa982b489cea2ccd2c0b14d63d45923e294a Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Mon, 15 May 2017 20:08:57 +0530 Subject: build-system: Add 'font-build-system'. * Makefile.am (MODULES): Add 'guix/build-system/font.scm' and 'guix/build/font-build-system.scm'. * guix/build-system/font.scm: New file. * guix/build/font-build-system.scm: New file. * doc/guix.texi (Build Systems): Add 'font-build-system'. --- guix/build/font-build-system.scm | 71 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 guix/build/font-build-system.scm (limited to 'guix/build') diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm new file mode 100644 index 0000000000..cca1e93f0f --- /dev/null +++ b/guix/build/font-build-system.scm @@ -0,0 +1,71 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Arun Isaac +;;; +;;; 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 . + +(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$")) + (for-each (cut install-file <> (string-append fonts "/opentype")) + (find-files source "\\.otf$")) + #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 -- cgit v1.2.3 From aa401f9ba6410095370ce0c4e5a01c02203a2b9f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 May 2017 15:49:11 +0200 Subject: syscalls: Add 'thread-name' and 'set-thread-name'. * guix/build/syscalls.scm (PR_SET_NAME, PR_GET_NAME) (%max-thread-name-length): New variables. (%prctl, set-thread-name, thread-name): New procedures. * tests/syscalls.scm ("set-thread-name"): New test. --- guix/build/syscalls.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 8 ++++++++ 2 files changed, 57 insertions(+) (limited to 'guix/build') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0529c228a5..52439afd44 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -69,6 +69,9 @@ pivot-root fcntl-flock + set-thread-name + thread-name + CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID CLONE_NEWNS @@ -882,6 +885,52 @@ exception if it's already taken." ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) + +;;; +;;; 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) ; +(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. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 8db45b41b6..e20f0600bc 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -266,6 +266,14 @@ (close-port file) result))))))))) +(test-equal "set-thread-name" + "Syscall Test" + (let ((name (thread-name))) + (set-thread-name "Syscall Test") + (let ((new-name (thread-name))) + (set-thread-name name) + new-name))) + (test-assert "all-network-interface-names" (match (all-network-interface-names) (((? string? names) ..1) -- cgit v1.2.3 From 27fd13c3c2701204f48fe0012438edbb91957dfc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 30 May 2017 10:11:13 +0200 Subject: download: Work around GnuTLS bug with UTF-8 certificate file names. Reported by Mark H Weaver at . * guix/build/download.scm (set-certificate-credentials-x509-trust-file!*): New procedure. (make-credendials-with-ca-trust-files): Use it instead of 'set-certificate-credentials-x509-trust-file!'. --- guix/build/download.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix/build') 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 +." + (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 '())) -- cgit v1.2.3 From 046175cd4eae314f6e5d3d614efdeb573e8199df Mon Sep 17 00:00:00 2001 From: Alex Griffin Date: Wed, 31 May 2017 13:01:42 -0500 Subject: build: font: Support font collection files. * guix/build/font-build-system.scm (install): Support TrueType Collection (TTC) and OpenType Collection (OTC) files. Signed-off-by: Danny Milosavljevic --- guix/build/font-build-system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm index cca1e93f0f..f2a646f6f4 100644 --- a/guix/build/font-build-system.scm +++ b/guix/build/font-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Arun Isaac +;;; Copyright © 2017 Alex Griffin ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,9 +51,9 @@ archive, or a font file." (source (getcwd)) (fonts (string-append out "/share/fonts"))) (for-each (cut install-file <> (string-append fonts "/truetype")) - (find-files source "\\.ttf$")) + (find-files source "\\.(ttf|ttc)$")) (for-each (cut install-file <> (string-append fonts "/opentype")) - (find-files source "\\.otf$")) + (find-files source "\\.(otf|otc)$")) #t)) (define %standard-phases -- cgit v1.2.3 From 65f224dc8d9568232baa07f28474ba5c90f07428 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 15:23:51 +0200 Subject: syscalls: Provide 'free-disk-space'. * guix/build/syscalls.scm (free-disk-space): New procedure. * guix/scripts/gc.scm (guix-gc)[ensure-free-space]: Use it instead of 'statfs'. --- guix/build/syscalls.scm | 7 +++++++ guix/scripts/gc.scm | 8 +++----- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 52439afd44..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! @@ -697,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. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 221467a108..0a9719d259 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix store) - #:autoload (guix build syscalls) (statfs) + #:autoload (guix build syscalls) (free-disk-space) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -184,9 +184,7 @@ Invoke the garbage collector.\n")) (define (ensure-free-space store space) ;; Attempt to have at least SPACE bytes available in STORE. - (let* ((fs (statfs (%store-prefix))) - (free (* (file-system-block-size fs) - (file-system-blocks-available fs)))) + (let ((free (free-disk-space (%store-prefix)))) (if (> free space) (info (G_ "already ~h bytes available on ~a, nothing to do~%") free (%store-prefix)) -- cgit v1.2.3