utils: Add 'edit-expression'.
* guix/utils.scm (edit-expression): New procedure. * tests/utils.scm (edit-expression): New test.
This commit is contained in:
parent
645deac326
commit
50a3d59473
@ -41,6 +41,7 @@
|
|||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
|
#:use-module ((ice-9 iconv) #:select (bytevector->string))
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:export (bytevector->base16-string
|
#:export (bytevector->base16-string
|
||||||
base16-string->bytevector
|
base16-string->bytevector
|
||||||
@ -86,6 +87,7 @@
|
|||||||
split
|
split
|
||||||
cache-directory
|
cache-directory
|
||||||
readlink*
|
readlink*
|
||||||
|
edit-expression
|
||||||
|
|
||||||
filtered-port
|
filtered-port
|
||||||
compressed-port
|
compressed-port
|
||||||
@ -318,6 +320,44 @@ a list of command-line arguments passed to the compression program."
|
|||||||
(unless (every (compose zero? cdr waitpid) pids)
|
(unless (every (compose zero? cdr waitpid) pids)
|
||||||
(error "compressed-output-port failure" pids))))))
|
(error "compressed-output-port failure" pids))))))
|
||||||
|
|
||||||
|
(define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
|
||||||
|
"Edit the expression specified by SOURCE-PROPERTIES using PROC, which should
|
||||||
|
be a procedure that takes the original expression in string and returns a new
|
||||||
|
one. ENCODING will be used to interpret all port I/O, it default to UTF-8.
|
||||||
|
This procedure returns #t on success."
|
||||||
|
(with-fluids ((%default-port-encoding encoding))
|
||||||
|
(let* ((file (assq-ref source-properties 'filename))
|
||||||
|
(line (assq-ref source-properties 'line))
|
||||||
|
(column (assq-ref source-properties 'column))
|
||||||
|
(in (open-input-file file))
|
||||||
|
;; The start byte position of the expression.
|
||||||
|
(start (begin (while (not (and (= line (port-line in))
|
||||||
|
(= column (port-column in))))
|
||||||
|
(when (eof-object? (read-char in))
|
||||||
|
(error (format #f "~a: end of file~%" in))))
|
||||||
|
(ftell in)))
|
||||||
|
;; The end byte position of the expression.
|
||||||
|
(end (begin (read in) (ftell in))))
|
||||||
|
(seek in 0 SEEK_SET) ; read from the beginning of the file.
|
||||||
|
(let* ((pre-bv (get-bytevector-n in start))
|
||||||
|
;; The expression in string form.
|
||||||
|
(str (bytevector->string
|
||||||
|
(get-bytevector-n in (- end start))
|
||||||
|
(port-encoding in)))
|
||||||
|
(post-bv (get-bytevector-all in))
|
||||||
|
(str* (proc str)))
|
||||||
|
;; Verify the edited expression is still a scheme expression.
|
||||||
|
(call-with-input-string str* read)
|
||||||
|
;; Update the file with edited expression.
|
||||||
|
(with-atomic-file-output file
|
||||||
|
(lambda (out)
|
||||||
|
(put-bytevector out pre-bv)
|
||||||
|
(display str* out)
|
||||||
|
;; post-bv maybe the end-of-file object.
|
||||||
|
(when (not (eof-object? post-bv))
|
||||||
|
(put-bytevector out post-bv))
|
||||||
|
#t))))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Advisory file locking.
|
;;; Advisory file locking.
|
||||||
|
@ -333,6 +333,19 @@
|
|||||||
"This is a journey\r\nInto the sound\r\nA journey ...\n")))
|
"This is a journey\r\nInto the sound\r\nA journey ...\n")))
|
||||||
(get-string-all (canonical-newline-port port))))
|
(get-string-all (canonical-newline-port port))))
|
||||||
|
|
||||||
|
|
||||||
|
(test-equal "edit-expression"
|
||||||
|
"(display \"GNU Guix\")\n(newline)\n"
|
||||||
|
(begin
|
||||||
|
(call-with-output-file temp-file
|
||||||
|
(lambda (port)
|
||||||
|
(display "(display \"xiuG UNG\")\n(newline)\n" port)))
|
||||||
|
(edit-expression `((filename . ,temp-file)
|
||||||
|
(line . 0)
|
||||||
|
(column . 9))
|
||||||
|
string-reverse)
|
||||||
|
(call-with-input-file temp-file get-string-all)))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
||||||
(false-if-exception (delete-file temp-file))
|
(false-if-exception (delete-file temp-file))
|
||||||
|
Loading…
Reference in New Issue
Block a user