diff options
Diffstat (limited to 'lib/gs/priv/gstk.tcl')
| -rw-r--r-- | lib/gs/priv/gstk.tcl | 366 |
1 files changed, 0 insertions, 366 deletions
diff --git a/lib/gs/priv/gstk.tcl b/lib/gs/priv/gstk.tcl deleted file mode 100644 index 63151ef952..0000000000 --- a/lib/gs/priv/gstk.tcl +++ /dev/null @@ -1,366 +0,0 @@ -# ------------------------------------------------------------ -# 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] - } - } -} |