utils: Add 'canonical-newline-port'.

* guix/utils.scm (canonical-newline-port): New procedure.
* tests/utils.scm ("canonical-newline-port"): New test.
This commit is contained in:
Federico Beffa 2015-11-14 15:00:36 +01:00
parent 94abc84887
commit c8be6f0d4a
2 changed files with 38 additions and 2 deletions

View File

@ -29,7 +29,8 @@
#:use-module (srfi srfi-39)
#:use-module (srfi srfi-60)
#:use-module (rnrs bytevectors)
#:use-module ((rnrs io ports) #:select (put-bytevector))
#:use-module (rnrs io ports)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module ((guix build utils)
#:select (dump-port package-name->name+version))
#:use-module ((guix build syscalls) #:select (errno mkdtemp!))
@ -90,7 +91,8 @@
decompressed-port
call-with-decompressed-port
compressed-output-port
call-with-compressed-output-port))
call-with-compressed-output-port
canonical-newline-port))
;;;
@ -746,6 +748,34 @@ elements after E."
(if success?
(loop (absolute target) (+ depth 1))
file))))))
(define (canonical-newline-port port)
"Return an input port that wraps PORT such that all newlines consist
of a single carriage return."
(define (get-position)
(if (port-has-port-position? port) (port-position port) #f))
(define (set-position! position)
(if (port-has-set-port-position!? port)
(set-port-position! position port)
#f))
(define (close) (close-port port))
(define (read! bv start n)
(let loop ((count 0)
(byte (get-u8 port)))
(cond ((eof-object? byte) count)
((= count (- n 1))
(bytevector-u8-set! bv (+ start count) byte)
n)
;; XXX: consume all LFs even if not followed by CR.
((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
(else
(bytevector-u8-set! bv (+ start count) byte)
(loop (+ count 1) (get-u8 port))))))
(make-custom-binary-input-port "canonical-newline-port"
read!
get-position
set-position!
close))
;;;
;;; Source location.

View File

@ -318,6 +318,12 @@
(string-append (%store-prefix)
"/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
(test-equal "canonical-newline-port"
"This is a journey\nInto the sound\nA journey ...\n"
(let ((port (open-string-input-port
"This is a journey\r\nInto the sound\r\nA journey ...\n")))
(get-string-all (canonical-newline-port port))))
(test-end)
(false-if-exception (delete-file temp-file))