Merge branch 'master' into core-updates
Ludovic Courtès
commit
e0556f7695
17
Makefile.am
17
Makefile.am
|
|
@ -250,18 +250,6 @@ nobase_dist_guilemodule_DATA = \
|
|||
nobase_nodist_guilemodule_DATA = guix/config.scm
|
||||
nobase_nodist_guileobject_DATA = $(GOBJECTS)
|
||||
|
||||
# Do we need to provide our own non-broken (srfi srfi-37) module?
|
||||
if INSTALL_SRFI_37
|
||||
|
||||
nobase_nodist_guilemodule_DATA += srfi/srfi-37.scm
|
||||
GOBJECTS += srfi/srfi-37.go
|
||||
|
||||
srfi/srfi-37.scm: srfi/srfi-37.scm.in
|
||||
$(MKDIR_P) srfi
|
||||
cp "$<" "$@"
|
||||
|
||||
endif INSTALL_SRFI_37
|
||||
|
||||
# Handy way to remove the .go files without removing all the rest.
|
||||
clean-go:
|
||||
-$(RM) -f $(GOBJECTS)
|
||||
|
|
@ -441,7 +429,6 @@ EXTRA_DIST = \
|
|||
build-aux/run-system-tests.scm \
|
||||
d3.v3.js \
|
||||
graph.js \
|
||||
srfi/srfi-37.scm.in \
|
||||
srfi/srfi-64.scm \
|
||||
srfi/srfi-64.upstream.scm \
|
||||
tests/test.drv \
|
||||
|
|
@ -598,9 +585,6 @@ GUIXSD_IMAGE_BASE = guixsd-usb-install-$(PACKAGE_VERSION)
|
|||
# Prefix of the GuixSD VM image file name.
|
||||
GUIXSD_VM_IMAGE_BASE = guixsd-vm-image-$(PACKAGE_VERSION)
|
||||
|
||||
# Size of the installation image (for x86_64 typically).
|
||||
GUIXSD_INSTALLATION_IMAGE_SIZE ?= 950MiB
|
||||
|
||||
# Size of the VM image (for x86_64 typically).
|
||||
GUIXSD_VM_IMAGE_SIZE ?= 2GiB
|
||||
|
||||
|
|
@ -648,7 +632,6 @@ release: dist
|
|||
image=`$(top_builddir)/pre-inst-env \
|
||||
guix system disk-image \
|
||||
--system=$$system \
|
||||
--image-size=$(GUIXSD_INSTALLATION_IMAGE_SIZE) \
|
||||
gnu/system/install.scm` ; \
|
||||
if [ ! -f "$$image" ] ; then \
|
||||
echo "failed to produced GuixSD installation image for $$system" >&2 ; \
|
||||
|
|
|
|||
|
|
@ -111,10 +111,6 @@ AM_CONDITIONAL([HAVE_GUILE_GIT], [test "x$have_guile_git" = "xyes"])
|
|||
dnl Make sure we have a full-fledged Guile.
|
||||
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
|
||||
|
||||
dnl Check whether (srfi srfi-37) works, and provide our own if it doesn't.
|
||||
GUIX_CHECK_SRFI_37
|
||||
AM_CONDITIONAL([INSTALL_SRFI_37], [test "x$ac_cv_guix_srfi_37_broken" = xyes])
|
||||
|
||||
dnl Decompressors, for use by the substituter and other modules.
|
||||
AC_PATH_PROG([GZIP], [gzip])
|
||||
AC_PATH_PROG([BZIP2], [bzip2])
|
||||
|
|
|
|||
|
|
@ -7877,9 +7877,8 @@ that.
|
|||
The installation image described above was built using the @command{guix
|
||||
system} command, specifically:
|
||||
|
||||
@c FIXME: 1G is too much; see <http://bugs.gnu.org/23077>.
|
||||
@example
|
||||
guix system disk-image --image-size=1G gnu/system/install.scm
|
||||
guix system disk-image gnu/system/install.scm
|
||||
@end example
|
||||
|
||||
Have a look at @file{gnu/system/install.scm} in the source tree,
|
||||
|
|
@ -16187,8 +16186,9 @@ size of the image.
|
|||
@item vm-image
|
||||
@itemx disk-image
|
||||
Return a virtual machine or disk image of the operating system declared
|
||||
in @var{file} that stands alone. Use the @option{--image-size} option
|
||||
to specify the size of the image.
|
||||
in @var{file} that stands alone. By default, @command{guix system}
|
||||
estimates the size of the image needed to store the system, but you can
|
||||
use the @option{--image-size} option to specify a value.
|
||||
|
||||
When using @code{vm-image}, the returned image is in qcow2 format, which
|
||||
the QEMU emulator can efficiently use. @xref{Running GuixSD in a VM},
|
||||
|
|
@ -16251,6 +16251,10 @@ of the given @var{size}. @var{size} may be a number of bytes, or it may
|
|||
include a unit as a suffix (@pxref{Block size, size specifications,,
|
||||
coreutils, GNU Coreutils}).
|
||||
|
||||
When this option is omitted, @command{guix system} computes an estimate
|
||||
of the image size as a function of the size of the system declared in
|
||||
@var{file}.
|
||||
|
||||
@item --root=@var{file}
|
||||
@itemx -r @var{file}
|
||||
Make @var{file} a symlink to the result, and register it as a garbage
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
|
||||
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
|
||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
|
|
@ -27,6 +27,7 @@
|
|||
#:use-module (gnu build linux-boot)
|
||||
#:use-module (gnu build install)
|
||||
#:use-module (guix records)
|
||||
#:use-module ((guix combinators) #:select (fold2))
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 regex)
|
||||
|
|
@ -46,6 +47,7 @@
|
|||
partition-flags
|
||||
partition-initializer
|
||||
|
||||
estimated-partition-size
|
||||
root-partition-initializer
|
||||
initialize-partition-table
|
||||
initialize-hard-disk))
|
||||
|
|
@ -71,19 +73,23 @@
|
|||
output
|
||||
(qemu (qemu-command)) (memory-size 512)
|
||||
linux initrd
|
||||
make-disk-image? (disk-image-size 100)
|
||||
make-disk-image?
|
||||
(disk-image-size (* 100 (expt 2 20)))
|
||||
(disk-image-format "qcow2")
|
||||
(references-graphs '()))
|
||||
"Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
|
||||
the result to OUTPUT.
|
||||
|
||||
When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
|
||||
DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
|
||||
it via /dev/hda.
|
||||
DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
|
||||
access it via /dev/hda.
|
||||
|
||||
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
|
||||
the #:references-graphs parameter of 'derivation'."
|
||||
(when make-disk-image?
|
||||
(format #t "creating ~a image of ~,2f MiB...~%"
|
||||
disk-image-format (/ disk-image-size (expt 2 20)))
|
||||
(force-output)
|
||||
(unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
|
||||
output
|
||||
(number->string disk-image-size)))
|
||||
|
|
@ -146,17 +152,11 @@ the #:references-graphs parameter of 'derivation'."
|
|||
(flags partition-flags (default '()))
|
||||
(initializer partition-initializer (default (const #t))))
|
||||
|
||||
(define (fold2 proc seed1 seed2 lst) ;TODO: factorize
|
||||
"Like `fold', but with a single list and two seeds."
|
||||
(let loop ((result1 seed1)
|
||||
(result2 seed2)
|
||||
(lst lst))
|
||||
(if (null? lst)
|
||||
(values result1 result2)
|
||||
(call-with-values
|
||||
(lambda () (proc (car lst) result1 result2))
|
||||
(lambda (result1 result2)
|
||||
(loop result1 result2 (cdr lst)))))))
|
||||
(define (estimated-partition-size graphs)
|
||||
"Return the estimated size of a partition that can store the store items
|
||||
given by GRAPHS, a list of file names produced by #:references-graphs."
|
||||
;; Simply add a 20% overhead.
|
||||
(round (* 1.2 (closure-size graphs))))
|
||||
|
||||
(define* (initialize-partition-table device partitions
|
||||
#:key
|
||||
|
|
@ -192,8 +192,15 @@ actual /dev name based on DEVICE."
|
|||
(cons (partition-options head offset index)
|
||||
result))))))
|
||||
|
||||
(format #t "creating partition table with ~a partitions...\n"
|
||||
(length partitions))
|
||||
(format #t "creating partition table with ~a partitions (~a)...\n"
|
||||
(length partitions)
|
||||
(string-join (map (compose (cut string-append <> " MiB")
|
||||
number->string
|
||||
(lambda (size)
|
||||
(round (/ size (expt 2. 20))))
|
||||
partition-size)
|
||||
partitions)
|
||||
", "))
|
||||
(unless (zero? (apply system* "parted" "--script"
|
||||
device "mklabel" label-type
|
||||
(options partitions offset)))
|
||||
|
|
|
|||
|
|
@ -363,8 +363,8 @@ It has been modified to remove all non-free binary blobs.")
|
|||
|
||||
(define %intel-compatible-systems '("x86_64-linux" "i686-linux"))
|
||||
|
||||
(define %linux-libre-version "4.11.7")
|
||||
(define %linux-libre-hash "0kliwdz4qqjz13pywhavxg19cy1mf6d1f52f6kgapc331309vad9")
|
||||
(define %linux-libre-version "4.11.8")
|
||||
(define %linux-libre-hash "1z35h6xr8gdzq31xv3dpdz6ddz4q3183fwvkmx8qd7h9bhy13aw6")
|
||||
|
||||
(define-public linux-libre
|
||||
(make-linux-libre %linux-libre-version
|
||||
|
|
@ -373,20 +373,20 @@ It has been modified to remove all non-free binary blobs.")
|
|||
#:configuration-file kernel-config))
|
||||
|
||||
(define-public linux-libre-4.9
|
||||
(make-linux-libre "4.9.34"
|
||||
"00jm3338kvhfj850lg3mvk680fmfw34mvwaq41lvxgb1z2xqqlz1"
|
||||
(make-linux-libre "4.9.35"
|
||||
"0fs90jgb01jybkclngg5asvbs1y70f2abs395qcb3lxpx7zxhy1h"
|
||||
%intel-compatible-systems
|
||||
#:configuration-file kernel-config))
|
||||
|
||||
(define-public linux-libre-4.4
|
||||
(make-linux-libre "4.4.74"
|
||||
"04x2ki3s2jsjkkk6bld0rd9rsk8qqvrfsxawxzfa26mkq6pv87r2"
|
||||
(make-linux-libre "4.4.75"
|
||||
"1h687flrdzlcd1ms5n2khm0mxybr8bj2jfnnm7qvy6ha2vsngb5b"
|
||||
%intel-compatible-systems
|
||||
#:configuration-file kernel-config))
|
||||
|
||||
(define-public linux-libre-4.1
|
||||
(make-linux-libre "4.1.41"
|
||||
"02mqfl899jxvrmxlh8lvcgvm3klwd8wbsdz4rr2gpchbggj4vgb2"
|
||||
(make-linux-libre "4.1.42"
|
||||
"1g5jhn7cm6ixn7w8ciqm6qgxv7k1jg50v6k05hsvzvrqfpaxqlbz"
|
||||
%intel-compatible-systems
|
||||
#:configuration-file kernel-config))
|
||||
|
||||
|
|
|
|||
|
|
@ -490,7 +490,7 @@ explicitly appear in OS."
|
|||
lsof ;for Guix's 'list-runtime-roots'
|
||||
pciutils usbutils
|
||||
util-linux inetutils isc-dhcp
|
||||
shadow ;for 'passwd'
|
||||
(@ (gnu packages admin) shadow) ;for 'passwd'
|
||||
|
||||
;; wireless-tools is deprecated in favor of iw, but it's still what
|
||||
;; many people are familiar with, so keep it around.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
|
||||
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
|
||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
|
|
@ -108,8 +108,7 @@
|
|||
(references-graphs #f)
|
||||
(memory-size 256)
|
||||
(disk-image-format "qcow2")
|
||||
(disk-image-size
|
||||
(* 100 (expt 2 20))))
|
||||
(disk-image-size 'guess))
|
||||
"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
|
||||
derivation). In the virtual machine, EXP has access to all its inputs from the
|
||||
store; it should put its output files in the `/xchg' directory, which is
|
||||
|
|
@ -118,7 +117,8 @@ runs with MEMORY-SIZE MiB of memory.
|
|||
|
||||
When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
|
||||
DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
|
||||
return it.
|
||||
return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
|
||||
based on the size of the closure of REFERENCES-GRAPHS.
|
||||
|
||||
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
|
||||
pairs, as for `derivation'. The files containing the reference graphs are
|
||||
|
|
@ -143,14 +143,18 @@ made available under the /xchg CIFS share."
|
|||
(use-modules (guix build utils)
|
||||
(gnu build vm))
|
||||
|
||||
(let ((inputs '#$(list qemu coreutils))
|
||||
(linux (string-append #$linux "/"
|
||||
#$(system-linux-image-file-name)))
|
||||
(initrd (string-append #$initrd "/initrd"))
|
||||
(loader #$loader)
|
||||
(graphs '#$(match references-graphs
|
||||
(((graph-files . _) ...) graph-files)
|
||||
(_ #f))))
|
||||
(let* ((inputs '#$(list qemu coreutils))
|
||||
(linux (string-append #$linux "/"
|
||||
#$(system-linux-image-file-name)))
|
||||
(initrd (string-append #$initrd "/initrd"))
|
||||
(loader #$loader)
|
||||
(graphs '#$(match references-graphs
|
||||
(((graph-files . _) ...) graph-files)
|
||||
(_ #f)))
|
||||
(size #$(if (eq? 'guess disk-image-size)
|
||||
#~(+ (* 70 (expt 2 20)) ;ESP
|
||||
(estimated-partition-size graphs))
|
||||
disk-image-size)))
|
||||
|
||||
(set-path-environment-variable "PATH" '("bin") inputs)
|
||||
|
||||
|
|
@ -160,7 +164,7 @@ made available under the /xchg CIFS share."
|
|||
#:memory-size #$memory-size
|
||||
#:make-disk-image? #$make-disk-image?
|
||||
#:disk-image-format #$disk-image-format
|
||||
#:disk-image-size #$disk-image-size
|
||||
#:disk-image-size size
|
||||
#:references-graphs graphs)))))
|
||||
|
||||
(gexp->derivation name builder
|
||||
|
|
@ -174,7 +178,7 @@ made available under the /xchg CIFS share."
|
|||
(name "qemu-image")
|
||||
(system (%current-system))
|
||||
(qemu qemu-minimal)
|
||||
(disk-image-size (* 100 (expt 2 20)))
|
||||
(disk-image-size 'guess)
|
||||
(disk-image-format "qcow2")
|
||||
(file-system-type "ext4")
|
||||
file-system-label
|
||||
|
|
@ -201,7 +205,8 @@ the image."
|
|||
(guix build utils)))
|
||||
#~(begin
|
||||
(use-modules (gnu build vm)
|
||||
(guix build utils))
|
||||
(guix build utils)
|
||||
(srfi srfi-26))
|
||||
|
||||
(let ((inputs
|
||||
'#$(append (list qemu parted e2fsprogs dosfstools)
|
||||
|
|
@ -227,9 +232,14 @@ the image."
|
|||
#:copy-closures? #$copy-inputs?
|
||||
#:register-closures? #$register-closures?
|
||||
#:system-directory #$os-drv))
|
||||
(root-size #$(if (eq? 'guess disk-image-size)
|
||||
#~(estimated-partition-size
|
||||
(map (cut string-append "/xchg/" <>)
|
||||
graphs))
|
||||
(- disk-image-size
|
||||
(* 50 (expt 2 20)))))
|
||||
(partitions (list (partition
|
||||
(size #$(- disk-image-size
|
||||
(* 50 (expt 2 20))))
|
||||
(size root-size)
|
||||
(label #$file-system-label)
|
||||
(file-system #$file-system-type)
|
||||
(flags '(boot))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -20,7 +20,9 @@
|
|||
#:use-module (guix build utils)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 ftw)
|
||||
#:export (read-reference-graph
|
||||
closure-size
|
||||
populate-store))
|
||||
|
||||
;;; Commentary:
|
||||
|
|
@ -46,6 +48,37 @@ The data at PORT is the format produced by #:references-graphs."
|
|||
(loop (read-line port)
|
||||
result)))))
|
||||
|
||||
(define (file-size file)
|
||||
"Return the size of bytes of FILE, entering it if FILE is a directory."
|
||||
(file-system-fold (const #t)
|
||||
(lambda (file stat result) ;leaf
|
||||
(+ (stat:size stat) result))
|
||||
(lambda (directory stat result) ;down
|
||||
(+ (stat:size stat) result))
|
||||
(lambda (directory stat result) ;up
|
||||
result)
|
||||
(lambda (file stat result) ;skip
|
||||
result)
|
||||
(lambda (file stat errno result)
|
||||
(format (current-error-port)
|
||||
"file-size: ~a: ~a~%" file
|
||||
(strerror errno))
|
||||
result)
|
||||
0
|
||||
file
|
||||
lstat))
|
||||
|
||||
(define (closure-size reference-graphs)
|
||||
"Return an estimate of the size of the closure described by
|
||||
REFERENCE-GRAPHS, a list of reference-graph files."
|
||||
(define (graph-from-file file)
|
||||
(call-with-input-file file read-reference-graph))
|
||||
|
||||
(define items
|
||||
(delete-duplicates (append-map graph-from-file reference-graphs)))
|
||||
|
||||
(reduce + 0 (map file-size items)))
|
||||
|
||||
(define* (populate-store reference-graphs target)
|
||||
"Populate the store under directory TARGET with the items specified in
|
||||
REFERENCE-GRAPHS, a list of reference-graph files."
|
||||
|
|
|
|||
|
|
@ -854,7 +854,7 @@ Some ACTIONS support additional ARGS.\n"))
|
|||
(build-hook? . #t)
|
||||
(max-silent-time . 3600)
|
||||
(verbosity . 0)
|
||||
(image-size . ,(* 900 (expt 2 20)))
|
||||
(image-size . guess)
|
||||
(install-bootloader? . #t)))
|
||||
|
||||
|
||||
|
|
|
|||
19
m4/guix.m4
19
m4/guix.m4
|
|
@ -136,25 +136,6 @@ AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [
|
|||
done
|
||||
])
|
||||
|
||||
dnl GUIX_CHECK_SRFI_37
|
||||
dnl
|
||||
dnl Check whether SRFI-37 suffers from <http://bugs.gnu.org/13176>.
|
||||
dnl This bug was fixed in Guile 2.0.9.
|
||||
AC_DEFUN([GUIX_CHECK_SRFI_37], [
|
||||
AC_CACHE_CHECK([whether (srfi srfi-37) is affected by http://bugs.gnu.org/13176],
|
||||
[ac_cv_guix_srfi_37_broken],
|
||||
[if "$GUILE" -c "(use-modules (srfi srfi-37)) \
|
||||
(sigaction SIGALRM (lambda _ (primitive-exit 1))) \
|
||||
(alarm 1) \
|
||||
(define opts (list (option '(#\I) #f #t (lambda _ #t)))) \
|
||||
(args-fold '(\"-I\") opts (lambda _ (error)) (lambda _ #f) '())"
|
||||
then
|
||||
ac_cv_guix_srfi_37_broken=no
|
||||
else
|
||||
ac_cv_guix_srfi_37_broken=yes
|
||||
fi])
|
||||
])
|
||||
|
||||
dnl GUIX_CHECK_UNBUFFERED_CBIP
|
||||
dnl
|
||||
dnl Check whether 'setbvuf' works on custom binary input ports (CBIPs), as is
|
||||
|
|
|
|||
|
|
@ -1,233 +0,0 @@
|
|||
;;; srfi-37.scm --- args-fold
|
||||
|
||||
;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
|
||||
;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
;; License as published by the Free Software Foundation; either
|
||||
;; version 3 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library 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
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; To use this module with Guile, use (cdr (program-arguments)) as
|
||||
;; the ARGS argument to `args-fold'. Here is a short example:
|
||||
;;
|
||||
;; (args-fold (cdr (program-arguments))
|
||||
;; (let ((display-and-exit-proc
|
||||
;; (lambda (msg)
|
||||
;; (lambda (opt name arg)
|
||||
;; (display msg) (quit) (values)))))
|
||||
;; (list (option '(#\v "version") #f #f
|
||||
;; (display-and-exit-proc "Foo version 42.0\n"))
|
||||
;; (option '(#\h "help") #f #f
|
||||
;; (display-and-exit-proc
|
||||
;; "Usage: foo scheme-file ..."))))
|
||||
;; (lambda (opt name arg)
|
||||
;; (error "Unrecognized option `~A'" name))
|
||||
;; (lambda (op) (load op) (values)))
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
|
||||
;;;; Module definition & exports
|
||||
(define-module (srfi srfi-37)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:export (option option-names option-required-arg?
|
||||
option-optional-arg? option-processor
|
||||
args-fold))
|
||||
|
||||
(cond-expand-provide (current-module) '(srfi-37))
|
||||
|
||||
;;;; args-fold and periphery procedures
|
||||
|
||||
;;; An option as answered by `option'. `names' is a list of
|
||||
;;; characters and strings, representing associated short-options and
|
||||
;;; long-options respectively that should use this option's
|
||||
;;; `processor' in an `args-fold' call.
|
||||
;;;
|
||||
;;; `required-arg?' and `optional-arg?' are mutually exclusive
|
||||
;;; booleans and indicate whether an argument must be or may be
|
||||
;;; provided. Besides the obvious, this affects semantics of
|
||||
;;; short-options, as short-options with a required or optional
|
||||
;;; argument cannot be followed by other short options in the same
|
||||
;;; program-arguments string, as they will be interpreted collectively
|
||||
;;; as the option's argument.
|
||||
;;;
|
||||
;;; `processor' is called when this option is encountered. It should
|
||||
;;; accept the containing option, the element of `names' (by `equal?')
|
||||
;;; encountered, the option's argument (or #f if none), and the seeds
|
||||
;;; as variadic arguments, answering the new seeds as values.
|
||||
(define-record-type srfi-37:option
|
||||
(option names required-arg? optional-arg? processor)
|
||||
option?
|
||||
(names option-names)
|
||||
(required-arg? option-required-arg?)
|
||||
(optional-arg? option-optional-arg?)
|
||||
(processor option-processor))
|
||||
|
||||
(define (error-duplicate-option option-name)
|
||||
(scm-error 'program-error "args-fold"
|
||||
"Duplicate option name `~A~A'"
|
||||
(list (if (char? option-name) #\- "--")
|
||||
option-name)
|
||||
#f))
|
||||
|
||||
(define (build-options-lookup options)
|
||||
"Answer an `equal?' Guile hash-table that maps OPTIONS' names back
|
||||
to the containing options, signalling an error if a name is
|
||||
encountered more than once."
|
||||
(let ((lookup (make-hash-table (* 2 (length options)))))
|
||||
(for-each
|
||||
(lambda (opt)
|
||||
(for-each (lambda (name)
|
||||
(let ((assoc (hash-create-handle!
|
||||
lookup name #f)))
|
||||
(if (cdr assoc)
|
||||
(error-duplicate-option (car assoc))
|
||||
(set-cdr! assoc opt))))
|
||||
(option-names opt)))
|
||||
options)
|
||||
lookup))
|
||||
|
||||
(define (args-fold args options unrecognized-option-proc
|
||||
operand-proc . seeds)
|
||||
"Answer the results of folding SEEDS as multiple values against the
|
||||
program-arguments in ARGS, as decided by the OPTIONS'
|
||||
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
|
||||
(let ((lookup (build-options-lookup options)))
|
||||
;; I don't like Guile's `error' here
|
||||
(define (error msg . args)
|
||||
(scm-error 'misc-error "args-fold" msg args #f))
|
||||
|
||||
(define (mutate-seeds! procedure . params)
|
||||
(set! seeds (call-with-values
|
||||
(lambda ()
|
||||
(apply procedure (append params seeds)))
|
||||
list)))
|
||||
|
||||
;; Clean up the rest of ARGS, assuming they're all operands.
|
||||
(define (rest-operands)
|
||||
(for-each (lambda (arg) (mutate-seeds! operand-proc arg))
|
||||
args)
|
||||
(set! args '()))
|
||||
|
||||
;; Call OPT's processor with OPT, NAME, an argument to be decided,
|
||||
;; and the seeds. Depending on OPT's *-arg? specification, get
|
||||
;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
|
||||
;; if no argument is allowed, call NO-ARG-PROC thunk.
|
||||
(define (invoke-option-processor
|
||||
opt name req-arg-proc opt-arg-proc no-arg-proc)
|
||||
(mutate-seeds!
|
||||
(option-processor opt) opt name
|
||||
(cond ((option-required-arg? opt) (req-arg-proc))
|
||||
((option-optional-arg? opt) (opt-arg-proc))
|
||||
(else (no-arg-proc) #f))))
|
||||
|
||||
;; Compute and answer a short option argument, advancing ARGS as
|
||||
;; necessary, for the short option whose character is at POSITION
|
||||
;; in the current ARG.
|
||||
(define (short-option-argument position)
|
||||
(cond ((< (1+ position) (string-length (car args)))
|
||||
(let ((result (substring (car args) (1+ position))))
|
||||
(set! args (cdr args))
|
||||
result))
|
||||
((pair? (cdr args))
|
||||
(let ((result (cadr args)))
|
||||
(set! args (cddr args))
|
||||
result))
|
||||
((pair? args)
|
||||
(set! args (cdr args))
|
||||
#f)
|
||||
(else #f)))
|
||||
|
||||
;; Interpret the short-option at index POSITION in (car ARGS),
|
||||
;; followed by the remaining short options in (car ARGS).
|
||||
(define (short-option position)
|
||||
(if (>= position (string-length (car args)))
|
||||
(begin
|
||||
(set! args (cdr args))
|
||||
(next-arg))
|
||||
(let* ((opt-name (string-ref (car args) position))
|
||||
(option-here (hash-ref lookup opt-name)))
|
||||
(cond ((not option-here)
|
||||
(mutate-seeds! unrecognized-option-proc
|
||||
(option (list opt-name) #f #f
|
||||
unrecognized-option-proc)
|
||||
opt-name #f)
|
||||
(short-option (1+ position)))
|
||||
(else
|
||||
(invoke-option-processor
|
||||
option-here opt-name
|
||||
(lambda ()
|
||||
(or (short-option-argument position)
|
||||
(error "Missing required argument after `-~A'" opt-name)))
|
||||
(lambda ()
|
||||
;; edge case: -xo -zf or -xo -- where opt-name=#\o
|
||||
;; GNU getopt_long resolves these like I do
|
||||
(short-option-argument position))
|
||||
(lambda () #f))
|
||||
(if (not (or (option-required-arg? option-here)
|
||||
(option-optional-arg? option-here)))
|
||||
(short-option (1+ position))))))))
|
||||
|
||||
;; Process the long option in (car ARGS). We make the
|
||||
;; interesting, possibly non-standard assumption that long option
|
||||
;; names might contain #\=, so keep looking for more #\= in (car
|
||||
;; ARGS) until we find a named option in lookup.
|
||||
(define (long-option)
|
||||
(let ((arg (car args)))
|
||||
(let place-=-after ((start-pos 2))
|
||||
(let* ((index (string-index arg #\= start-pos))
|
||||
(opt-name (substring arg 2 (or index (string-length arg))))
|
||||
(option-here (hash-ref lookup opt-name)))
|
||||
(if (not option-here)
|
||||
;; look for a later #\=, unless there can't be one
|
||||
(if index
|
||||
(place-=-after (1+ index))
|
||||
(mutate-seeds!
|
||||
unrecognized-option-proc
|
||||
(option (list opt-name) #f #f unrecognized-option-proc)
|
||||
opt-name #f))
|
||||
(invoke-option-processor
|
||||
option-here opt-name
|
||||
(lambda ()
|
||||
(if index
|
||||
(substring arg (1+ index))
|
||||
(error "Missing required argument after `--~A'" opt-name)))
|
||||
(lambda () (and index (substring arg (1+ index))))
|
||||
(lambda ()
|
||||
(if index
|
||||
(error "Extraneous argument after `--~A'" opt-name))))))))
|
||||
(set! args (cdr args)))
|
||||
|
||||
;; Process the remaining in ARGS. Basically like calling
|
||||
;; `args-fold', but without having to regenerate `lookup' and the
|
||||
;; funcs above.
|
||||
(define (next-arg)
|
||||
(if (null? args)
|
||||
(apply values seeds)
|
||||
(let ((arg (car args)))
|
||||
(cond ((or (not (char=? #\- (string-ref arg 0)))
|
||||
(= 1 (string-length arg))) ;"-"
|
||||
(mutate-seeds! operand-proc arg)
|
||||
(set! args (cdr args)))
|
||||
((char=? #\- (string-ref arg 1))
|
||||
(if (= 2 (string-length arg)) ;"--"
|
||||
(begin (set! args (cdr args)) (rest-operands))
|
||||
(long-option)))
|
||||
(else (short-option 1)))
|
||||
(next-arg))))
|
||||
|
||||
(next-arg)))
|
||||
|
||||
;;; srfi-37.scm ends here
|
||||
Reference in New Issue