diff options
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/syscalls.scm | 123 | ||||
-rw-r--r-- | guix/build/texlive-build-system.scm | 89 |
2 files changed, 212 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 2def2a108f..9c082b4352 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -68,6 +69,7 @@ mkdtemp! fdatasync pivot-root + scandir* fcntl-flock set-thread-name @@ -819,6 +821,127 @@ system to PUT-OLD." ;;; +;;; Opendir & co. +;;; + +(define-c-struct %struct-dirent-header + sizeof-dirent-header + (lambda (inode offset length type name) + ;; Convert TYPE to symbols like 'stat:type' does. + (let ((type (cond ((= type DT_REG) 'regular) + ((= type DT_LNK) 'symlink) + ((= type DT_DIR) 'directory) + ((= type DT_FIFO) 'fifo) + ((= type DT_CHR) 'char-special) + ((= type DT_BLK) 'block-special) + ((= type DT_SOCK) 'socket) + (else 'unknown)))) + `((type . ,type) + (inode . ,inode)))) + read-dirent-header + write-dirent-header! + (inode int64) + (offset int64) + (length unsigned-short) + (type uint8) + (name uint8)) ;first byte of 'd_name' + +;; Constants for the 'type' field, from <dirent.h>. +(define DT_UNKNOWN 0) +(define DT_FIFO 1) +(define DT_CHR 2) +(define DT_DIR 4) +(define DT_BLK 6) +(define DT_REG 8) +(define DT_LNK 10) +(define DT_SOCK 12) +(define DT_WHT 14) + +(define string->pointer/utf-8 + (cut string->pointer <> "UTF-8")) + +(define pointer->string/utf-8 + (cut pointer->string <> <> "UTF-8")) + +(define opendir* + (let ((proc (syscall->procedure '* "opendir" '(*)))) + (lambda* (name #:optional (string->pointer string->pointer/utf-8)) + (let-values (((ptr err) + (proc (string->pointer name)))) + (if (null-pointer? ptr) + (throw 'system-error "opendir*" + "~A: ~A" (list name (strerror err)) + (list err)) + ptr))))) + +(define closedir* + (let ((proc (syscall->procedure int "closedir" '(*)))) + (lambda (directory) + (let-values (((ret err) + (proc directory))) + (unless (zero? ret) + (throw 'system-error "closedir" + "closedir: ~A" (list (strerror err)) + (list err))))))) + +(define readdir* + (let ((proc (syscall->procedure '* "readdir64" '(*)))) + (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) + (let ((ptr (proc directory))) + (and (not (null-pointer? ptr)) + (cons (pointer->string + (make-pointer (+ (pointer-address ptr) + (c-struct-field-offset + %struct-dirent-header name))) + -1) + (read-dirent-header + (pointer->bytevector ptr sizeof-dirent-header)))))))) + +(define* (scandir* name #:optional + (select? (const #t)) + (entry<? (lambda (entry1 entry2) + (match entry1 + ((name1 . _) + (match entry2 + ((name2 . _) + (string<? name1 name2))))))) + #:key + (string->pointer string->pointer/utf-8) + (pointer->string pointer->string/utf-8)) + "This procedure improves on Guile's 'scandir' procedure in several ways: + + 1. Systematically encode decode file names using STRING->POINTER and + POINTER->STRING (UTF-8 by default; this works around a defect in Guile 2.0/2.2 + where 'scandir' decodes file names according to the current locale, which is + not always desirable. + + 2. Each entry that is returned has the form (NAME . PROPERTIES). + PROPERTIES is an alist showing additional properties about the entry, as + found in 'struct dirent'. An entry may look like this: + + (\"foo.scm\" (type . regular) (inode . 123456)) + + Callers must be prepared to deal with the case where 'type' is 'unknown' + since some file systems do not provide that information. + + 3. Raise to 'system-error' when NAME cannot be opened." + (let ((directory (opendir* name string->pointer))) + (dynamic-wind + (const #t) + (lambda () + (let loop ((result '())) + (match (readdir* directory pointer->string) + (#f + (sort result entry<?)) + (entry + (loop (if (select? entry) + (cons entry result) + result)))))) + (lambda () + (closedir* directory))))) + + +;;; ;;; Advisory file locking. ;;; diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm new file mode 100644 index 0000000000..c1fd9fd9af --- /dev/null +++ b/guix/build/texlive-build-system.scm @@ -0,0 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 texlive-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + texlive-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for TeX Live packages. +;; +;; Code: + +(define (compile-with-latex format file) + (zero? (system* format + "-interaction=batchmode" + "-output-directory=build" + (string-append "&" format) + file))) + +(define* (build #:key inputs build-targets tex-format #:allow-other-keys) + ;; Find additional tex and sty files + (setenv "TEXINPUTS" + (string-append + (getcwd) ":" (getcwd) "/build:" + (string-join + (append-map (match-lambda + ((_ . dir) + (find-files dir + (lambda (_ stat) + (eq? 'directory (stat:type stat))) + #:directories? #t + #:stat stat))) + inputs) + ":"))) + (setenv "TEXFORMATS" + (string-append (assoc-ref inputs "texlive-latex-base") + "/share/texmf-dist/web2c/")) + (setenv "LUAINPUTS" + (string-append (assoc-ref inputs "texlive-latex-base") + "/share/texmf-dist/tex/latex/base/")) + (mkdir "build") + (every (cut compile-with-latex tex-format <>) + (if build-targets build-targets + (find-files "." "\\.ins$")))) + +(define* (install #:key outputs tex-directory #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (target (string-append + out "/share/texmf-dist/tex/" tex-directory))) + (mkdir-p target) + (for-each delete-file (find-files "." "\\.(log|aux)$")) + (for-each (cut install-file <> target) + (find-files "build" ".*")) + #t)) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (replace 'build build) + (delete 'check) + (replace 'install install))) + +(define* (texlive-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given TeX Live package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; texlive-build-system.scm ends here |