System.Data.SQLite
Artifact Content
Not logged in

Artifact ef7735137ba554231f3e4ddb170a3f05d926a5d9:


###############################################################################
#
# info.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Information 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 returns the list of options that were used when
  #       compiling the Eagle core library.
  #
  proc getCompileInfo {} {
    #
    # NOTE: Return the important compile-time information for use by the
    #       setup or other callers.
    #
    return [expr {[isEagle] ? [lappend result \
        TimeStamp $::eagle_platform(timeStamp) \
        ImageRuntimeVersion $::eagle_platform(imageRuntimeVersion) \
        ModuleVersionId $::eagle_platform(moduleVersionId) \
        CompileOptions $::eagle_platform(compileOptions)] : ""}]
  }

  #
  # NOTE: This procedure returns the specified Eagle platform information,
  #       if available; otherwise a default value is returned instead.
  #
  proc getPlatformInfo { name {default ""} } {
    #
    # NOTE: Return the important platform information for use by the test
    #       suite or other callers.
    #
    return [expr {[isEagle] && [info exists ::eagle_platform($name)] && \
        [string length [string trim $::eagle_platform($name)]] > 0 ? \
        $::eagle_platform($name) : $default}]
  }

  #
  # NOTE: This procedure returns the name of the first loaded plugin that
  #       matches the specified pattern.
  #
  proc getPluginName { pattern } {
    #
    # NOTE: This should work properly in both Tcl and Eagle.
    #
    foreach loaded [info loaded] {
      if {[regexp -- $pattern [lindex $loaded end]]} then {
        return [lindex $loaded 1]
      }
    }

    return ""
  }

  #
  # NOTE: This procedure returns the fully qualified file name of the first
  #       loaded plugin that matches the specified pattern.
  #
  proc getPluginPath { pattern } {
    #
    # NOTE: This should work properly in both Tcl and Eagle.
    #
    foreach loaded [info loaded] {
      if {[regexp -- $pattern [lindex $loaded end]]} then {
        return [lindex $loaded 0]
      }
    }

    return ""
  }

  #
  # NOTE: This procedure returns the fully qualified directory name where new
  #       packages targeting the interpreter should be installed.  The return
  #       values of this procedure are subject to change in future releases.
  #
  proc getPackageInstallPath { {packageName ""} {temporaryPrefix ""} } {
    #
    # NOTE: Skip using the Tcl library location if that has been explicitly
    #       forbidden.
    #
    if {![info exists ::no(getPackageInstallPath)]} then {
      #
      # NOTE: First, check if the Tcl library variable exists and its location
      #       exists.  The location may refer to a file.
      #
      global tcl_library

      if {[info exists tcl_library]} then {
        #
        # NOTE: What is the parent directory for the Tcl library location?  If
        #       the Tcl library location was a file, it should be a directory;
        #       if it was already a directory, it should still be one.  Either
        #       way, the new (directory) location must be writable.
        #
        set directory [file dirname $tcl_library]

        if {[file exists $directory] && [file isdirectory $directory] && \
            [file writable $directory]} then {
          #
          # NOTE: Ok, all checks passed, return the location.  Callers of this
          #       procedure should generally not put files directly within it;
          #       instead, they should create a sub-directory within it, named
          #       appropriately.  If a package name was supplied by the caller
          #       it will be used.  In that case, the resulting directory will
          #       be created if necessary.
          #
          if {[string length $packageName] > 0} then {
            set directory [file join $directory $packageName]
            file mkdir $directory
          }

          return $directory
        }
      }
    }

    #
    # NOTE: Next, since the fallback location requires the test package, load
    #       it now.
    #
    package require Eagle.Test

    #
    # NOTE: Return the temporary directory as the fallback location.  Callers
    #       of this procedure should generally not put files directly within
    #       it; instead, they should create a sub-directory within it, named
    #       appropriately.  If a temporary prefix was supplied by the caller
    #       it will be used.  In that case, the resulting directory will be
    #       created if necessary.
    #
    set directory [getTemporaryPath]

    if {[string length $temporaryPrefix] > 0} then {
      set directory [file join \
          $directory [appendArgs $temporaryPrefix - \
          [pid] - [string trim [clock seconds] -]]]

      file mkdir $directory
    }

    return $directory
  }

  #
  # NOTE: This procedure returns the Eagle core library base path, e.g. a
  #       value like "C:\Eagle" when loaded from "C:\Eagle\bin\Eagle.dll".
  #
  proc getBasePath {} {
    set assembly [object invoke -flags +NonPublic \
        Eagle._Components.Private.GlobalState GetAssembly]

    return [object invoke -flags +NonPublic \
        Eagle._Components.Private.PathOps GetBasePath $assembly \
        [file dirname [lindex [info assembly] 1]]]
  }

  #
  # NOTE: This procedure returns the flags for the first loaded plugin that
  #       matches the specified pattern.
  #
  proc getPluginFlags { pattern } {
    foreach loaded [info loaded] {
      set plugin [lindex $loaded end]

      if {[regexp -- $pattern $plugin]} then {
        return [string map [list , " "] \
            [getDictionaryValue [info plugin $plugin] flags]]
      }
    }

    return [list]
  }

  #
  # NOTE: This procedure returns non-zero if the Eagle Native Package for
  #       Tcl (Garuda) is loaded into the primary native Tcl interpreter.
  #
  proc haveGaruda { {varName ""} } {
    #
    # NOTE: Check for a variable name to place the Garuda package Id into.
    #
    if {[string length $varName] > 0} then {
      upvar 1 $varName packageId
    }

    #
    # NOTE: Is the Eagle Package for Tcl (Garuda) available?  This check
    #       is different in Eagle and Tcl.
    #
    if {[isEagle]} then {
      return [expr {[llength [info commands tcl]] > 0 && [tcl ready] && \
          [catch {tcl eval [tcl master] {package present Garuda}}] == 0 && \
          [catch {tcl eval [tcl master] {garuda packageid}} packageId] == 0}]
    } else {
      return [expr {[catch {package present Garuda}] == 0 && \
          [catch {garuda packageid} packageId] == 0}]
    }
  }

  #
  # NOTE: This procedure returns non-zero if the specified name represents
  #       a thread managed by the native Tcl integration subsystem of Eagle.
  #
  proc isTclThread { name } {
    #
    # NOTE: For now, this check only works in Eagle.
    #
    set result false

    if {[isEagle]} then {
      catch {
        if {[llength [info commands tcl]] > 0 && [tcl ready] && \
            [lsearch -exact -- [tcl threads] $name] != -1} then {
          #
          # NOTE: The name specified by the caller appears in the
          #       list of Tcl threads for this Eagle interpreter.
          #
          set result true
        }
      }
    }

    return $result
  }

  #
  # NOTE: Provide the Eagle "info" package to the interpreter.
  #
  package provide Eagle.Information \
    [expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}