guile-pstk

commit 732c0a4b99839edc9cc3d3d51426feaa6538fd56
parent 04d03f1b26bc815ed017cf740f67c36f499264ea
Author: Yuval Langer <yuval.langer@gmail.com>
Date:   Mon, 17 Jun 2024 01:41:03 +0300

Move Tcl Tk initialisation code.

Diffstat:
M
pstk.scm
 | 
78
+++---------------------------------------------------------------------------
A
tk-init.tcl
 | 
74
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

2 files changed, 77 insertions(+), 75 deletions(-)
diff --git a/pstk.scm b/pstk.scm
@@ -263,81 +263,9 @@
 (define in-callback #f)
 (define callback-mutex #t)
 (define ttk-widget-map '())
-(define tk-init-string "package require Tk
-if {[package version tile] != \"\"} {
-    package require tile
-}
-
-namespace eval AutoName {
-    variable c 0
-    proc autoName {{result \\#\\#}} {
-        variable c
-        append result [incr c]
-    }
-    namespace export *
-}
-
-namespace import AutoName::*
-
-proc callToScm {callKey args} {
-    global scmVar
-    if { [catch {
-            set resultKey [autoName]
-            puts \"(call $callKey \\\"$resultKey\\\" $args)\"
-            flush stdout
-            vwait scmVar($resultKey)
-            set result $scmVar($resultKey)
-            unset scmVar($resultKey)
-            set result
-        } ]
-    } { exit 1 }
-}
-
-proc tclListToScmList {l} {
-    switch [llength $l] {
-        0 {
-            return ()
-        }
-        1 {
-            if {[string range $l 0 0] eq \"\\#\"} {
-                return $l
-            }
-            if {[regexp {^[0-9]+$} $l]} {
-                return $l
-            }
-            if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {
-                return $l
-            }
-            set result \\\"
-            append result\\
-                [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]
-            append result \\\"
-
-        }
-        default {
-            set result {}
-            foreach el $l {
-                append result \" \" [tclListToScmList $el]
-            }
-            set result [string range $result 1 end]
-            return \"($result)\"
-        }
-    }
-}
-
-proc evalCmdFromScm {cmd {properly 0}} {
-    if {[catch {
-        set result [uplevel \\#0 $cmd]
-    } err]} {
-        puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\"
-    } elseif $properly {
-        puts \"(return [tclListToScmList $result])\"
-    } else {
-        puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\"
-    }
-    flush stdout
-}
-")
+(define tk-init-string (call-with-input-file "tk-init.tcl"
+                         (lambda (port)
+                           (get-string-all port))))
 
 (define (report-error x)
   (newline)
diff --git a/tk-init.tcl b/tk-init.tcl
@@ -0,0 +1,74 @@
+package require Tk
+if {[package version tile] != ""} {
+    package require tile
+}
+
+namespace eval AutoName {
+    variable c 0
+    proc autoName {{result \#\#}} {
+        variable c
+        append result [incr c]
+    }
+    namespace export *
+}
+
+namespace import AutoName::*
+
+proc callToScm {callKey args} {
+    global scmVar
+    if { [catch {
+            set resultKey [autoName]
+            puts "(call $callKey \"$resultKey\" $args)"
+            flush stdout
+            vwait scmVar($resultKey)
+            set result $scmVar($resultKey)
+            unset scmVar($resultKey)
+            set result
+        } ]
+    } { exit 1 }
+}
+
+proc tclListToScmList {l} {
+    switch [llength $l] {
+        0 {
+            return ()
+        }
+        1 {
+            if {[string range $l 0 0] eq "\#"} {
+                return $l
+            }
+            if {[regexp {^[0-9]+$} $l]} {
+                return $l
+            }
+            if {[regexp {^[.[:alpha:]][^ ,\"\'\[\]\\;]*$} $l]} {
+                return $l
+            }
+            set result \"
+            append result\
+                [string map [list \" \\\" \\ \\\\] $l]
+            append result \"
+
+        }
+        default {
+            set result {}
+            foreach el $l {
+                append result " " [tclListToScmList $el]
+            }
+            set result [string range $result 1 end]
+            return "($result)"
+        }
+    }
+}
+
+proc evalCmdFromScm {cmd {properly 0}} {
+    if {[catch {
+        set result [uplevel \#0 $cmd]
+    } err]} {
+        puts "(error \"[string map [list \\ \\\\ \" \\\"] $err]\")"
+    } elseif $properly {
+        puts "(return [tclListToScmList $result])"
+    } else {
+        puts "(return \"[string map [list \\ \\\\ \" \\\"] $result]\")"
+    }
+    flush stdout
+}