System.Data.SQLite
Artifact Content
Not logged in

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"}]
}