aboutsummaryrefslogtreecommitdiffstats
path: root/lib/gs/priv/gstk.tcl
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/gs/priv/gstk.tcl
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/gs/priv/gstk.tcl')
-rw-r--r--lib/gs/priv/gstk.tcl366
1 files changed, 366 insertions, 0 deletions
diff --git a/lib/gs/priv/gstk.tcl b/lib/gs/priv/gstk.tcl
new file mode 100644
index 0000000000..63151ef952
--- /dev/null
+++ b/lib/gs/priv/gstk.tcl
@@ -0,0 +1,366 @@
+# ------------------------------------------------------------
+# Some tcl scripts used from erlang
+# By Ola Samuelsson in May 1995
+# � Ericsson Software Technology / Erlang System
+# ------------------------------------------------------------
+
+package require Tk 8.3
+
+# Scrolled object.
+# This is a script that creates a
+# scrolled object of specified type
+# and connects it with scrollbars.
+#
+# Give a name for the frame and you'll find
+# name.z,
+# name.sy,
+# name.pad.sx
+# name.pad.it
+#
+
+proc so_create {type w} {
+ set parent [frame $w]
+ eval {$type $parent.z -highlightt 0}
+ $parent.z config -yscrollcommand [list $parent.sy set] \
+ -xscrollcommand [list $parent.pad.sx set]
+ scrollbar $parent.sy -orient vertical -takefocus 0 \
+ -command [list $parent.z yview]
+ # create extra frame to hold pad
+ frame $parent.pad
+ scrollbar $parent.pad.sx -orient horizontal -takefocus 0 \
+ -command [list $parent.z xview]
+ #create padding based on the scrollbars width
+ set pad [expr [$parent.sy cget -width] + 2 * \
+ ([$parent.sy cget -bd] + \
+ [$parent.sy cget -highlightthickness])]
+ frame $parent.pad.it -width $pad -height $pad
+ # Arrange everything
+ so_plain $parent
+ return $parent
+}
+
+proc so_top_right {w} {
+ so_unpack $w
+ pack $w.pad -side top -fill x
+ pack $w.pad.it -side right
+ pack $w.pad.sx -side top -fill x
+ pack $w.sy -side right -fill y
+ pack $w.z -side left -fill both -expand true
+}
+
+proc so_top_left {w} {
+ so_unpack $w
+ pack $w.pad -side top -fill x
+ pack $w.pad.it -side left
+ pack $w.pad.sx -side top -fill x
+ pack $w.sy -side left -fill y
+ pack $w.z -side right -fill both -expand true
+}
+
+proc so_bottom_right {w} {
+ so_unpack $w
+ pack $w.pad -side bottom -fill x
+ pack $w.pad.it -side right
+ pack $w.pad.sx -side bottom -fill x
+ pack $w.sy -side right -fill y
+ pack $w.z -side left -fill both -expand true
+}
+
+proc so_bottom_left {w} {
+ so_unpack $w
+ pack $w.pad -side bottom -fill x
+ pack $w.pad.it -side left
+ pack $w.pad.sx -side bottom -fill x
+ pack $w.sy -side left -fill y
+ pack $w.z -side right -fill both -expand true
+}
+
+proc so_bottom {w} {
+ so_unpack $w
+ pack $w.pad -side bottom -fill x
+ pack $w.pad.sx -side bottom -fill x
+ pack $w.z -side left -fill both -expand true
+}
+
+proc so_top {w} {
+ so_unpack $w
+ pack $w.pad -side top -fill x
+ pack $w.pad.sx -side top -fill x
+ pack $w.z -side left -fill both -expand true
+}
+
+proc so_right {w} {
+ so_unpack $w
+ pack $w.sy -side right -fill y
+ pack $w.z -side left -fill both -expand true
+}
+
+proc so_left {w} {
+ so_unpack $w
+ pack $w.sy -side left -fill y
+ pack $w.z -side right -fill both -expand true
+}
+
+proc so_plain {w} {
+ so_unpack $w
+ pack $w.z -side left -fill both -expand true
+}
+
+proc so_unpack {w} {
+ pack forget $w.pad.it
+ pack forget $w.pad.sx
+ pack forget $w.pad
+ pack forget $w.sy
+ pack forget $w.z
+}
+
+# ------------------------------------------------------------
+# editor stuff
+
+proc ed_load {w file} {
+ if [catch {open $file r} fileId] {
+ report "$fileId"
+ return -code error
+ } else {
+ $w delete 1.0 end
+ while {![eof $fileId]} {
+ $w insert end [read $fileId 1000]
+ }
+ close $fileId
+ }
+}
+
+proc ed_save {w file} {
+ if [catch {open $file w} fileId] {
+ report "$fileId"
+ return -code error
+ } else {
+ puts -nonewline $fileId [$w get 1.0 end]
+ close $fileId
+ }
+}
+
+# returns rect1 text1 rect2 text2 ...
+proc mkgrid {canvas colws startrow endrow height font fg bg} {
+ set res [list]
+ set ncols [llength $colws]
+ set y [expr ($startrow-1)*$height+$startrow]
+ for {set row $startrow} {$row <= $endrow} {incr row} {
+ set x 1
+ for {set col 0} {$col < $ncols} {incr col} {
+ set colw [lindex $colws $col]
+# each object is tagged q<columnNo>
+# is this (ugly) way we can find to what column an object belongs
+# even later...
+ set r [$canvas create re $x $y [expr $x+$colw] [expr $y+$height]\
+ -f $bg -outline $fg -tag "q$col"]
+ set t [$canvas create te [expr $x+2] [expr $y+2]\
+ -anch nw -fo $font -fi $fg -tag "q$col"]
+ $canvas raise $t
+ lappend res $r $t
+ set x [expr $x+$colw+1]
+ }
+ set y [expr $y+$height+1]
+ }
+ return $res
+}
+
+# new x values
+proc calc_new_xs {colws} {
+ set ncols [llength $colws]
+ set res [list]
+ set x 1
+ for {set col 0} {$col < $ncols} {incr col} {
+ lappend res $x
+ set x [expr $x+1+[lindex $colws $col]]
+ }
+ lappend res $x
+ return $res
+}
+
+proc resize_grid_cols {canvas colws} {
+ set item 1
+ set xs [calc_new_xs $colws]
+ while {[set nbr_of_coords\
+ [llength [set coords [$canvas coords $item]]]] > 0} {
+ set tags [$canvas itemcget $item -tag]
+ set first [string first "q" $tags]
+# find the column of the current object by
+# searching for the q tag.
+ set col [string range $tags [expr 1 + $first]\
+ [expr [string wordend $tags $first] -1]]
+ switch $nbr_of_coords {
+ 2 { # a text object
+ set y [lindex $coords 1]
+ set newx [expr [lindex $xs $col] + 2]
+ $canvas coords $item $newx $y
+ }
+ 4 { # a rectangle object
+ set y1 [lindex $coords 1]
+ set y2 [lindex $coords 3]
+ set newx1 [lindex $xs $col]
+ set newx2 [expr [lindex $xs [expr $col + 1]]-1]
+ $canvas coords $item $newx1 $y1 $newx2 $y2
+ }
+ }
+ set item [expr $item+1]
+ }
+}
+
+# ------------------------------------------------------------
+# A wish init script to make it possible for
+# Tcl/Tk and erlang to communicate.
+# Written by Ola Samuelsson in August 1995
+# � Ericsson Software Technology AB / Erlang Systems
+# ------------------------------------------------------------
+
+# Protocol:
+# \1 = it's an event
+# \2 = it's a reply for a call
+# \3 = it's a error reply for call
+# \4 = it's an error
+# \5 = stopbyte (end of message)
+
+proc erlsend {args} {
+ global outstream
+ set msg [join $args]
+ puts -nonewline $outstream [binary format Ica* \
+ [expr 1 + [string length $msg]] 1 $msg]
+ flush $outstream
+}
+
+proc erlcall {w} {
+ global outstream
+ set errcode [catch $w result]
+ if {$errcode == 0} {
+ puts -nonewline $outstream [binary format Ica* \
+ [expr 1 + [string length $result]] 2 $result]
+ flush $outstream
+ } else {
+ puts -nonewline $outstream [binary format Ica* \
+ [expr 1 + [string length $result]] 3 $result]
+ flush $outstream
+ }
+}
+
+proc erlexec {w} {
+ set errcode [catch $w result]
+ if {$errcode != 0} {
+ global outstream
+ puts -nonewline $outstream [binary format Ica* \
+ [expr 1 + [string length $result]] 4 $result]
+ flush $outstream
+ }
+}
+
+proc erlerror {w} {
+ global outstream
+ puts -nonewline $outstream [binary format Ica* \
+ [expr 1 + [string length $w]] 4 $w]
+ flush $outstream
+}
+
+proc report {s} {
+ catch {console show}
+ puts -nonewline stderr "$s\r\n"
+}
+
+wm withdraw .
+
+# The stdin stream is by default in line buffering mode.
+# We set non blocking so that if the line is large we are
+# not blocked until we get all data. The gets command
+# will never give us a line until we have read it all
+# so we do nothing if we get the return code -1.
+# Note that -1 also means eof so we check that.
+
+# FIXME: What is the default encoding on Unix?
+# Do we need to set "-encoding iso8859-1" ?
+
+# FIXME: If pipe we should do "catch {close $pipe}"
+# but we don't do that on stdin do we? If not how
+# do we unregister from 'fileevent'?
+
+# The ending "vwait forever" will block
+# until all streams are closed.
+# FIXME: How are we terminated? No check for eof?
+
+# If we got something on the command line after --
+# we have a port number and we are to use sockets
+# for the communication.
+
+set privdir [lindex $argv 0]
+set portno [lindex $argv 1]
+#report $argv
+#report $privdir
+#report $portno
+set resfile [file join $privdir gs-xdefaults]
+
+# FIXME we may use 'startupFile' as priority level to enable the user
+# to use .Xdefaults to override things but I think this require that
+# we change gs-xdefaults to use Tk*Option format?
+
+if [catch {option readfile $resfile} err] {
+ report "Error reading $resfile: $err"
+}
+
+if {$portno == ""} {
+
+ global use_socket
+ set use_socket 0
+ set instream stdin
+ set outstream stdout
+
+ # We are only allowed to set non blocking output
+ # for pipes because sockets are bidirectional
+ # and the fconfigure sets both input and output.
+
+ fconfigure stdout -buffering none -blocking false \
+ -translation binary -encoding binary
+} else {
+
+ global use_socket
+ set use_socket 1
+ set sock [socket 127.0.0.1 $portno]
+ set instream $sock
+ set outstream $sock
+
+}
+
+fconfigure $instream -buffering none -blocking true \
+ -translation binary -encoding binary
+
+fileevent $instream readable do_read
+
+proc do_read {} {
+ global instream
+
+ binary scan [read $instream 4] I len
+
+ if {[eof $instream]} {
+ catch {close $instream}
+ exit
+ }
+
+# report {"LEN $len"}
+
+ # FIXME need to read again if less then $len ?????
+ set command [read $instream $len]
+
+ if {[eof $instream]} {
+ catch {close $instream}
+ exit
+ }
+
+# report {"INMSG $command EOMSG"}
+
+ if [catch {uplevel #0 $command} msg] {
+ report {$msg}
+ } else {
+ if {[string length $msg] != 0} {
+# report {"OUTMSG $msg EOMSG"}
+ puts -nonewline $instream [binary format Ia* \
+ [string length $msg] $msg]
+ }
+ }
+}