diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2020-12-17 16:19:07 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2020-12-19 23:25:01 +0100 |
| commit | 4f621a2b003e85d480999e4d0630e9dc3de85bc3 (patch) | |
| tree | 8e5dda8866dcae4887560e32dae15e1a02267457 | |
| parent | c7c7f068c15e419aaf5ef616516aa5ad4e55c2fa (diff) | |
maint: Require Guile >= 2.2.6.
* configure.ac: For Guile 2.2, require 2.2.6 or later.
* guix/gexp.scm (define-syntax-parameter-once): Remove.
Use 'define-syntax-parameter' instead.
* guix/mnoads.scm: Likewise.
* guix/inferior.scm (proxy)[select*]: Remove.
* guix/scripts/publish.scm <top level>: Remove replacement for (@@ (web
http) read-header-line).
* guix/store/deduplication.scm (counting-wrapper-port): Remove.
(nar-sha256): Call 'port-position' on PORT to compute SIZE.
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | guix/gexp.scm | 15 | ||||
| -rw-r--r-- | guix/inferior.scm | 11 | ||||
| -rw-r--r-- | guix/monads.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 26 | ||||
| -rw-r--r-- | guix/store/deduplication.scm | 32 |
6 files changed, 10 insertions, 91 deletions
diff --git a/configure.ac b/configure.ac index a5bdf24e939..afb449950ff 100644 --- a/configure.ac +++ b/configure.ac | |||
| @@ -102,7 +102,7 @@ if test "x$GUILD" = "x"; then | |||
| 102 | fi | 102 | fi |
| 103 | 103 | ||
| 104 | if test "x$GUILE_EFFECTIVE_VERSION" = "x2.2"; then | 104 | if test "x$GUILE_EFFECTIVE_VERSION" = "x2.2"; then |
| 105 | PKG_CHECK_MODULES([GUILE], [guile-2.2 >= 2.2.3]) | 105 | PKG_CHECK_MODULES([GUILE], [guile-2.2 >= 2.2.6]) |
| 106 | fi | 106 | fi |
| 107 | 107 | ||
| 108 | dnl Get CFLAGS and LDFLAGS for libguile. | 108 | dnl Get CFLAGS and LDFLAGS for libguile. |
diff --git a/guix/gexp.scm b/guix/gexp.scm index 051831238ea..764c89a1873 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm | |||
| @@ -1317,18 +1317,7 @@ and in the current monad setting (system type, etc.)" | |||
| 1317 | reference->sexp (gexp-references exp)))) | 1317 | reference->sexp (gexp-references exp)))) |
| 1318 | (return (apply (gexp-proc exp) args)))) | 1318 | (return (apply (gexp-proc exp) args)))) |
| 1319 | 1319 | ||
| 1320 | (define-syntax-rule (define-syntax-parameter-once name proc) | 1320 | (define-syntax-parameter current-imported-modules |
| 1321 | ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME | ||
| 1322 | ;; does not get redefined. This works around a race condition in a | ||
| 1323 | ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. | ||
| 1324 | (eval-when (load eval expand compile) | ||
| 1325 | (define name | ||
| 1326 | (if (module-locally-bound? (current-module) 'name) | ||
| 1327 | (module-ref (current-module) 'name) | ||
| 1328 | (make-syntax-transformer 'name 'syntax-parameter | ||
| 1329 | (list proc)))))) | ||
| 1330 | |||
| 1331 | (define-syntax-parameter-once current-imported-modules | ||
| 1332 | ;; Current list of imported modules. | 1321 | ;; Current list of imported modules. |
| 1333 | (identifier-syntax '())) | 1322 | (identifier-syntax '())) |
| 1334 | 1323 | ||
| @@ -1339,7 +1328,7 @@ environment." | |||
| 1339 | (identifier-syntax modules))) | 1328 | (identifier-syntax modules))) |
| 1340 | body ...)) | 1329 | body ...)) |
| 1341 | 1330 | ||
| 1342 | (define-syntax-parameter-once current-imported-extensions | 1331 | (define-syntax-parameter current-imported-extensions |
| 1343 | ;; Current list of extensions. | 1332 | ;; Current list of extensions. |
| 1344 | (identifier-syntax '())) | 1333 | (identifier-syntax '())) |
| 1345 | 1334 | ||
diff --git a/guix/inferior.scm b/guix/inferior.scm index 77820872b35..2fe91beaabe 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm | |||
| @@ -469,22 +469,13 @@ is similar to the sexp returned by 'package-provenance' for regular packages." | |||
| 469 | "Proxy communication between CLIENT and BACKEND until CLIENT closes the | 469 | "Proxy communication between CLIENT and BACKEND until CLIENT closes the |
| 470 | connection, at which point CLIENT is closed (both CLIENT and BACKEND must be | 470 | connection, at which point CLIENT is closed (both CLIENT and BACKEND must be |
| 471 | input/output ports.)" | 471 | input/output ports.)" |
| 472 | (define (select* read write except) | ||
| 473 | ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4: | ||
| 474 | ;; since 'select' sometimes returns non-empty sets for no good reason, | ||
| 475 | ;; call 'select' a second time with a zero timeout to filter out incorrect | ||
| 476 | ;; replies. | ||
| 477 | (match (select read write except) | ||
| 478 | ((read write except) | ||
| 479 | (select read write except 0)))) | ||
| 480 | |||
| 481 | ;; Use buffered ports so that 'get-bytevector-some' returns up to the | 472 | ;; Use buffered ports so that 'get-bytevector-some' returns up to the |
| 482 | ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. | 473 | ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. |
| 483 | (setvbuf client 'block 65536) | 474 | (setvbuf client 'block 65536) |
| 484 | (setvbuf backend 'block 65536) | 475 | (setvbuf backend 'block 65536) |
| 485 | 476 | ||
| 486 | (let loop () | 477 | (let loop () |
| 487 | (match (select* (list client backend) '() '()) | 478 | (match (select (list client backend) '() '()) |
| 488 | ((reads () ()) | 479 | ((reads () ()) |
| 489 | (when (memq client reads) | 480 | (when (memq client reads) |
| 490 | (match (get-bytevector-some client) | 481 | (match (get-bytevector-some client) |
diff --git a/guix/monads.scm b/guix/monads.scm index 6924471345a..6ae616aca93 100644 --- a/guix/monads.scm +++ b/guix/monads.scm | |||
| @@ -274,23 +274,12 @@ more optimizations." | |||
| 274 | (_ | 274 | (_ |
| 275 | #'generic-name)))))))))) | 275 | #'generic-name)))))))))) |
| 276 | 276 | ||
| 277 | (define-syntax-rule (define-syntax-parameter-once name proc) | 277 | (define-syntax-parameter >>= |
| 278 | ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME | ||
| 279 | ;; does not get redefined. This works around a race condition in a | ||
| 280 | ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. | ||
| 281 | (eval-when (load eval expand compile) | ||
| 282 | (define name | ||
| 283 | (if (module-locally-bound? (current-module) 'name) | ||
| 284 | (module-ref (current-module) 'name) | ||
| 285 | (make-syntax-transformer 'name 'syntax-parameter | ||
| 286 | (list proc)))))) | ||
| 287 | |||
| 288 | (define-syntax-parameter-once >>= | ||
| 289 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. | 278 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. |
| 290 | (lambda (s) | 279 | (lambda (s) |
| 291 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) | 280 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) |
| 292 | 281 | ||
| 293 | (define-syntax-parameter-once return | 282 | (define-syntax-parameter return |
| 294 | (lambda (s) | 283 | (lambda (s) |
| 295 | (syntax-violation 'return "return used outside of 'with-monad'" s))) | 284 | (syntax-violation 'return "return used outside of 'with-monad'" s))) |
| 296 | 285 | ||
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c31cef31818..5a865c838d6 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm | |||
| @@ -824,32 +824,6 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." | |||
| 824 | (define %http-write | 824 | (define %http-write |
| 825 | (@@ (web server http) http-write)) | 825 | (@@ (web server http) http-write)) |
| 826 | 826 | ||
| 827 | (match (list (major-version) (minor-version) (micro-version)) | ||
| 828 | (("2" "2" "5") ;Guile 2.2.5 | ||
| 829 | (let () | ||
| 830 | (define %read-line (@ (ice-9 rdelim) %read-line)) | ||
| 831 | (define bad-header (@@ (web http) bad-header)) | ||
| 832 | |||
| 833 | ;; XXX: Work around <https://bugs.gnu.org/36350> by reverting to the | ||
| 834 | ;; definition of 'read-header-line' as found in 2.2.4 and earlier. | ||
| 835 | (define (read-header-line port) | ||
| 836 | "Read an HTTP header line and return it without its final CRLF or LF. | ||
| 837 | Raise a 'bad-header' exception if the line does not end in CRLF or LF, | ||
| 838 | or if EOF is reached." | ||
| 839 | (match (%read-line port) | ||
| 840 | (((? string? line) . #\newline) | ||
| 841 | ;; '%read-line' does not consider #\return a delimiter; so if it's | ||
| 842 | ;; there, remove it. We are more tolerant than the RFC in that we | ||
| 843 | ;; tolerate LF-only endings. | ||
| 844 | (if (string-suffix? "\r" line) | ||
| 845 | (string-drop-right line 1) | ||
| 846 | line)) | ||
| 847 | ((line . _) ;EOF or missing delimiter | ||
| 848 | (bad-header 'read-header-line line)))) | ||
| 849 | |||
| 850 | (set! (@@ (web http) read-header-line) read-header-line))) | ||
| 851 | (_ #t)) | ||
| 852 | |||
| 853 | (define (strip-headers response) | 827 | (define (strip-headers response) |
| 854 | "Return RESPONSE's headers minus 'Content-Length' and our internal headers." | 828 | "Return RESPONSE's headers minus 'Content-Length' and our internal headers." |
| 855 | (fold alist-delete | 829 | (fold alist-delete |
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index a72a43bf79b..cd9660174cf 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm | |||
| @@ -37,38 +37,14 @@ | |||
| 37 | dump-file/deduplicate | 37 | dump-file/deduplicate |
| 38 | copy-file/deduplicate)) | 38 | copy-file/deduplicate)) |
| 39 | 39 | ||
| 40 | ;; XXX: This port is used as a workaround on Guile <= 2.2.4 where | ||
| 41 | ;; 'port-position' throws to 'out-of-range' when the offset is great than or | ||
| 42 | ;; equal to 2^32: <https://bugs.gnu.org/32161>. | ||
| 43 | (define (counting-wrapper-port output-port) | ||
| 44 | "Return two values: an output port that wraps OUTPUT-PORT, and a thunk to | ||
| 45 | retrieve the number of bytes written to OUTPUT-PORT." | ||
| 46 | (let ((byte-count 0)) | ||
| 47 | (values (make-custom-binary-output-port "counting-wrapper" | ||
| 48 | (lambda (bytes offset count) | ||
| 49 | (put-bytevector output-port bytes | ||
| 50 | offset count) | ||
| 51 | (set! byte-count | ||
| 52 | (+ byte-count count)) | ||
| 53 | count) | ||
| 54 | (lambda () | ||
| 55 | byte-count) | ||
| 56 | #f | ||
| 57 | (lambda () | ||
| 58 | (close-port output-port))) | ||
| 59 | (lambda () | ||
| 60 | byte-count)))) | ||
| 61 | |||
| 62 | (define (nar-sha256 file) | 40 | (define (nar-sha256 file) |
| 63 | "Gives the sha256 hash of a file and the size of the file in nar form." | 41 | "Gives the sha256 hash of a file and the size of the file in nar form." |
| 64 | (let*-values (((port get-hash) (open-sha256-port)) | 42 | (let-values (((port get-hash) (open-sha256-port))) |
| 65 | ((wrapper get-size) (counting-wrapper-port port))) | 43 | (write-file file port) |
| 66 | (write-file file wrapper) | ||
| 67 | (force-output wrapper) | ||
| 68 | (force-output port) | 44 | (force-output port) |
| 69 | (let ((hash (get-hash)) | 45 | (let ((hash (get-hash)) |
| 70 | (size (get-size))) | 46 | (size (port-position port))) |
| 71 | (close-port wrapper) | 47 | (close-port port) |
| 72 | (values hash size)))) | 48 | (values hash size)))) |
| 73 | 49 | ||
| 74 | (define (tempname-in directory) | 50 | (define (tempname-in directory) |
