Artifact
3d73e7479877edb7cdcd1c6de0f897fdcef3d721:
###############################################################################
#
# compat.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle [Native Tcl] Compatibility Package File
#
# Copyright (c) 2007-2012 by Joe Mistachkin. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
#
###############################################################################
#
# NOTE: Use our own namespace here because even though we do not directly
# support namespaces ourselves, we do not want to pollute the global
# namespace if this script actually ends up being evaluated in Tcl.
#
namespace eval ::Eagle {
#
# NOTE: This procedure attempts to query the size from the host, in terms
# of columns and rows; failing that, it returns a reasonable default
# value. Generally, this procedure is intended to be used only by
# the other procedures in this file.
#
proc getHostSize {} {
if {[catch {host size} result] == 0} then {
return $result
}
return [list 80 25]; # TODO: Good default?
}
#
# NOTE: This procedure emulates the behavior of the native Tcl [parray]
# procedure: it prints (to stdout) the names and values contained
# in the specified array, or a subset of those names based on the
# specified pattern.
#
proc parray { a args } {
if {[llength $args] > 2} then {
error "wrong # args: should be \"parray a ?pattern?\""
}
upvar 1 $a array
if {![array exists array]} {
error [appendArgs \" $a "\" isn't an array"]
}
set names [lsort [eval array names array $args]]
set maxLength 0
foreach name $names {
set length [string length $name]
if {$length > $maxLength} {
set maxLength $length
}
}
set stringMap [list \b " " \t " " \r \xB6 \n \xB6]
set maxLength [expr {$maxLength + [string length $a] + 2}]
set hostLength [lindex [getHostSize] 0]
set valueLength [expr {$hostLength - $maxLength - 5}]; # " ... "
foreach name $names {
#
# NOTE: Format the array element name for display.
#
set nameString [string map $stringMap [appendArgs $a ( $name )]]
#
# NOTE: If the value by itself is too long to fit on one host line,
# just truncate and ellipsis it.
#
set valueString [string map $stringMap $array($name)]
if {[string length $valueString] > $valueLength} then {
set valueString [appendArgs [string range $valueString 0 \
[expr {$valueLength - 4}]] " ..."]
}
#
# HACK: Mono does not currently support calling the String.Format
# overload that takes a variable number of arguments via
# reflection (Mono bug #636939).
#
if {![isMono]} then {
set line [string format -verbatim -- [appendArgs "\{0,-" \
$maxLength "\} = {1}"] $nameString $valueString]
} elseif {[llength [info commands object]] > 0} then {
set line [object invoke String Format [appendArgs "\{0,-" \
$maxLength "\} = {1}"] $nameString $valueString]
} else {
set line [format [appendArgs "%-" $maxLength "s = %s"] \
$nameString $valueString]
}
puts stdout $line
}
}
#
# NOTE: This procedure emulates the behavior of the native Tcl [parray]
# procedure: it prints (to stdout) the names and values contained
# in the specified dictionary, or a subset of those names based on
# the specified pattern.
#
proc pdict { d } {
set maxLength 0
foreach {name value} $d {
set length [string length $name]
if {$length > $maxLength} {
set maxLength $length
}
}
set hostLength [lindex [getHostSize] 0]
set valueLength [expr {$hostLength - $maxLength - 5}]; # " ... "
foreach {name value} $d {
#
# NOTE: If the value by itself is too long to fit on one host line,
# just truncate and ellipsis it.
#
set valueString $value
if {[string length $valueString] > $valueLength} then {
set valueString [appendArgs [string range $valueString 0 \
[expr {$valueLength - 4}]] " ..."]
}
#
# HACK: Mono does not currently support calling the String.Format
# overload that takes a variable number of arguments via
# reflection (Mono bug #636939).
#
if {![isMono]} then {
set line [string format -verbatim -- [appendArgs "\{0,-" \
$maxLength "\} = {1}"] $name $valueString]
} elseif {[llength [info commands object]] > 0} then {
set line [object invoke String Format [appendArgs "\{0,-" \
$maxLength "\} = {1}"] $name $valueString]
} else {
set line [format [appendArgs "%-" $maxLength "s = %s"] \
$name $valueString]
}
puts stdout $line
}
}
#
# NOTE: This procedure emulates the behavior of the native Tcl [test]
# command as provided by its bundled "tcltest" package. It is
# designed to automatically detect and handle the type of test
# specified by the various arguments, which may be an old style
# test or a new style test.
#
proc test { name description args } {
#
# NOTE: Determine if the caller is trying to run an old style or
# new style test and use the appropriate command.
#
if {[string index [lindex $args 0] 0] eq "-"} then {
#
# NOTE: New style test, use [test2] command.
#
set command test2
} else {
#
# NOTE: Old style test, use [test1] command.
#
set command test1
}
return [uplevel 1 [list $command $name $description] $args]
}
#
# NOTE: This procedure emulates the behavior of the native Tcl [tclLog]
# command.
#
proc tclLog { string } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
catch {puts stderr $string}
}
#
# NOTE: Provide the Eagle "Tcl compatibility" package to the interpreter.
#
package provide Eagle.Tcl.Compatibility \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}