From a629b61e5ea21f6a23c0ec4d68ccbca64f993845 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 7 May 2019 23:50:48 -0700 Subject: [PATCH] Treat strings returned from primitives as UTF-8 coded. In particular, make sure that filenames are treated this way, because this is normal for modern unix systems. This change mostly affects filenames, but also environment variables and command-line strings. This is necessary because strings passed to primitives are converted to UTF-8 bytevectors. Otherwise, a non-ASCII filename returned by a primitive won't be converted back to the same bytes when passed to another primitive. --- src/runtime/command-line.scm | 8 ++++++-- src/runtime/os-primitives.scm | 3 ++- src/runtime/primitive-io.scm | 16 +++++++++------- src/runtime/runtime.pkg | 13 ++++++++----- src/runtime/savres.scm | 4 +++- src/runtime/sfile.scm | 9 +++------ src/runtime/string.scm | 5 +++++ src/runtime/unxprm.scm | 14 ++++++++------ src/runtime/wrkdir.scm | 3 ++- 9 files changed, 46 insertions(+), 29 deletions(-) diff --git a/src/runtime/command-line.scm b/src/runtime/command-line.scm index 7a6bfaab5..fedd21fc0 100644 --- a/src/runtime/command-line.scm +++ b/src/runtime/command-line.scm @@ -33,8 +33,12 @@ USA. (lambda () (add-event-receiver! event:after-restart process-command-line))) +(define (scheme-program-name) + (string-from-primitive ((ucode-primitive scheme-program-name 0)))) + (define (command-line) - (vector->list ((ucode-primitive get-command-line 0)))) + (map string-from-primitive + (vector->list ((ucode-primitive get-command-line 0))))) (define-deferred param:load-init-file? (make-settable-parameter #t)) @@ -80,7 +84,7 @@ USA. (set! *command-line-arguments* '()) (let ((unused (or ((ucode-primitive get-unused-command-line 0)) '#()))) (parameterize ((param:load-init-file? #t)) - (process-keyword (vector->list unused) '()) + (process-keyword (map string-from-primitive (vector->list unused)) '()) (for-each (lambda (act) (act)) (reverse after-parsing-actions)) (if (and (param:load-init-file?) diff --git a/src/runtime/os-primitives.scm b/src/runtime/os-primitives.scm index 7a6fee3d2..4efd6d5b1 100644 --- a/src/runtime/os-primitives.scm +++ b/src/runtime/os-primitives.scm @@ -54,7 +54,8 @@ USA. (define (reset-environment-variables!) (hash-table-clear! %env-cache) (vector-for-each (lambda (s) - (let ((i (string-find-next-char s #\=))) + (let ((s (string-from-primitive s)) + (i (string-find-next-char s #\=))) (if i (hash-table-set! %env-cache (string-head s i) diff --git a/src/runtime/primitive-io.scm b/src/runtime/primitive-io.scm index a11523db6..9a690b0b2 100644 --- a/src/runtime/primitive-io.scm +++ b/src/runtime/primitive-io.scm @@ -420,8 +420,8 @@ USA. (lambda () (let ((result ((ucode-primitive open-pty-master 0)))) (values (make-channel (vector-ref result 0)) - (vector-ref result 1) - (vector-ref result 2)))))) + (string-from-primitive (vector-ref result 1)) + (string-from-primitive (vector-ref result 2))))))) (define (pty-master-send-signal channel signal) ((ucode-primitive pty-master-send-signal 2) (channel-descriptor channel) @@ -464,13 +464,15 @@ USA. (remove-from-gc-finalizer! open-directories channel)) (define (directory-channel-read channel) - ((ucode-primitive new-directory-read 1) - (directory-channel/descriptor channel))) + (string-from-primitive + ((ucode-primitive new-directory-read 1) + (directory-channel/descriptor channel)))) (define (directory-channel-read-matching channel prefix) - ((ucode-primitive new-directory-read-matching 2) - (directory-channel/descriptor channel) - (string-for-primitive prefix))) + (string-from-primitive + ((ucode-primitive new-directory-read-matching 2) + (directory-channel/descriptor channel) + (string-for-primitive prefix)))) ;;;; Select registry diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index c216d3ffd..3bd89bf6d 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -728,7 +728,11 @@ USA. (define-package (runtime simple-file-ops) (files "sfile") (parent (runtime)) + (export () deprecated:simple-file-ops + (file-writable? file-writeable?)) (export () + (file-exists? file-exists-indirect?) + (file-soft-link? file-symbolic-link?) allocate-temporary-file associate-pathname-type-with-mime-type @@ -748,18 +752,15 @@ USA. file-executable? file-exists-direct? file-exists-indirect? - file-exists? file-modification-time<=? file-modification-timestring) (export (runtime) - string-for-primitive) + string-for-primitive + string-from-primitive) (export (runtime symbol) %ascii-ustring! %ascii-ustring-allocate @@ -3285,6 +3287,7 @@ USA. argument-command-line-parser command-line command-line-arguments + scheme-program-name set-command-line-parser! simple-command-line-parser)) diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm index 11d582542..74f233da8 100644 --- a/src/runtime/savres.scm +++ b/src/runtime/savres.scm @@ -106,7 +106,9 @@ USA. (->namestring (if (default-object? filename) (merge-pathnames - (let ((filename ((ucode-primitive reload-band-name)))) + (let ((filename + (string-from-primitive + ((ucode-primitive reload-band-name))))) (if (not filename) (error "no default band name available")) filename)) diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index 496bfb9e7..da100090f 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -45,8 +45,6 @@ USA. #f result))) -(define file-exists? file-exists-indirect?) - (define file-type-direct) (define file-type-indirect) (let ((make-file-type @@ -82,9 +80,9 @@ USA. (eq? 'directory (file-type-indirect filename))) (define (file-symbolic-link? filename) - ((ucode-primitive file-symlink? 1) - (string-for-primitive (->namestring (merge-pathnames filename))))) -(define file-soft-link? file-symbolic-link?) + (string-from-primitive + ((ucode-primitive file-symlink? 1) + (string-for-primitive (->namestring (merge-pathnames filename)))))) (define (file-access filename amode) ((ucode-primitive file-access 2) @@ -102,7 +100,6 @@ USA. filename (string-for-primitive (directory-namestring pathname))))) 2)) -(define file-writable? file-writeable?) ;upwards compatability (define (file-executable? filename) (file-access filename 1)) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 9c8156ce7..9c401d0ee 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -2120,6 +2120,11 @@ USA. string (string->utf8 string))) +(define (string-from-primitive string) + (if (legacy-string? string) + (utf8->string (legacy-string->bytevector string)) + string)) + (define-integrable (every-loop proc ref string start end) (let loop ((i start)) (if (fix:< i end) diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index fb2c4cf9c..6b88c678e 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -97,16 +97,18 @@ USA. (error "Can't find temporary directory."))))) (define (file-attributes-direct filename) - ((ucode-primitive file-attributes 1) - (string-for-primitive (->namestring (merge-pathnames filename))))) + (let ((v + ((ucode-primitive file-attributes 1) + (string-for-primitive (->namestring (merge-pathnames filename)))))) + (and v + (begin + (vector-set! v 0 (string-from-primitive (vector-ref v 0))) + v)))) (define (file-attributes-indirect filename) ((ucode-primitive file-attributes-indirect 1) (string-for-primitive (->namestring (merge-pathnames filename))))) -(define file-attributes - file-attributes-direct) - (define-structure (file-attributes (type vector) (constructor #f) @@ -245,7 +247,7 @@ USA. (let ((directory ((ucode-primitive get-user-home-directory 1) user-name))) (if (not directory) (error "Can't find user's home directory:" user-name)) - (pathname-as-directory directory))) + (pathname-as-directory (string-from-primitive directory)))) (define (current-home-directory) (let ((home (get-environment-variable "HOME"))) diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm index 2199edf13..4e4f18214 100644 --- a/src/runtime/wrkdir.scm +++ b/src/runtime/wrkdir.scm @@ -50,7 +50,8 @@ USA. (working-directory-pathname (pathname-simplify (pathname-as-directory - ((ucode-primitive working-directory-pathname)))))) + (string-from-primitive + ((ucode-primitive working-directory-pathname))))))) (define (set-working-directory-pathname! name) (let ((pathname (new-pathname name))) -- 2.25.1