diff options
author | Ludovic Courtès <ludo@gnu.org> | 2017-06-30 11:41:57 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2017-06-30 11:41:57 +0200 |
commit | e0556f76954cc56b257dad33aaa94588e87695dc (patch) | |
tree | 6d6d6f4d6682256a40de4abd031175fb7440918d | |
parent | 1abc08a8f48f121cfa5a77394aa71a0441b4eb44 (diff) | |
parent | 87941d1df473511f0f75737e81a51a106132c9de (diff) | |
download | guix-e0556f76954cc56b257dad33aaa94588e87695dc.tar guix-e0556f76954cc56b257dad33aaa94588e87695dc.tar.gz |
Merge branch 'master' into core-updates
-rw-r--r-- | Makefile.am | 17 | ||||
-rw-r--r-- | configure.ac | 4 | ||||
-rw-r--r-- | doc/guix.texi | 12 | ||||
-rw-r--r-- | gnu/build/vm.scm | 41 | ||||
-rw-r--r-- | gnu/packages/linux.scm | 16 | ||||
-rw-r--r-- | gnu/system.scm | 2 | ||||
-rw-r--r-- | gnu/system/vm.scm | 44 | ||||
-rw-r--r-- | guix/build/store-copy.scm | 35 | ||||
-rw-r--r-- | guix/scripts/system.scm | 2 | ||||
-rw-r--r-- | m4/guix.m4 | 19 | ||||
-rw-r--r-- | srfi/srfi-37.scm.in | 233 |
11 files changed, 103 insertions, 322 deletions
diff --git a/Makefile.am b/Makefile.am index 4dfcd06d0b..f6059d94bf 100644 --- a/Makefile.am +++ b/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 ; \ diff --git a/configure.ac b/configure.ac index c937e948d3..2b75c900cc 100644 --- a/configure.ac +++ b/configure.ac @@ -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]) diff --git a/doc/guix.texi b/doc/guix.texi index 729ec081be..d61a5b7514 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 57619764ce..8f7fc3c9c4 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -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))) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 9031d727ef..28a060fe54 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -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)) diff --git a/gnu/system.scm b/gnu/system.scm index 31f9320023..39f8465bcb 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -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. diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 392737d078..7ac8696158 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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)) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index a296bdf78f..fe2eb6f69a 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -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." diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 35675cc018..7e20b10dad 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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))) diff --git a/m4/guix.m4 b/m4/guix.m4 index e546b8f4dd..add57f5262 100644 --- a/m4/guix.m4 +++ b/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 diff --git a/srfi/srfi-37.scm.in b/srfi/srfi-37.scm.in deleted file mode 100644 index 3f654af2ce..0000000000 --- a/srfi/srfi-37.scm.in +++ /dev/null @@ -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 |