@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/tcltk/exec/util-expand.tcl

@@ -0,0 +1,207 @@
+# util-expand.tcl --
+#
+#	This file implements package ::Utility::expand, which  ...
+#
+# Copyright (c) 1997-8 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+package require ::Utility
+package provide ::Utility::expand 1.0
+
+namespace eval ::Utility::expand {;
+
+namespace export -clear expand*
+namespace import -force ::Utility::*
+
+##
+## NOTE: In places where uplevel is used, it is highly likely that
+## a further eval redirect is otherwise necessary for foreign interps
+##
+
+# expand --
+#
+#	The string to match is expanded to the longest possible match.
+#	If data(-showmultiple) is non-zero and the user longest match
+#	equaled the string to expand, then all possible matches are
+#	output to stdout.  Triggers bell if no matches are found.
+#
+# Arguments:
+#    type	type of expansion (path / proc / variable)
+#
+# Returns:
+#	number of matches found
+#
+proc expand {args} {
+    array set opts {
+	-type any -widget {}
+    }
+    set args [get_opts opts $args {-type 1 -widget 1} {-widget widget}]
+    if {[string match {} $opts(-widget)] && [llength $args]!=1} {
+	return -code error "wrong # args: should be\
+		\"[lindex [info level 0] 0] ?-type type?\
+		?-widget widget || str?"
+    }
+    set prefix [namespace current]::expand_
+    if {[string match {} [set arg [info commands $prefix$opts(-type)]]]} {
+	set arg [info commands $prefix$opts(-type)*]
+    }
+    set result {}
+    set code ok
+    if 0 {
+	set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
+	set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
+	if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit}
+	if {[$w compare $tmp >= insert]} return
+	set str [$w get $tmp insert]
+    }
+    switch [llength $arg] {
+	1 { set code [catch {uplevel $arg $args} result] }
+	0 {
+	    set arg [info commands $prefix*]
+	    regsub -all $prefix $arg {} arg
+	    return -code error "unknown [lindex [info level 0] 0] type\
+		    \"$opts(-type)\", must be one of: [join [lsort $arg] {, }]"
+	}
+	default {
+	    regsub -all $prefix $arg {} arg
+	    return -code error "ambiguous type \"$opts(-type)\",\
+		    could be one of: [join [lsort $arg] {, }]"
+	}
+    }
+    if 0 {
+	set len [llength $res]
+	if {$len} {
+	    $w delete $tmp insert
+	    $w insert $tmp [lindex $res 0]
+	    if {$len > 1} {
+		upvar \#0 [namespace current]::[winfo parent $w] data
+		if {$data(-showmultiple) && \
+			![string compare [lindex $res 0] $str]} {
+		    puts stdout [lsort [lreplace $res 0 0]]
+		}
+	    }
+	} else { bell }
+	return [incr len -1]
+    }
+    return -code $code [string trimright $result \n]
+}
+
+# expand_pathname --
+#
+#    expand a file pathname based on $str
+#    This is based on UNIX file name conventions
+#
+# Arguments:
+#   str		partial file pathname to expand
+# Results:
+#   Returns list containing longest unique match followed by all the
+#   possible further matches
+#
+proc expand_pathname {str} {
+    #reval pwd, cd, glob and final cd
+    set pwd [pwd]
+    if {[catch {cd [file dirname $str]} err]} {
+	return -code error $err
+    }
+    if {[catch {glob [file tail $str]*} m]} {
+	set match {}
+    } else {
+	if {[llength $m] > 1} {
+	    global tcl_platform
+	    if {[string match windows $tcl_platform(platform)]} {
+		## Windows is screwy because it can be case insensitive
+		set tmp [best_match [string tolower [lsort $m]] \
+			[string tolower [file tail $str]]]
+	    } else {
+		set tmp [best_match [lsort $m] [file tail $str]]
+	    }
+	    if {[string match ?*/* $str]} {
+		set tmp [file dirname $str]/$tmp
+	    } elseif {[string match /* $str]} {
+		set tmp /$tmp
+	    }
+	    regsub -all { } $tmp {\\ } tmp
+	    set match [linsert $m 0 $tmp]
+	} else {
+	    ## This may look goofy, but it handles spaces in path names
+	    eval append match $m
+	    if {[file isdir $match]} {append match /}
+	    if {[string match ?*/* $str]} {
+		set match [file dirname $str]/$match
+	    } elseif {[string match /* $str]} {
+		set match /$match
+	    }
+	    regsub -all { } $match {\\ } match
+	    ## Why is this one needed and the ones below aren't!!
+	    set match [list $match]
+	}
+    }
+    cd $pwd
+    return $match
+}
+
+# expand_proc --
+#
+## ExpandProcname - expand a tcl proc name based on $str
+# ARGS:	str	- partial proc name to expand
+# Calls:	best_match
+# Returns:	list containing longest unique match followed by all the
+#		possible further matches
+#
+# Arguments:
+#   args	comments
+# Results:
+#   Returns ...
+#
+proc expand_proc {str} {
+    #reval info
+    set match [uplevel info commands [list $str]*]
+    if {[llength $match] > 1} {
+	regsub -all { } [best_match $match $str] {\\ } str
+	set match [linsert $match 0 $str]
+    } else {
+	regsub -all { } $match {\\ } match
+    }
+    return $match
+}
+
+# expand_variable --
+#
+## ExpandVariable - expand a tcl variable name based on $str
+# ARGS:	str	- partial tcl var name to expand
+# Calls:	best_match
+# Returns:	list containing longest unique match followed by all the
+#		possible further matches
+#
+# Arguments:
+#   args	comments
+# Results:
+#   Returns ...
+#
+proc expand_variable {str} {
+    #reval "array names", "info vars"
+    if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
+	## Looks like they're trying to expand an array.
+	set match [array names $ary $str*]
+	if {[llength $match] > 1} {
+	    set vars $ary\([best_match $match $str]
+	    foreach var $match {lappend vars $ary\($var\)}
+	    return $vars
+	} else {set match $ary\($match\)}
+	## Space transformation avoided for array names.
+    } else {
+	set match [info vars $str*]
+	if {[llength $match] > 1} {
+	    regsub -all { } [best_match $match $str] {\\ } str
+	    set match [linsert $match 0 $str]
+	} else {
+	    regsub -all { } $match {\\ } match
+	}
+    }
+    return $match
+}
+
+}; # end of namespace ::Utility::expand

package/dist/vfs/usr/lib/R/library/tcltk/exec/util-number.tcl

@@ -0,0 +1,101 @@
+# util-number.tcl --
+#
+#	This file implements package ::Utility::number, which  ...
+#
+# Copyright (c) 1997 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+#package require NAME VERSION
+package provide ::Utility::number 1.0
+
+namespace eval ::Utility::number {;
+
+namespace export -clear *
+
+# get_square_size --
+#   gets the minimum square size for an input
+# Arguments:
+#   num		number
+# Returns:
+#   returns smallest square size that would fit number
+#
+;proc get_square_size num {
+    set i 1
+    while {[expr {$i*$i}] < $num} { incr i }
+    return $i
+}
+
+# roman2dec --
+#   converts a roman numeral to decimal
+# Arguments:
+#   x		number in roman numeral format
+# Returns:
+#   decimal number
+#
+;proc roman2dec {x} {
+    set result ""
+    foreach elem {
+	{ 1000	m }	{ 900	cm }    
+	{ 500	d }	{ 400	id }    
+	{ 100	c }	{ 90	ic }    
+	{ 50	l }    
+	{ 10	x }	{ 9	ix }    
+	{ 5	v }	{ 4	iv }    
+	{ 1	i }
+    } {
+	set digit [lindex $elem 0]
+	set roman [lindex $elem 1]
+	while {$x >= $digit} {
+	    append result $roman
+	    incr x -$digit
+	}
+    }
+    return $result
+}
+
+# bin2hex --
+#   converts binary to hex number
+# Arguments:
+#   bin		number in binary format
+# Returns:
+#   hexadecimal number
+#
+;proc bin2hex bin {
+    ## No sanity checking is done
+    array set t {
+	0000 0 0001 1 0010 2 0011 3 0100 4
+	0101 5 0110 6 0111 7 1000 8 1001 9
+	1010 a 1011 b 1100 c 1101 d 1110 e 1111 f
+    }
+    set diff [expr {4-[string length $bin]%4}]
+    if {$diff != 4} {
+        set bin [format %0${diff}d$bin 0]
+    }
+    regsub -all .... $bin {$t(&)} hex
+    return [subst $hex]
+}
+
+
+# hex2bin --
+#   converts hex number to bin
+# Arguments:
+#   hex		number in hex format
+# Returns:
+#   binary number (in chars, not binary format)
+#
+;proc hex2bin hex {
+    array set t {
+	0 0000 1 0001 2 0010 3 0011 4 0100
+	5 0101 6 0110 7 0111 8 1000 9 1001
+	a 1010 b 1011 c 1100 d 1101 e 1110 f 1111
+	A 1010 B 1011 C 1100 D 1101 E 1110 F 1111
+    }
+    regsub {^0[xX]} $hex {} hex
+    regsub -all . $hex {$t(&)} bin
+    return [subst $bin]
+}
+
+}

package/dist/vfs/usr/lib/R/library/tcltk/exec/util-string.tcl

@@ -0,0 +1,149 @@
+# util-string.tcl --
+#
+#	This file implements package ::Utility::string, which  ...
+#
+# Copyright (c) 1997 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+
+#package require NAME VERSION
+package provide ::Utility::string 1.0; # SET VERSION
+
+namespace eval ::Utility::string {;
+
+namespace export -clear *
+
+# string_cap --
+#
+#   Capitalize a string, or one char in it
+#
+# Arguments:
+#   str		input string
+#   idx		idx to capitalize
+# Results:
+#   Returns string with specified capitalization
+#
+proc string_cap {str {idx -1}} {
+    if {$i>-1} {
+	if {[string length $str]>$i} {
+	    return $str
+	} else {
+	}
+    } else {
+	return [string toupper [string index $str 0]][string tolower \
+		[string range $str 1 end]]
+    }
+}
+
+# string_reverse --
+#   reverses input string
+# Arguments:
+#   s		input string to reverse
+# Returns:
+#   string with chars reversed
+#
+;proc string_reverse s {
+    if {[set i [string len $s]]} {
+	while {$i} {append r [string index $s [incr i -1]]}
+	return $r
+    }
+}
+
+# obfuscate --
+#   If I describe it, it ruins it...
+# Arguments:
+#   s		input string
+# Returns:
+#   output
+#
+;proc obfuscate s {
+    if {[set len [string len $s]]} {
+	set i -1
+	while {[incr i]<$len} {
+	    set c [string index $s $i]
+	    if {[regexp "\[\]\\\[ \{\}\t\n\"\]" $c]} {
+		append r $c
+	    } else {
+		scan $c %c c
+		append r \\[format %0.3o $c]
+	    }
+	}
+	return $r
+    }
+}
+
+# untabify --
+#   removes tabs from a string, replacing with appropriate number of spaces
+# Arguments:
+#   str		input string
+#   tablen	tab length, defaults to 8
+# Returns:
+#   string sans tabs
+#
+;proc untabify {str {tablen 8}} {
+    set out {}
+    while {[set i [string first "\t" $str]] != -1} {
+	set j [expr {$tablen-($i%$tablen)}]
+	append out [string range $str 0 [incr i -1]][format %*s $j { }]
+	set str [string range $str [incr i 2] end]
+    }
+    return $out$str
+}
+
+# tabify --
+#   converts excess spaces to tab chars
+# Arguments:
+#   str		input string
+#   tablen	tab length, defaults to 8
+# Returns:
+#   string with tabs replacing excess space where appropriate
+#
+;proc tabify {str {tablen 8}} {
+    ## We must first untabify so that \t is not interpreted to be one char
+    set str [untabify $str]
+    set out {}
+    while {[set i [string first { } $str]] != -1} {
+	## Align i to the upper tablen boundary
+	set i [expr {$i+$tablen-($i%$tablen)-1}]
+	set s [string range $str 0 $i]
+	if {[string match {* } $s]} {
+	    append out [string trimright $s { }]\t
+	} else {
+	    append out $s
+	}
+	set str [string range $str [incr i] end]
+    }
+    return $out$str
+}
+
+# wrap_lines --
+#   wraps text to a specific max line length
+# Arguments:
+#   txt		input text
+#   len		desired max line length+1, defaults to 75
+#   P		paragraph boundary chars, defaults to \n\n
+#   P2		substitute for $P while processing, defaults to \254
+#		this char must not be in the input text
+# Returns:
+#   text with lines no longer than $len, except where a single word
+#   is longer than $len chars.  does not preserve paragraph boundaries.
+#
+;proc wrap_lines "txt {len 75} {P \n\n} {P2 \254}" {
+    regsub -all $P $txt $P2 txt
+    regsub -all "\n" $txt { } txt
+    incr len -1
+    set out {}
+    while {[string len $txt]>$len} {
+	set i [string last { } [string range $txt 0 $len]]
+	if {$i == -1 && [set i [string first { } $txt]] == -1} break
+	append out [string trim [string range $txt 0 [incr i -1]]]\n
+	set txt [string range $txt [incr i 2] end]
+    }
+    regsub -all $P2 $out$txt $P txt
+    return $txt
+}
+
+}; # end of namespace ::Utility::string

package/dist/vfs/usr/lib/R/library/tcltk/exec/util-tk.tcl

@@ -0,0 +1,244 @@
+# util-tk.tcl --
+#
+#	This file implements package ::Utility::tk, which  ...
+#
+# Copyright (c) 1997-8 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+package require Tk
+package require ::Utility
+package provide ::Utility::tk 1.0
+
+namespace eval ::Utility::tk {;
+
+namespace export -clear *
+
+## PROBLEM HERE
+## 
+## Only uncomment one of the following namespace import lines
+##
+
+## This is what I theoretically need, but it causes the Abort in
+## regular wish.  This works for wish with TCL_MEM_DEBUG.
+#namespace import -force ::Utility::get_opts ::Utility::highlight
+
+## This works, but is essentially useless in my situation
+#namespace import -force ::Utility::expand::* ::Utility::dump::*
+
+## This works too, but is silly
+after idle [namespace code [list namespace import -force \
+	::Utility::highlight ::Utility::get_opts]]
+
+## This causes constant Bus Error on startup with regular wish
+## but the Abort with debugging wish.
+#namespace import -force ::Utility::*
+
+## The abort message mentioned above is:
+
+#DeleteImportedCmd: did not find cmd in real cmd's list of import references
+#Abort
+
+## If I try loading the above interactively as opposed to the tour at
+## command line, I get a seg fault instead of a bus error.
+
+##
+## YOU CAN IGNORE THE REST
+##
+
+# warn --
+#
+#   Simple warning alias to ease programming
+#
+# Arguments:
+#   msg		The warning message to display
+# Results:
+#   Returns nothing important.
+#
+proc warn {msg} {
+    bell
+    tk_dialog .__warning Warning $msg warning 0 OK
+}
+
+# place_window --
+#   place a toplevel at a particular position
+# Arguments:
+#   toplevel	name of toplevel window
+#   ?placement?	pointer ?center? ; places $w centered on the pointer
+#		widget widget_name ; centers $w over widget_name
+#		defaults to placing toplevel in the middle of the screen
+#   ?anchor?
+# Results:
+#   Returns nothing
+#
+proc place_window {w {placement ""} {anchor ""}} {
+    wm withdraw $w
+    update idletasks
+    switch -glob -- $placement {
+	p*	{ ## place at POINTER (centered is $anchor == center)
+	    if {[string match "c*" $anchor]} {
+		wm geometry $w +[expr \
+			{[winfo pointerx $w]-[winfo width $w]/2}]+[expr \
+			{[winfo pointery $w]-[winfo height $w]/2}]
+	    } else {
+		wm geometry $w +[winfo pointerx $w]+[winfo pointery $w]
+	    }
+	}
+	w*	{ ## center about WIDGET $anchor
+	    wm geometry $w +[expr {[winfo rootx $anchor]+([winfo width \
+		    $anchor]-[winfo width $w])/2}]+[expr {[winfo rooty \
+		    $anchor]+([winfo height $anchor]-[winfo height $w])/2}]
+	}
+	default	{
+	    wm geometry $w +[expr {([winfo screenwidth $w]-\
+		    [winfo reqwidth $w])/2}]+[expr \
+		    {([winfo screenheight $w]-[winfo reqheight $w])/2}]
+	}
+    }
+    wm deiconify $w
+}
+
+## Centers the canvas around points x & y
+##
+## Unoptimized, this looks like:
+##    set xtenth [expr .10 * [winfo width $w]]
+##    set ytenth [expr .10 * [winfo height $w]]
+##    set X [expr [winfo width $w] / 2]
+##    set Y [expr [winfo height $w] / 2]
+##    set x1 [expr round(($x-$X)/$xtenth)]
+##    set y1 [expr round(($y-$Y)/$ytenth)]
+##    $w xview scroll $x1 units
+##    $w yview scroll $y1 units
+##
+proc canvas_center {w x y} {
+    $w xview scroll [expr {round(10.0*$x/[winfo width $w]-5)}] units
+    $w yview scroll [expr {round(10.0*$y/[winfo height $w]-5)}] units
+}
+
+## "see" method alternative for canvas
+## Aligns the named item as best it can in the middle of the screen
+## Behavior depends on whether -scrollregion is set
+##
+## c    - a canvas widget
+## item - a canvas tagOrId
+proc canvas_see {c item} {
+    set box [$c bbox $item]
+    if {[string match {} $box]} return
+    if {[string match {} [$c cget -scrollregion]]} {
+	## People really should set -scrollregion you know...
+	foreach {x y x1 y1} $box {
+	    set x [expr {round(2.5*($x1+$x)/[winfo width $c])}]
+	    set y [expr {round(2.5*($y1+$y)/[winfo height $c])}]
+	}
+	$c xview moveto 0
+	$c yview moveto 0
+	$c xview scroll $x units
+	$c yview scroll $y units
+    } else {
+	## If -scrollregion is set properly, use this
+	foreach {x y x1 y1} $box {top btm} [$c yview] {left right} [$c xview] \
+		{p q xmax ymax} [$c cget -scrollregion] {
+	    set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}]
+	    set ypos [expr {(($y1+$y)/2.0)/$ymax - ($btm-$top)/2.0}]
+	}
+	$c xview moveto $xpos
+	$c yview moveto $ypos
+    }
+}
+
+## Set cursor of widget $w and its descendants to $cursor
+## Ignores {} cursors
+proc cursor_set {w cursor} {
+    variable CURSOR
+    if {[string compare {} [set CURSOR($w) [$w cget -cursor]]]} {
+	$w config -cursor $cursor
+    } else {
+	unset CURSOR($w)
+    }
+    foreach child [winfo children $w] { cursor_set $child $cursor }
+}
+
+## Restore cursor based on CURSOR($w) for $w and its descendants
+## $cursor is the default cursor (if none was cached)
+proc cursor_restore {w {cursor {}}} {
+    variable CURSOR
+    if {[info exists CURSOR($w)]} {
+	$w config -cursor $CURSOR($w)
+    } else {
+	$w config -cursor $cursor
+    }
+    foreach child [winfo children $w] { cursor_restore $child $cursor }
+}
+
+# highlight_dialog --
+#
+#   creates minimal dialog interface to highlight
+#
+# Arguments:
+#   w	text widget
+#   str	optional seed string for HIGHLIGHT(string)
+# Results:
+#   Returns null.
+#
+proc highlight_dialog {w {str {}}} {
+    variable HIGHLIGHT
+
+    set namesp [namespace current]
+    set var ${namesp}::HIGHLIGHT
+    set base $w.__highlight
+    if {![winfo exists $base]} {
+	toplevel $base
+	wm withdraw $base
+	wm title $base "Find String"
+
+	pack [frame $base.f] -fill x -expand 1
+	label $base.f.l -text "Find:"
+	entry $base.f.e -textvariable ${var}($w,string)
+	pack [frame $base.opt] -fill x
+	checkbutton $base.opt.c -text "Case Sensitive" \
+		-variable ${var}($w,nocase)
+	checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp)
+	pack $base.f.l -side left
+	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
+	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
+	pack [frame $base.btn] -fill both
+	button $base.btn.fnd -text "Find" -width 6
+	button $base.btn.clr -text "Clear" -width 6
+	button $base.btn.dis -text "Dismiss" -width 6
+	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
+		-side left -fill both
+
+	focus $base.f.e
+
+	bind $base.f.e <Return> [list $base.btn.fnd invoke]
+	bind $base.f.e <Escape> [list $base.btn.dis invoke]
+    }
+    ## FIX namespace
+    $base.btn.fnd config -command [namespace code \
+	    "highlight [list $w] \[set ${var}($w,string)\] \
+	    \[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \
+	    \[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \
+	    -tag __highlight -color [list yellow]"]
+    $base.btn.clr config -command \
+	    "[list $w] tag remove __highlight 1.0 end;\
+	    set [list ${var}($w,string)] {}"
+    $base.btn.dis config -command \
+	    "[list $w] tag remove __highlight 1.0 end;\
+	    wm withdraw [list $base]"
+    if {[string compare {} $str]} {
+	set ${var}($w,string) $str
+	$base.btn.fnd invoke
+    }
+
+    if {[string compare normal [wm state $base]]} {
+	wm deiconify $base
+    } else {
+	raise $base
+    }
+    $base.f.e select range 0 end
+}
+
+
+}; # end namespace ::Utility::Tk