diff options
Diffstat (limited to 'guix/derivations.scm')
-rw-r--r-- | guix/derivations.scm | 84 |
1 files changed, 58 insertions, 26 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 7db61d272f..2fe684cc18 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 binary-ports) + #:use-module ((ice-9 textual-ports) #:select (put-char put-string)) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -561,33 +562,65 @@ things as appropriate and is thus more efficient." ((prefix (... ...) last) (for-each (lambda (item) (write-item item port) - (display "," port)) + (put-char port #\,)) prefix) (write-item last port)))) (define-inlinable (write-list lst write-item port) ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each ;; element. - (display "[" port) + (put-char port #\[) (write-sequence lst write-item port) - (display "]" port)) + (put-char port #\])) (define-inlinable (write-tuple lst write-item port) ;; Same, but write LST as a tuple. - (display "(" port) + (put-char port #\() (write-sequence lst write-item port) - (display ")" port)) + (put-char port #\))) + +(define %escape-char-set + ;; Characters that need to be escaped. + (char-set #\" #\\ #\newline #\return #\tab)) + +(define (escaped-string str) + "Escape double quote characters found in STR, if any." + (define escape + (match-lambda + (#\" "\\\"") + (#\\ "\\\\") + (#\newline "\\n") + (#\return "\\r") + (#\tab "\\t"))) + + (let loop ((str str) + (result '())) + (let ((index (string-index str %escape-char-set))) + (if index + (let ((rest (string-drop str (+ 1 index)))) + (loop rest + (cons* (escape (string-ref str index)) + (string-take str index) + result))) + (if (null? result) + str + (string-concatenate-reverse (cons str result))))))) (define (write-derivation drv port) "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of Eelco Dolstra's PhD dissertation for an overview of a previous version of that form." - ;; Make sure we're using the faster implementation. - (define format simple-format) + ;; Use 'put-string', which does less work and is faster than 'display'. + ;; Likewise, 'write-escaped-string' is faster than 'write'. + + (define (write-escaped-string str port) + (put-char port #\") + (put-string port (escaped-string str)) + (put-char port #\")) (define (write-string-list lst) - (write-list lst write port)) + (write-list lst write-escaped-string port)) (define (write-output output port) (match output @@ -599,48 +632,47 @@ that form." "") (or (and=> hash bytevector->base16-string) "")) - write + write-escaped-string port)))) (define (write-input input port) (match input (($ <derivation-input> obj sub-drvs) - (display "(\"" port) + (put-string port "(\"") ;; 'derivation/masked-inputs' produces objects that contain a string ;; instead of a <derivation>, so we need to account for that. - (display (if (derivation? obj) - (derivation-file-name obj) - obj) - port) - (display "\"," port) + (put-string port (if (derivation? obj) + (derivation-file-name obj) + obj)) + (put-string port "\",") (write-string-list sub-drvs) - (display ")" port)))) + (put-char port #\))))) (define (write-env-var env-var port) (match env-var ((name . value) - (display "(" port) - (write name port) - (display "," port) - (write value port) - (display ")" port)))) + (put-char port #\() + (write-escaped-string name port) + (put-char port #\,) + (write-escaped-string value port) + (put-char port #\))))) ;; Assume all the lists we are writing are already sorted. (match drv (($ <derivation> outputs inputs sources system builder args env-vars) - (display "Derive(" port) + (put-string port "Derive(") (write-list outputs write-output port) - (display "," port) + (put-char port #\,) (write-list inputs write-input port) - (display "," port) + (put-char port #\,) (write-string-list sources) (simple-format port ",\"~a\",\"~a\"," system builder) (write-string-list args) - (display "," port) + (put-char port #\,) (write-list env-vars write-env-var port) - (display ")" port)))) + (put-char port #\))))) (define derivation->bytevector (lambda (drv) |