System.Data.SQLite

Artifact [7bb8658e55]
Login

Artifact 7bb8658e55eeb37c6c2362a81e45cd0e574e0ee6:


###############################################################################
#
# pkgt.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Package Toolset 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 sets up the default values for all configuration
  #       parameters used by this package.  If the force argument is non-zero,
  #       any existing values will be overwritten and set back to their
  #       default values.
  #
  proc setupPackageToolsetVars { force } {
    #
    # NOTE: Using the [getAuxiliaryBaseUri] procedure requires the update
    #       package.
    #
    # NOTE: The base URI used to build the URIs for the Package Client
    #       Toolset downloads.
    #
    variable baseUri; # DEFAULT: [getAuxiliaryBaseUri] -OR- https://urn.to/r

    if {$force || ![info exists baseUri]} then {
      if {[isEagle]} then {
        set baseUri [getAuxiliaryBaseUri]
      } else {
        set baseUri https://urn.to/r
      }
    }

    #
    # NOTE: The URN, relative to the base URI, where the Package Client
    #       Toolset may be downloaded.
    #
    variable packageToolsetUrn; # DEFAULT: pkg_client_only

    if {$force || ![info exists packageToolsetUrn]} then {
      set packageToolsetUrn pkg_client_only
    }

    #
    # NOTE: The URI where the Package Client Toolset may be downloaded.
    #
    variable packageToolsetUri; # DEFAULT: ${baseUri}/${packageToolsetUrn}

    if {$force || ![info exists packageToolsetUri]} then {
      set packageToolsetUri {${baseUri}/${packageToolsetUrn}}
    }

    #
    # NOTE: The URN, relative to the base URI, where the TclKit DLL for
    #       a particular platform may be downloaded.
    #
    variable tclKitDllUrn; # DEFAULT: tclkit_dll_${platform}

    if {$force || ![info exists tclKitDllUrn]} then {
      set tclKitDllUrn {tclkit_dll_${platform}}
    }

    #
    # NOTE: The URI where the TclKit DLL for a particular platform may
    #       be downloaded.
    #
    variable tclKitDllUri; # DEFAULT: ${baseUri}/${urn}

    if {$force || ![info exists tclKitDllUri]} then {
      set tclKitDllUri {${baseUri}/${urn}}
    }

    #
    # NOTE: The URN, relative to the base URI, where the Harpy and Badge
    #       plugins for a particular build may be downloaded.
    #
    variable securityToolsetUrn; # DEFAULT: security_toolset_${platform}

    if {$force || ![info exists securityToolsetUrn]} then {
      set securityToolsetUrn {security_toolset_${platform}}
    }

    #
    # NOTE: The URI where the Harpy and Badge plugins for a particular
    #       build may be downloaded.
    #
    variable securityToolsetUri; # DEFAULT: ${baseUri}/${urn}

    if {$force || ![info exists securityToolsetUri]} then {
      set securityToolsetUri {${baseUri}/${urn}}
    }

    #
    # NOTE: The URN, relative to the base URI, where license certificate
    #       requests should be sent.
    #
    variable licenseUrn; # DEFAULT: get_license_01

    if {$force || ![info exists licenseUrn]} then {
      set licenseUrn get_license_01
    }

    #
    # NOTE: The URI where license certificate requests should be sent.
    #
    variable licenseUri; # DEFAULT: ${baseUri}/${urn}

    if {$force || ![info exists licenseUri]} then {
      set licenseUri {${baseUri}/${urn}}
    }

    #
    # NOTE: The URN, relative to the base URI, where script evaluation
    #       requests should be submitted to the "safe" sandbox.
    #
    variable sandboxEvalUrn; # DEFAULT: eval_01

    if {$force || ![info exists sandboxEvalUrn]} then {
      set sandboxEvalUrn eval_01
    }

    #
    # NOTE: The URI where script evaluation requests should be submitted
    #       to the "safe" sandbox.
    #
    variable sandboxEvalUri; # DEFAULT: ${baseUri}/${urn}

    if {$force || ![info exists sandboxEvalUri]} then {
      set sandboxEvalUri {${baseUri}/${urn}}
    }
  }

  #
  # NOTE: This procedure attempts to download and extract the Package Client
  #       Toolset.  The optional channel argument is the output channel where
  #       diagnostic information is sent.  The optional quiet argument should
  #       be non-zero to prevent diagnostic information from being emitted.
  #       This procedure may raise script errors.  The return value is the
  #       full path to the directory that should be added to the auto-path.
  #
  proc downloadAndExtractPackageClientToolset {
          {channel stdout} {quiet false} } {
    setupPackageToolsetVars false

    variable baseUri
    variable packageToolsetUri
    variable packageToolsetUrn

    package require Eagle.Test
    package require Eagle.Unzip

    set extractRootDirectory [getPackageInstallPath pkgd ea-pt-di]

    set uri [subst $packageToolsetUri]
    set fileName [getTemporaryFileName]

    if {[isEagle]} then {
      uri download $uri $fileName
    } else {
      package require Eagle.Tools.Common

      namespace import \
          ::Eagle::Tools::Common::getFileViaHttp \
          ::Eagle::Tools::Common::writeFile

      set data [getFileViaHttp $uri 20 $channel $quiet -binary true]

      writeFile $fileName $data
    }

    set extractDirectory [extractZipArchive \
        $fileName $extractRootDirectory true]

    return [file join $extractDirectory pkgr_an_d client 1.0 neutral]
  }

  #
  # NOTE: This procedure attempts to load (via [package require]) the package
  #       client toolset.  It is designed to be used in conjunction with the
  #       [downloadAndExtractPackageClientToolset] procedure, above.  Support
  #       is included for specifying an extra auto-path directory and API key
  #       to use.  By default, the [package unknown] handler is hooked to add
  #       the remote package repository lookup functionality.  Eagle supports
  #       extra script security via signed script certificates, which will be
  #       enabled by default, unless it is unavailable.
  #
  proc loadPackageClientToolset {
          {directory auto} {apiKeys ""} {hookUnknown true} {enableSecurity true}
          {strictSecurity false} {debug false} } {
    #
    # NOTE: When running in Eagle, namespace support must be available and
    #       enabled.
    #
    if {[isEagle] && ![namespace enable]} then {
      error "namespace support must be enabled"
    }

    #
    # NOTE: Does the caller want automatic discovery of the directory that
    #       contains the (downloaded?) package client toolset?  Currently,
    #       this only works on Windows and searches the temporary download
    #       location, which normally obtains its value from the environment
    #       variable TEMP.
    #
    if {$directory eq "auto"} then {
      #
      # NOTE: First, before doing anything else, see if the package client
      #       toolset is already installed somewhere it can be loaded from.
      #
      set needDirectory true

      if {[isEagle]} then {
        #
        # NOTE: Force Eagle to find *ALL* available package index files.
        #       This must be done in the global scope so that the special
        #       global variable 'dir' set by the package index loading
        #       subsystem can be accessed.  Use [catch] here just in case
        #       a package index file raises a script error.
        #
        catch {
          uplevel #0 [list package scan -host -normal -refresh]
        }
      } else {
        #
        # HACK: Force Tcl to find *ALL* available package index files.
        #       Without this, checking for the available versions of a
        #       package using [package versions] likely will not succeed
        #       unless the package is already loaded.  Use [catch] here
        #       just in case a package index file raises a script error.
        #
        catch {
          package require [appendArgs \
              bogus_package_ [string trim [clock seconds] -]]
        }
      }

      #
      # NOTE: Check and see if the package repository client is a known
      #       package now.  If so, there is no need to search directories
      #       for it.
      #
      if {[llength [package versions Eagle.Package.Repository]] > 0} then {
        set needDirectory false
      }

      #
      # NOTE: Is searching for temporary download directories required at
      #       this point?
      #
      if {$needDirectory} then {
        if {![isWindows]} then {
          error "directory discovery not supported on this platform"
        }

        set extractRootDirectory [getPackageInstallPath]

        foreach directory [findDirectoriesRecursive \
            [file join $extractRootDirectory pkgr_an_d]] {
          #
          # NOTE: Reset directory we just found to include the necessary
          #       sub-directory components for the actual client files
          #       and then stop, thereby selecting the first match.
          #
          set directory [file join $directory client 1.0 neutral]; break
        }
      }

      #
      # NOTE: If no directory was found, just clear the directory name,
      #       which will cause auto-path modification(s) to be skipped.
      #
      if {$directory eq "auto"} then {
        set directory ""
      }
    }

    #
    # NOTE: If there is a directory specified by the caller -OR- found
    #       via automatic directory discovery, add it to the auto-path
    #       now.
    #
    if {[string length $directory] > 0} then {
      #
      # NOTE: Only modify the auto-path if the directory is not already
      #       present.  This prevents needless variable trace execution
      #       that rescans the various auto-path directories.
      #
      if {![info exists ::auto_path] || \
          [lsearch -exact $::auto_path $directory] == -1} then {
        lappend ::auto_path $directory
      }
    }

    #
    # NOTE: If the caller wants to enable extra diagnostic information,
    #       set the appropriate environment variables now.
    #
    if {$debug} then {
      set ::env(DEBUG_PKGR) 1; set ::env(DEBUG_PKGD) 1
    }

    #
    # NOTE: If the caller specified API keys, add them to the configured
    #       list of API keys for the package repository client now.  This
    #       uses a special global variable.
    #
    if {[llength $apiKeys] > 0} then {
      eval lappend ::pkgr_api_keys $apiKeys
    }

    #
    # NOTE: If the caller wants to enable the extra Eagle script security,
    #       attempt to do that now.  Only treat a failure here as fatal if
    #       the caller said so.
    #
    if {[isEagle] && $enableSecurity} then {
      if {[catch {
        uplevel 1 [list source enableSecurity]
      } error] && $strictSecurity} then {
        error $error
      }
    }

    #
    # NOTE: In Eagle, to actually enable make use of the [package unknown]
    #       handler, an interpreter flag must be disabled.  If necessary,
    #       do that now.
    #
    if {[isEagle] && $hookUnknown} then {
      object invoke -flags +NonPublic -objectflags +AutoFlagsEnum \
          Interpreter.GetActive interpreterFlags -NoPackageUnknown
    }

    #
    # NOTE: Finally, attempt to actually load the package repository client.
    #       This may fail for a number of reasons.  The most likely failure
    #       case is when the directory containing the package is not found;
    #       however, there are other possible failure modes.
    #
    package require Eagle.Package.Repository
  }

  #
  # NOTE: This procedure attempts to download and extract a native TclKit DLL
  #       for the current platform.  The optional channel argument is the
  #       output channel where diagnostic information is sent.  The optional
  #       quiet argument should be non-zero to prevent diagnostic information
  #       from being emitted.  This procedure may raise script errors.  The
  #       return value is the full path to the native TclKit DLL file.
  #
  proc downloadAndExtractNativeTclKitDll {
          {channel stdout} {quiet false} } {
    setupPackageToolsetVars false

    variable baseUri
    variable tclKitDllUri
    variable tclKitDllUrn

    package require Eagle.Test
    package require Eagle.Unzip

    set platform [machineToPlatform $::tcl_platform(machine) true]

    set extractRootDirectory [getPackageInstallPath \
        [appendArgs KitDll_ $platform] ea-td-di]

    set urn [subst $tclKitDllUrn]; set uri [subst $tclKitDllUri]
    set fileName [getTemporaryFileName]

    if {[isEagle]} then {
      uri download $uri $fileName
    } else {
      package require Eagle.Tools.Common

      namespace import \
          ::Eagle::Tools::Common::getFileViaHttp \
          ::Eagle::Tools::Common::writeFile

      set data [getFileViaHttp $uri 20 $channel $quiet -binary true]

      writeFile $fileName $data
    }

    set extractDirectory [extractZipArchive \
        $fileName $extractRootDirectory true]

    return [lindex [glob -nocomplain \
        [file join $extractDirectory lib *[info sharedlibextension]]] 0]
  }

  #
  # NOTE: This procedure attempts to download and extract the Security Toolset,
  #       which includes the Harpy and Badge plugins.  The optional channel
  #       argument is the output channel where diagnostic information is sent.
  #       The optional quiet argument should be non-zero to prevent diagnostic
  #       information from being emitted.  This procedure may raise script
  #       errors.  The return value is the full path to a directory that should
  #       contain the "Harpy1.0" and "Badge1.0" plugin directories.
  #
  proc downloadAndExtractSecurityToolset {
          {channel stdout} {quiet false} } {
    setupPackageToolsetVars false

    variable baseUri
    variable securityToolsetUri
    variable securityToolsetUrn

    package require Eagle.Test
    package require Eagle.Unzip

    if {[info exists ::eagle_platform(text)] && \
        [string length $::eagle_platform(text)] > 0} then {
      set platform [string tolower $::eagle_platform(text)]
    } else {
      set platform [string tolower netFx20]; # TODO: Good default?
    }

    set extractRootDirectory [getPackageInstallPath \
        [appendArgs eee_ $platform] ea-st-di]

    set dir [string map [list fx ""] $platform]; # netfx20 -> net20
    set urn [subst $securityToolsetUrn]; set uri [subst $securityToolsetUri]
    set fileName [getTemporaryFileName]

    if {[isEagle]} then {
      uri download $uri $fileName
    } else {
      package require Eagle.Tools.Common

      namespace import \
          ::Eagle::Tools::Common::getFileViaHttp \
          ::Eagle::Tools::Common::writeFile

      set data [getFileViaHttp $uri 20 $channel $quiet -binary true]

      writeFile $fileName $data
    }

    set extractDirectory [extractZipArchive \
        $fileName $extractRootDirectory true]

    return [file join $extractDirectory build $dir lib]
  }

  #
  # NOTE: This procedure attempts to request a license certificate for Eagle,
  #       which includes the Harpy and Badge plugins.  The optional channel
  #       argument is the output channel where diagnostic information is sent.
  #       The optional quiet argument should be non-zero to prevent diagnostic
  #       information from being emitted.  This procedure may raise script
  #       errors.  The return value is the fully qualified file name for the
  #       resulting license certificate.
  #
  # WARNING: This procedure will send the short name and display name of the
  #          currently logged on user to the Eagle license server as they are
  #          required for a new license certificate to be issued.  Abuse of
  #          this service may result in a permanent ban from the service and
  #          revocation of any previously issued license certificates.
  #
  proc requestLicenseCertificate {
          {channel stdout} {quiet false} } {
    setupPackageToolsetVars false

    variable baseUri
    variable licenseUri
    variable licenseUrn

    package require Eagle.Test

    set certificateRootDirectory [getTemporaryPath]

    set processDirectoryPrefix [file join $certificateRootDirectory \
        [appendArgs ea-lc-di- [pid] -]]

    #
    # NOTE: Issue a warning to the user if it appears there is already a
    #       license certificate in a temporary directory that was created
    #       by this process.  Hopefully, this should reduce the number of
    #       duplicate requests.
    #
    set varName1 YES_PLEASE_FORCE_A_LICENSE_CERTIFICATE_REQUEST

    if {![info exists ::env($varName1)] && [isWindows]} then {
      set processFileNames [list]

      foreach processDirectory [findDirectories \
          [appendArgs $processDirectoryPrefix *]] {
        eval lappend processFileNames [findFiles \
            [file join $processDirectory *]]
      }

      if {[llength $processFileNames] > 0} then {
        set warningCommand [list]

        if {[isEagle]} then {
          lappend warningCommand host result Error
        } else {
          lappend warningCommand puts stderr
        }

        set varName2 Master_Certificate

        lappend warningCommand [appendArgs \
            "One or more temporary license certificate files " \
            "apparently belonging to this process were found.  " \
            "If you wish to override this warning and force a " \
            "new license certificate request to be submitted, " \
            "set the \"" $varName1 "\" environment variable " \
            "(to anything); however, please keep in mind that " \
            "requesting too many license certificates and/or " \
            "requesting license certificates too fast MAY be " \
            "considered abusive behavior.  Upon success, the " \
            "resulting temporary license certificate file " \
            "SHOULD be saved to a secure location on the local " \
            "file system, e.g. the home directory associated " \
            "with the user submitting the license certificate " \
            "request.  The fully qualified file name for the " \
            "temporary license certificate MUST used as the " \
            "value for the \"" $varName2 "\" environment " \
            "variable; otherwise, it MAY NOT be found when one " \
            "of its associated plugins attempts to load.\n"]

        #
        # NOTE: Emit our carefully worded license warning message.
        #
        eval $warningCommand

        #
        # NOTE: Return the first pre-existing license certificate file
        #       name that was found.
        #
        return [lindex $processFileNames 0]
      }
    }

    set directory [appendArgs \
        $processDirectoryPrefix [string trim [clock seconds] -]]

    set urn [subst $licenseUrn]; set uri [subst $licenseUri]

    if {![isEagle] || [catch {
      object invoke System.Security.Principal.WindowsIdentity \
          GetCurrent.Name
    } userName]} then {
      #
      # HACK: Fallback to using a value from the "tcl_platform" array.
      #       For native Tcl, this is the only choice.  For Eagle, it
      #       is used as a fallback.
      #
      if {[info exists ::tcl_platform(user)]} then {
        set userName $::tcl_platform(user)
      } else {
        set userName "NO USER NAME"
      }
    }

    if {![isEagle] || [catch {
      object load System.DirectoryServices.AccountManagement

      object invoke \
          System.DirectoryServices.AccountManagement.UserPrincipal \
          Current.DisplayName
    } displayName]} then {
      #
      # HACK: Fallback to using a value from the "tcl_platform" array.
      #       This value is not set by native Tcl or Eagle; therefore,
      #       the user would have to set it manually prior to calling
      #       this procedure.
      #
      if {[info exists ::tcl_platform(userDisplayName)]} then {
        set displayName $::tcl_platform(userDisplayName)
      } else {
        set displayName "NO DISPLAY NAME"
      }
    }

    #
    # NOTE: Add the necessary query parameters to the license request
    #       URI, making sure to properly escape their values.
    #
    if {[isEagle]} then {
      append uri ?userName= [uri escape data $userName]
      append uri &displayName= [uri escape data $displayName]
    } else {
      package require http 2.0

      append uri ? [::http::formatQuery \
          userName $userName displayName $displayName]
    }

    if {[isEagle]} then {
      set data [uri download -inline $uri]
    } else {
      package require Eagle.Tools.Common

      namespace import \
          ::Eagle::Tools::Common::getFileViaHttp \
          ::Eagle::Tools::Common::writeFile

      set data [getFileViaHttp $uri 20 $channel $quiet -binary true]
      package require Eagle.Auxiliary
    }

    if {[getDictionaryValue $data returnCode] ne "Ok"} then {
      if {[string length $data] > 0} then {
        error [appendArgs \
            "request failed with error information: " $data]
      } else {
        error "request failed without providing error information"
      }
    }

    set fileName [getTemporaryFileName]
    writeFile $fileName [getDictionaryValue $data result]
    set newFileName [file join $directory [file tail $fileName]]

    file mkdir $directory; file copy $fileName $newFileName
    file delete $fileName

    return $newFileName
  }

  #
  # NOTE: This procedure attempts to submit the specified script to a remote
  #       sandbox for evaluation.  The apiKey parameter is the optional API
  #       key to use, which MAY enable additional permissions in the remote
  #       sandbox.  The params parameter contains any optional extra names
  #       and values to include in the submitted query.  Upon success, this
  #       procedure returns a Tcl dictionary that includes at least the keys
  #       "returnCode", "result", and "errorLine".  The "returnCode" value
  #       will be "Ok", "Error", "Return", "Break", "Continue", or possibly
  #       a signed integer.  The "result" value will be the textual result
  #       of the script or an error message.  The "errorLine" value will be
  #       zero or the line where a script error was raised.  This procedure
  #       may raise script errors.
  #
  proc evaluateInRemoteSandbox {
          script {apiKey ""} {params ""} {channel stdout} {quiet false} } {
    setupPackageToolsetVars false

    variable baseUri
    variable sandboxEvalUri
    variable sandboxEvalUrn

    set urn [subst $sandboxEvalUrn]
    set uri [subst $sandboxEvalUri]

    set query [list go 1 raw 1 script $script]

    if {[string length $apiKey] > 0} then {
      lappend query apiKey $apiKey
    }

    if {[llength $params] > 0} then {
      eval lappend query $params
    }

    if {[isEagle]} then {
      return [uri upload -inline -data $query $uri]
    } else {
      package require http 2.0
      package require Eagle.Tools.Common

      namespace import \
          ::Eagle::Tools::Common::getFileViaHttp

      return [getFileViaHttp \
          $uri 20 $channel $quiet -binary true \
          -query [eval ::http::formatQuery $query]]
    }
  }

  #
  # NOTE: Provide the Eagle "package toolset" package to the interpreter.
  #
  package provide Eagle.Package.Toolset \
    [expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}