###############################################################################
#
# object.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Object 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 accepts two arguments containing the flag string
# that are based on an enumerated CLR type. Flag values that are
# contained in these two arguments are combined and returned as
# the result. The third flag string argument contains the flags
# to exclude from the result.
#
proc combineFlags { flags1 flags2 {flags3 ""} {noCase false} } {
#
# NOTE: This should work properly in both Tcl and Eagle.
#
set result [list]
set notFlags [list]
if {[string length $flags3] > 0} then {
foreach flag [split $flags3 ", "] {
set flag [string trim $flag]
if {[string length $flag] > 0} then {
lappend notFlags $flag
}
}
}
foreach flags [list $flags1 $flags2] {
foreach flag [split $flags ", "] {
set flag [string trim $flag]
if {[string length $flag] > 0} then {
set addFlag false
if {[llength $notFlags] > 0} then {
set command [list lsearch -exact]
if {$noCase} then {
lappend command -nocase
}
lappend command -- $notFlags $flag
if {[eval $command] == -1} then {
set addFlag true
}
} else {
set addFlag true
}
if {$addFlag} then {
lappend result $flag
}
}
}
}
return [join $result ,]
}
#
# NOTE: This procedure returns the type name of the return type for the
# specified CLR member.
#
proc getReturnType { object member } {
if {[string length $object] == 0} then {
return ""
}
if {[string length $member] == 0} then {
return ""
}
set code [catch {
object foreach -alias memberInfo \
[object invoke -noinvoke $object $member] {
#
# NOTE: Use the member type to determine which property contains
# the type information we want to return.
#
switch -exact -- [$memberInfo MemberType] {
Field {
return [$memberInfo FieldType.AssemblyQualifiedName]
}
Method {
return [$memberInfo ReturnType.AssemblyQualifiedName]
}
Property {
return [$memberInfo PropertyType.AssemblyQualifiedName]
}
default {
return ""
}
}
}
} result]
#
# NOTE: If no error was raised above, return the result; otherwise,
# return an empty string to indicate a general failure.
#
return [expr {$code == 2 ? $result : ""}]
}
#
# NOTE: This procedure returns the default value for the specified CLR type.
#
proc getDefaultValue { typeName } {
if {[llength [info commands object]] == 0} then {
return ""
}
if {[string length $typeName] == 0} then {
return ""
}
set type [object invoke -create -alias Utility GetType $typeName]
if {[string length $type] == 0} then {
return ""
}
return [expr {[$type IsValueType] ? 0 : "null"}]
}
#
# NOTE: This procedure returns a string obtained by using the specified
# value as an opaque object handle -OR- a default value (e.g. an
# empty string) if the value is not a valid opaque object handle.
#
proc getStringFromObjectHandle { value {default ""} } {
if {[isNonNullObjectHandle $value]} then {
return [object invoke $value ToString]
}
if {[string length $default] > 0} then {
return $default
}
return $value
}
#
# NOTE: This procedure returns non-zero if the specified value can be used
# as an opaque object handle.
#
proc isObjectHandle { value } {
set pattern [string map [list \\ \\\\ \[ \\\[ \] \\\]] $value]
set objects [info objects $pattern]
if {[llength $objects] == 1 && [lindex $objects 0] eq $value} then {
return true
}
return false
}
#
# NOTE: This procedure returns non-zero if the specified value can be used
# as an opaque object handle -AND- the value does not represent a null
# value.
#
proc isNonNullObjectHandle { value } {
global null
return [expr {[isObjectHandle $value] && $value ne $null}]
}
#
# NOTE: This procedure returns non-zero if the specified name represents
# a valid CLR type name.
#
proc isManagedType { name } {
if {[llength [info commands object]] > 0} then {
if {![isObjectHandle $name]} then {
if {[catch {
object members -matchnameonly -nameonly -pattern Equals $name
} result] == 0 && $result eq "Equals"} then {
return true
}
}
}
return false
}
#
# NOTE: This procedure returns non-zero if the specified name is usable
# as a CLR type name.
#
proc canGetManagedType { name {varName ""} } {
if {[llength [info commands object]] > 0} then {
if {![isObjectHandle $name]} then {
set cultureInfo [object invoke Interpreter.GetActive CultureInfo]
set type null
set code [object invoke -create -alias -flags +NonPublic \
Value GetType "" $name null null None $cultureInfo type]
if {[$code ToString] eq "Ok"} then {
if {[string length $varName] > 0} then {
upvar 1 $varName typeName
}
set typeName [$type AssemblyQualifiedName]
if {[isManagedType $typeName]} then {
return true
}
}
}
}
return false
}
#
# NOTE: This procedure evaluates a script asynchronously and optionally
# notifies another script upon its completion. The first argument
# is the notification script; if an empty string, there will be no
# notification when asynchronous script evaluation is completed.
# If there is exactly one more argument, it is evaluated verbatim;
# otherwise, all remaining arguments are concatenated via [concat]
# and evaluated asynchronously. If the script cannot be submitted
# for asynchronous evaluation, a script error will be raised.
#
proc evalAsync { doneScript args } {
#
# NOTE: This procedure requires the [object] command in order to work.
# If it is not available, bail out now.
#
if {[llength [info commands object]] == 0} then {
error "cannot eval async: missing \[object\] command"
}
#
# NOTE: If the core library was not compiled with thread-safety enabled,
# this procedure cannot be used because it could corrupt the state
# of the interpreter.
#
if {[lsearch -exact -- \
$::eagle_platform(compileOptions) THREADING] == -1} then {
error "cannot eval async: library missing THREADING compile-option"
}
#
# NOTE: If there is more than one script optional argument, use [concat]
# to build up the final script; otherwise, use the single argument
# verbatim. This mirrors the behavior of [eval].
#
if {[llength $args] > 1} then {
set asyncScript [concat $args]
} else {
set asyncScript [lindex $args 0]
}
#
# NOTE: Is there a script to be evaluated when the asynchronous script
# evaluation is complete? If so, build an anonymous procedure
# that wraps it; otherwise, set the callback argument to null, so
# the core marshaller will handle the lack of a callback correctly.
# The context argument will be added to this script prior to it
# being evaluated; however, it is not actually used by this script.
# The -identifier option is NOT actually processed by the library;
# however, it is necessary here to avoid having multiple calls to
# this procedure collide with each other when attempting to remove
# their callbacks during cleanup.
#
if {[string length $doneScript] > 0} then {
#
# NOTE: If the core library was compiled without dynamic delegates,
# this procedure cannot be used when there is a callback, due
# to the AsynchronousCallback delegate type being unsupported.
#
if {[lsearch -exact -- \
$::eagle_platform(compileOptions) EMIT] == -1} then {
error "cannot eval async: library missing EMIT compile-option"
}
set callback [list -identifier [expr {random()}] -callbackflags \
{+ResetCancel FireAndForget} -- apply [list [list script context] \
{uplevel 1 $script}] $doneScript]
} else {
set callback null
}
#
# NOTE: Initialize the local variable that will be used to receive the
# script error, if any.
#
set error null
#
# NOTE: Attempt to submit the script for asynchonous evaluation. Use
# the dynamic callback mechanism with the anonymous procedure we
# constructed above.
#
set code [object invoke -verbose \
-marshalflags +DynamicCallback -- Interpreter.GetActive \
EvaluateScript $asyncScript $callback null error]
#
# NOTE: Check the return code, which only indicates if the script was
# actually submitted for asynchronous evaluation, to make sure
# it was successful. If not, raise a script error.
#
if {$code ne "Ok"} then {
error [getStringFromObjectHandle $error]
}
#
# NOTE: Upon success, return an empty string. The actual script result
# will be sent to the callback script, if any.
#
return ""
}
#
# NOTE: Provide the Eagle "object" package to the interpreter.
#
package provide Eagle.Object \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}
