From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 21 Sep 2017 22:25:47 +0000 (-0700)
Subject: x11: Ensure C strings are null terminated.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~21
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fd1a6e93db21ac2b8ef2fab7c4349df5713afe5d;p=mit-scheme.git

x11: Ensure C strings are null terminated.
---

diff --git a/src/x11/x11-base.scm b/src/x11/x11-base.scm
index ed50a8b5a..8eb177e3f 100644
--- a/src/x11/x11-base.scm
+++ b/src/x11/x11-base.scm
@@ -52,6 +52,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
       (error "XAllocWMHints failed.")))
 
 (define (->bytes string)
+  ;; NOT null terminated
   (if (and (or (bytevector? string)
 	       (and (ustring? string)
 		    (fix:= 1 (ustring-cp-size string))))
@@ -68,14 +69,33 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	     (loop (fix:+ i 1)))
 	#t)))
 
+(define (->cstring string)
+  (if (bytevector? string)
+      (if (let ((end (bytevector-length string)))
+	    (let loop ((i 0))
+	      (if (fix:< i end)
+		  (or (fix:zero? (bytevector-u8-ref string i))
+		      (loop (fix:1+ i)))
+		  #f)))
+	  string
+	  (error "C string not null terminated:" string))
+      ;; String->iso8859-1 would be incorrect here; it does not null terminate.
+      (let* ((end (string-length string))
+	     (result (make-bytevector (fix:1+ end))))
+	(do ((i 0 (fix:1+ i)))
+	    ((not (fix:< i end))
+	     (bytevector-u8-set! result i #x00))
+	  (bytevector-u8-set! result i (char->integer (string-ref string i))))
+	result)))
+
 (define (x-window-set-name window name)
   (guarantee-xwindow window 'x-window-set-name)
-  (if (not (zero? (C-call "x_window_set_name" window (->bytes name))))
+  (if (not (zero? (C-call "x_window_set_name" window (->cstring name))))
       (error "XStringListToTextProperty failed.")))
 
 (define (x-window-set-icon-name window name)
   (guarantee-xwindow window 'x-window-set-icon-name)
-  (if (not (zero? (C-call "x_window_set_icon_name" window (->bytes name))))
+  (if (not (zero? (C-call "x_window_set_icon_name" window (->cstring name))))
       (error "XStringListToTextProperty failed.")))
 
 ;;; Open/Close
@@ -84,7 +104,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (let ((alien (make-alien '(struct |xdisplay|))))
     (C-call "x_open_display" alien (if (eq? #f display-name)
 				       0
-				       (->bytes display-name)))
+				       (->cstring display-name)))
     (if (alien-null? alien)
 	(error "Could not open display:" display-name)
 	alien)))
@@ -104,7 +124,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (x-set-default-font display font-name)
   (guarantee-xdisplay display 'x-set-default-font)
-  (if (not (zero? (c-call "x_set_default_font" display (->bytes font-name))))
+  (if (not (zero? (c-call "x_set_default_font" display (->cstring font-name))))
       (error "Could not load font:" font-name)))
 
 ;;; Event Processing
@@ -432,8 +452,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (x-display-get-default display resource-name class-name)
   (guarantee-xdisplay display 'x-display-get-default)
-  (let ((alien (C-call "x_display_get_default" (make-alien 'char)
-		       display (->bytes resource-name) (->bytes class-name))))
+  (let ((alien (C-call "x_display_get_default" (make-alien 'char) display
+		       (->cstring resource-name) (->cstring class-name))))
     (and (not (alien-null? alien))
 	 (c-peek-cstring alien))))
 
@@ -487,7 +507,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-window-set-foreground-color window color)
   (guarantee-xwindow window 'x-window-set-foreground-color)
   (cond ((string? color)
-	 (C-call "x_window_set_foreground_color_name" window (->bytes color)))
+	 (C-call "x_window_set_foreground_color_name" window (->cstring color)))
 	((integer? color)
 	 (C-call "x_window_set_foreground_color_pixel" window color))
 	(else
@@ -497,7 +517,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-window-set-background-color window color)
   (guarantee-xwindow window 'x-window-set-background-color)
   (cond ((string? color)
-	 (C-call "x_window_set_background_color_name" window (->bytes color)))
+	 (C-call "x_window_set_background_color_name" window (->cstring color)))
 	((integer? color)
 	 (C-call "x_window_set_background_color_pixel" window color))
 	(else
@@ -507,7 +527,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-window-set-border-color window color)
   (guarantee-xwindow window 'x-window-set-border-color)
   (cond ((string? color)
-	 (C-call "x_window_set_border_color_name" window (->bytes color)))
+	 (C-call "x_window_set_border_color_name" window (->cstring color)))
 	((integer? color)
 	 (C-call "x_window_set_border_color_pixel" window color))
 	(else
@@ -517,7 +537,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-window-set-cursor-color window color)
   (guarantee-xwindow window 'x-window-set-cursor-color)
   (cond ((string? color)
-	 (C-call "x_window_set_cursor_color_name" window (->bytes color)))
+	 (C-call "x_window_set_cursor_color_name" window (->cstring color)))
 	((integer? color)
 	 (C-call "x_window_set_cursor_color_pixel" window color))
 	(else
@@ -527,7 +547,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-window-set-mouse-color window color)
   (guarantee-xwindow window 'x-window-set-mouse-color)
   (cond ((string? color)
-	 (C-call "x_window_set_mouse_color_name" window (->bytes color)))
+	 (C-call "x_window_set_mouse_color_name" window (->cstring color)))
 	((integer? color)
 	 (C-call "x_window_set_mouse_color_pixel" window color))
 	(else
@@ -542,7 +562,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-window-set-font window font)
   (guarantee-xwindow window 'x-window-set-font)
   (guarantee string? font 'x-window-set-font)
-  (not (zero? (C-call "x_window_set_font" window (->bytes font)))))
+  (not (zero? (C-call "x_window_set_font" window (->cstring font)))))
 
 (define (x-window-set-border-width window width)
   (guarantee-xwindow window 'x-window-set-border-width)
@@ -620,7 +640,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (guarantee-xdisplay display 'x-font-structure)
   (let ((font-struct (make-alien '(struct |XFontStruct|))))
     (cond ((string? name/id)
-	   (let ((name (->bytes name/id)))
+	   (let ((name (->cstring name/id)))
 	     (add-alien-cleanup!
 	      font-struct
 	      (named-lambda (font-struct-init-by-name! copy)
@@ -735,7 +755,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (x-intern-atom display name soft?)
   (guarantee-xdisplay display 'x-intern-atom)
-  (c-call "x_intern_atom" display (->bytes name) (if soft? 1 0)))
+  (c-call "x_intern_atom" display (->cstring name) (if soft? 1 0)))
 
 (define (x-get-atom-name display atom)
 
diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm
index f160f5542..db4910fc4 100644
--- a/src/x11/x11-graphics.scm
+++ b/src/x11/x11-graphics.scm
@@ -58,23 +58,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-graphics-reconfigure window width height)
   (C-call "x_graphics_reconfigure" window width height))
 
-(define (->bytes string)
-  (if (and (or (bytevector? string)
-	       (and (ustring? string)
-		    (fix:= 1 (ustring-cp-size string))))
-	   (let ((end (string-length string)))
-	     (every-loop (lambda (cp) (fix:< cp #x80))
-			 cp1-ref string 0 end)))
-      string
-      (string->iso8859-1 string)))
-
-(define-integrable (every-loop proc ref string start end)
-  (let loop ((i start))
-    (if (fix:< i end)
-	(and (proc (ref string i))
-	     (loop (fix:+ i 1)))
-	#t)))
-
 (define (x-graphics-open-window display geometry suppress-map)
   ;; Open a window on DISPLAY using GEOMETRY.  If GEOMETRY is false
   ;; map window interactively.  If third argument SUPPRESS-MAP? is
@@ -99,9 +82,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (let ((window
 	   (c-call "x_graphics_open_window" (make-alien '(struct |xwindow|))
 		   display
-		   (->bytes geometry)
-		   (->bytes name)
-		   (->bytes class)
+		   (->cstring geometry)
+		   (->cstring name)
+		   (->cstring class)
 		   (if map? 1 0))))
       (if (alien-null? window)
 	  (error "Could not open window:" geometry))
@@ -137,12 +120,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (x-graphics-draw-string window x y string)
   ;; Draw characters in the current font at the given coordinates, with
   ;; transparent background.
-  (C-call "x_graphics_draw_string" window x y (->bytes string)))
+  (C-call "x_graphics_draw_string" window x y (->cstring string)))
 
 (define (x-graphics-draw-image-string window x y string)
   ;; Draw characters in the current font at the given coordinates, with
   ;; solid background.
-  (C-call "x_graphics_draw_image_string" window x y (->bytes string)))
+  (C-call "x_graphics_draw_image_string" window x y (->cstring string)))
 
 (define (x-graphics-set-function window function)
   (if (not (zero? (C-call "x_graphics_set_function" window function)))
diff --git a/src/x11/x11-terminal.scm b/src/x11/x11-terminal.scm
index 1cee3cb1e..548492901 100644
--- a/src/x11/x11-terminal.scm
+++ b/src/x11/x11-terminal.scm
@@ -75,9 +75,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (let ((window
 	   (c-call "xterm_open_window" (make-alien '(struct |xwindow|))
 		   display
-		   (string->utf8 geometry)
-		   (string->utf8 name)
-		   (string->utf8 class)
+		   (->cstring geometry)
+		   (->cstring name)
+		   (->cstring class)
 		   (if map? 1 0))))
       (if (alien-null? window)
 	  (error "Could not open xterm:" geometry))
@@ -109,23 +109,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
       ((2) (error:bad-range-argument y 'xterm-write-char!))
       ((3) (error:bad-range-argument highlight 'xterm-write-char!)))))
 
-(define (all-ascii? string)
-  (let ((len (string-length string)))
-    (let loop ((i 0))
-      (if (fix:< i len)
-	  (and (char-ascii? (string-ref string i))
-	       (loop (fix:+ i 1)))
-	  #t))))
-
-(define (guarantee-all-ascii string operator)
-  (if (not (all-ascii? string))
-      (error:wrong-type-argument string "an ASCII string" operator))
-  string)
-
 (define (xterm-write-substring! xterm x y string start end highlight)
-  (guarantee-all-ascii string 'xterm-write-substring!)
-  (let ((code (c-call "xterm_write_substring"
-		      xterm x y (string->utf8 string) start end highlight)))
+  (let ((code (if (bytevector? string)
+		  (c-call "xterm_write_substring"
+			  xterm x y string start end highlight)
+		  (c-call "xterm_write_substring"
+			  xterm x y
+			  (string->iso8859-1 string start end)
+			  0 (fix:- end start) highlight))))
     (case code
       ((1) (error:bad-range-argument x 'xterm-write-substring!))
       ((2) (error:bad-range-argument y 'xterm-write-substring!))
diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg
index 071ba2e4c..c67e3ae6b 100644
--- a/src/x11/x11.pkg
+++ b/src/x11/x11.pkg
@@ -38,6 +38,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	  ustring-cp-size
 	  ustring?)
   (export (x11)
+	  ->cstring
 	  x-visual-deallocate
 	  x-close-display
 	  x-close-all-displays
@@ -141,10 +142,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define-package (x11 graphics)
   (files "x11-graphics")
   (parent (x11))
-  (import (runtime ustring)
-	  cp1-ref
-	  ustring-cp-size
-	  ustring?)
   (export (x11)
 	  x-graphics-set-vdc-extent
 	  x-graphics-vdc-extent