diff --git a/.gitignore b/.gitignore
index cf802181..88ba4625 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,30 +1,22 @@
-/*.lastrun
-/*.ps1
-
-#/bin/
/bin/*
!/bin/*.cmd
+!/bin/*.kit
+!/bin/*.tcl
+!/bin/*.sh
+!/bin/*.bash
/lib/
-#The directories for compiled/built Tcl modules and libraries
+#The directory for compiled/built Tcl modules
/modules/
-/modules_tcl8/
-/modules_tcl9/
-/lib/
-/lib_tcl8/
-/lib_tcl9/
+/vendorbuilds/
#Temporary files e.g from tests
/tmp/
-**/_old.*
/logs/
**/_aside/
-scratch*
-
-#working directories
**/_build/
-/src/docgen/
+scratch*
#Built documentation
/html/
@@ -33,20 +25,8 @@ scratch*
/doc/
/test*
-/src/testdata/
-
-#do not ignore src/runtime folder (needed to re-include what we do want from within)
-!/src/runtime
-#ignore files and sub dirs in src/runtime
-/src/runtime/*
-#but do not ignore specific files
-!/src/runtime/Readme.md
-!/src/runtime/tclkit.ico
-!/src/runtime/mapvfs.config
#Built tclkits (if any)
-#punk*.exe
-#tcl*.exe
*.exe
#ignore fossil database files (but keep .fossil-settings and .fossil-custom in repository even if fossil not being used at your site)
@@ -57,13 +37,9 @@ _FOSSIL_
#miscellaneous editor files etc
*.swp
-.vscode
*.log
-/src/modules/punk/mix/templates/utility/multishell.ps1
-
-
-.punkcheck
+*.punkcheck
todo.txt
@@ -74,7 +50,3 @@ zig-out/
/build/
/build-*/
/docgen_tmp/
-
-
-
-
diff --git a/bin/runtime.cmd b/bin/runtime.cmd
index ac5676f9..50f13aa8 100755
--- a/bin/runtime.cmd
+++ b/bin/runtime.cmd
@@ -1507,7 +1507,7 @@ if (-not $MyInvocation.PSCommandPath) {
if ($PSVersionTable.PSVersion.Major -le 5) {
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
- #Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'pwershell' subfolder??
+ #Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';'
}
@@ -1704,422 +1704,422 @@ if ($match.Success) {
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload
#
-
-
-function GetDynamicParamDictionary {
- [CmdletBinding()]
- param(
- [Parameter(ValueFromPipeline=$true, Mandatory=$true)]
- [string] $CommandName
- )
-
- begin {
- # Get a list of params that should be ignored (they're common to all advanced functions)
- $CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) |
- Get-Member -MemberType Properties |
- Select-Object -ExpandProperty Name
- }
-
- process {
- # Create the dictionary that this scriptblock will return:
- $DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary
-
- # Convert to object array and get rid of Common params:
- (Get-Command $CommandName | Select-Object -exp Parameters).GetEnumerator() |
- Where-Object { $CommonParameterNames -notcontains $_.Key } |
- ForEach-Object {
- $DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter (
- $_.Key,
- $_.Value.ParameterType,
- $_.Value.Attributes
- )
- $DynParamDictionary.Add($_.Key, $DynamicParameter)
- }
-
- # Return the dynamic parameters
- return $DynParamDictionary
- }
-}
-function ParameterDefinitions {
- param(
- [Parameter(ValueFromRemainingArguments=$true,Position = 1)][string[]] $opts
- )
-}
-
-function psmain {
- [CmdletBinding()]
- #Empty param block (extra params can be added)
- param(
- [Parameter(Mandatory=$false, Position = 0)][string] $action = ""
- )
- dynamicparam {
- if ($action -eq 'list') {
- $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
- ParameterSetName = "listruntime"
- Mandatory = $false
- }
- $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
- $attributeCollection.Add($parameterAttribute)
- $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
- 'remote', [switch], $attributeCollection
- )
- $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
- $paramDictionary.Add('remote', $dynParam1)
- return $paramDictionary
- } elseif ($action -eq 'fetch') {
- #GetDynamicParamDictionary ParameterDefinitions
- $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
- ParameterSetName = "fetchruntime"
- Mandatory = $false
- Position = 1
- }
- $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
- $attributeCollection.Add($parameterAttribute)
-
- $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
- 'runtime', [string], $attributeCollection
- )
-
- $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
- $paramDictionary.Add('runtime', $dynParam1)
- return $paramDictionary
- } elseif ($action -eq 'run') {
- #GetDynamicParamDictionary ParameterDefinitions
- $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
- ParameterSetName = "runargs"
- Mandatory = $false
- ValueFromRemainingArguments = $true
- }
- $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
- $attributeCollection.Add($parameterAttribute)
-
- $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
- 'opts', [string[]], $attributeCollection
- )
-
- $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
- $paramDictionary.Add('opts', $dynParam1)
- return $paramDictionary
- } else {
- #accept all args when action is unrecognised - so we can go to help anyway
- $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
- ParameterSetName = "invalidaction"
- Mandatory = $false
- ValueFromRemainingArguments = $true
- }
- $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
- $attributeCollection.Add($parameterAttribute)
-
- $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
- 'opts', [string[]], $attributeCollection
- )
-
- $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
- $paramDictionary.Add('opts', $dynParam1)
- return $paramDictionary
- }
- }
- process {
- #Called once - we get a single item being our PSBoundParameters dictionary
- #write-host "Bound Parameters:$($PSBoundParameters.Keys)"
- switch ($PSBoundParameters.keys) {
- 'action' {
- write-host "got action " $PSBoundParameters.action
- Set-Variable -Name $_ -Value $PSBoundParameters."$_"
- $known_actions = @("fetch", "list", "run")
- if (-not($known_actions -contains $action)) {
- write-host "fetch '$action' not understood. Known_actions: $known_actions"
- exit 1
- }
- }
- 'opts' {
- # write-warning "Unused parameters: $($PSBoundParameters.$_)"
- }
- Default {
- # write-warning "Unhandled parameter -> [$($_)]"
- }
- }
- #foreach ($boundparam in $PSBoundParameters.Keys) {
- # write-host "k: $boundparam"
- #}
- }
- end {
- # PSBoundParameters
- #write-host "action:'$action'"
- $outbase = $PSScriptRoot
- $outbase = Resolve-Path -Path $outbase
- #expected script location is the bin folder of a punk project
- $rtfolder = Join-Path -Path $outbase -ChildPath "runtime"
- #Binary artifact server url. (git is not ideal for this - but will do for now - todo - use artifact system within gitea?)
- $artifacturl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master"
- switch ($action) {
- 'fetch' {
- $arch = "win32-x86_64"
- $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch"
- $archurl = "$artifacturl/$arch"
- $sha1url = "$archurl/sha1sums.txt"
- $runtime = "tclsh902z.exe"
- foreach ($boundparam in $PSBoundParameters.Keys) {
- write-host "fetchopt: $boundparam $($PSBoundParameters[$boundparam])"
- }
- if ( $PSBoundParameters["runtime"].Length ) {
- $runtime = $PSBoundParameters["runtime"]
- }
- $fileurl = "$archurl/$runtime"
-
- $output = join-path -Path $archfolder -ChildPath $runtime
- $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt"
-
- $container = split-path -Path $output -Parent
- new-item -Path $container -ItemType Directory -force #create with intermediary folders if not already present
-
- try {
- Write-Host "Fetching $sha1url"
- Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop
- Write-Host "sha1 saved at $sha1local"
- } catch {
- Write-Host "An error occurred while downloading ${sha1url}: $($_.Exception.Message)"
- if ($_.Exception.Response) {
- Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)"
- }
- }
- if (Test-Path -Path $sha1local -PathType Leaf) {
- $sha1Content = Get-Content -Path $sha1local
- $stored_sha1 = ""
- foreach ($line in $sha1Content) {
- #all sha1sums have * (binary indicator) - review
- $match = [regex]::Match($line,"(.*) [*]${runtime}$")
- if ($match.Success) {
- $stored_sha1 = $match.Groups[1].Value
- Write-host "stored hash from sha1sums.txt: $storedhash"
- break
- }
- }
- if ($stored_sha1 -eq "") {
- Write-Host "Unable to locate hash for $runtime in $sha1local - Aborting"
- Write-Host "Please download and verify manually"
- return
- }
-
- $need_download = $false
- if (Test-Path -Path $output -PathType Leaf) {
- Write-Host "Runtime already found at $output"
- Write-Host "Checking sha1 checksum of local file versus sha1 of server file"
- $file_sha1 = Get-FileHash -Path "$output" -Algorithm SHA1
- if (${file_sha1}.Hash -ne $stored_sha1) {
- Write-Host "$runtime on server has different sha1 hash - Download required"
- $need_download = $true
- }
- } else {
- Write-Host "$runtime not found locally - Download required"
- $need_download = $true
- }
-
- if ($need_download) {
- Write-Host "Downloading from $fileurl ..."
- try {
- Invoke-WebRequest -Uri $fileurl -OutFile "${output}.tmp" -ErrorAction Stop
- Write-Host "Runtime saved at $output.tmp"
- }
- catch {
- Write-Host "An error occurred while downloading $fileurl $($_.Exception.Message)"
- if ($_.Exception.Response) {
- Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)"
- }
- return
- }
- Write-Host "comparing sha1 checksum of downloaded file with data in sha1sums.txt"
- Start-Sleep -Seconds 1 #REVIEW - give at least some time for windows to do its thing? (av filters?)
- $newfile_sha1 = Get-FileHash -Path "${output}.tmp" -Algorithm SHA1
- if (${newfile_sha1}.Hash -eq $stored_sha1) {
- Write-Host "sha1 checksum ok"
- Move-Item -Path "${output}.tmp" -Destination "${output}" -Force
- Write-Host "Runtime is available at ${output}"
- } else {
- Write-Host "WARNING! sha1 of downloaded file at $output.tmp does not match stored sha1 from sha1sums.txt"
- return
- }
- } else {
- Write-Host "Local copy of runtime at $output seems to match sha1 checksum of file on server."
- Write-Host "No download required"
- }
- } else {
- Write-Host "Unable to consult local copy of sha1sums.txt at $sha1local"
- if (Test-Path -Path $output -PathType Leaf) {
- Write-Host "A runtime is available at $output - but we failed to retrieve the list of sha1sums from the server"
- Write-Host "Unable to check for updated version at this time."
- } else {
- Write-Host "Please retry - or manually download a runtime from $archurl and verify checksums"
- }
- }
- }
- 'run' {
- #select first (or configured default) runtime and launch, passing arguments
- $arch = "win32-x86_64"
- $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch"
- if (-not(Test-Path -Path $archfolder -PathType Container)) {
- write-host "No runtimes seem to be installed for $arch`nPlease use 'runtime.cmd fetch' to install"
- } else {
- $dircontents = (get-childItem -Path $archfolder -File | Sort-Object Name)
- if ($dircontents.Count -gt 0) {
- #write-host "run.."
- write-host "num params: $($PSBoundParameters.opts.count)"
-
- #todo - use 'active' runtime - need to lookup (PSToml?)
- #when no 'active' runtime for this os-arch - use last item (sorted in dictionary order)
- $active = $dircontents[-1].FullName
- write-host "using: $active"
- if ($PSBoundParameters.opts.Length -gt 0) {
- $optsType = $PSBoundParameters.opts.GetType() #method can only be called if .opts is not null
- write-host "type of opts: $($optsType.FullName)"
- foreach ($boundparam in $PSBoundParameters.opts) {
- write-host $boundparam
- }
- Write-Host "opts: $($PSBoundParameters.opts)"
- Write-Host "args: $args"
- Write-HOst "argscount: $($args.Count)"
- $arglist = @()
- foreach ($o in $PSBoundParameters.opts) {
- $oquoted = $o -replace '"', "`\`""
- #$oquoted = $oquoted -replace "'", "`'"
- if ($oquoted -match "\s") {
- $oquoted = "`"$oquoted`""
- }
- $arglist += @($oquoted)
- }
- $arglist = $arglist.TrimEnd(' ')
- write-host "arglist: $arglist"
- #$arglist = $PSBoundParameters.opts
- Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait
- } else {
- #powershell 5.1 and earlier can't accept an empty -ArgumentList value :/ !!
- #$arglist = @()
- #Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait
- #Start-Process -FilePath $active -ArgumentList "" -NoNewWindow -Wait
- Start-Process -FilePath $active -NoNewWindow -Wait
- }
- } else {
- write-host "No files found in $archfolder"
- write-host "No runtimes seem to be installed for $arch`nPlease use 'runtime.cmd fetch' to install."
- }
- }
- }
- 'list' {
- #todo - option to list for other os-arch
- $arch = 'win32-x86_64'
- $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch"
- $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt"
- $archurl = "$artifacturl/$arch"
- $sha1url = "$archurl/sha1sums.txt"
- if ( $PSBoundParameters.ContainsKey('remote') ) {
- if (-not (test-path -Path $archfolder -Type Container)) {
- new-item -Path $container -ItemType Directory -force #create with intermediary folders if not already present
- }
- write-host "Checking for available remote runtimes for"
- Write-Host "Fetching $sha1url"
- Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop
- Write-Host "sha1 saved at $sha1local"
- $sha1Content = Get-Content -Path $sha1local
- $remotedict = @{}
- foreach ($line in $sha1Content) {
- #all sha1sums have * (binary indicator) - review
- $match = [regex]::Match($line,"(.*) [*](.*)$")
- if ($match.Success) {
- $server_sha1 = $match.Groups[1].Value
- $server_rt = $match.Groups[2].Value
- $remotedict[$server_rt] = $server_sha1
- }
- }
-
- $localdict = @{}
- if (test-path -Path $archfolder -Type Container) {
- $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) })
- foreach ($f in $dircontents) {
- $local_sha1 = Get-FileHash -Path $(${f}.FullName) -Algorithm SHA1
- $localdict[$f.Name] = ${local_sha1}.Hash
- }
- }
-
- Write-host "-----------------------------------------------------------------------"
- Write-host "Runtimes for $arch"
- Write-host "Local $archfolder"
- Write-host "Remote $archurl"
- Write-host "-----------------------------------------------------------------------"
- Write-host "Local Remote"
- Write-host "-----------------------------------------------------------------------"
- # 12345678910234567892023456789302345
- $G = "`e[32m" #Green
- $Y = "`e[33m" #Yellow
- $R = "`e[31m" #Red
- $RST = "`e[m"
- foreach ($key in $localdict.Keys) {
- $local_sha1 = $($localdict[$key])
- if ($remotedict.ContainsKey($key)) {
- if ($local_sha1 -eq $remotedict[$key]) {
- $rhs = "Same version"
- $C = $G
- } else {
- $rhs = "UPDATE AVAILABLE"
- $C = $Y
- }
- } else {
- $C = $R
- $rhs = "(not listed on server)"
- }
- #ansi problems from cmd.exe not in windows terminal - review
- $C = ""
- $RST = ""
- $lhs = "$key".PadRight(35, ' ')
- write-host -nonewline "${C}${lhs}${RST}"
- write-host $rhs
- }
- $lhs_missing = "-".PadRight(35, ' ')
- foreach ($key in $remotedict.Keys) {
- if (-not ($localdict.ContainsKey($key))) {
- write-host -nonewline $lhs_missing
- write-host $key
- }
- }
- Write-host "-----------------------------------------------------------------------"
-
- } else {
- if (test-path -Path $archfolder -Type Container) {
- Write-host "-----------------------------------------------------------------------"
- Write-Host "Local runtimes for $arch"
- $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) })
- write-host "$(${dircontents}.count) files in $archfolder"
- Write-host "-----------------------------------------------------------------------"
- foreach ($f in $dircontents) {
- write-host $f.Name
- }
- Write-host "-----------------------------------------------------------------------"
- Write-host "Use: 'list -remote' to compare local runtimes with those available on the artifact server"
- } else {
- write-host "No runtimes seem to be installed for $arch in $archfolder`nPlease use 'runtime.cmd fetch' to install."
- write-host "Use 'runtime.cmd list -remote' to see available runtimes for $arch"
- }
- }
- }
- default {
- $actions = @("fetch", "list", "run")
- write-host "Available actions: $actions"
- write-host "received"
- foreach ($boundparam in $PSBoundParameters.opts) {
- write-host $boundparam
- }
- }
- }
-
- return $PSBoundParameters
- }
-}
-#write-host (psmain @args)
-#$returnvalue = psmain @args
-#Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan
-#return $returnvalue
-psmain @args | out-null
-exit 0
-
+
+
+function GetDynamicParamDictionary {
+ [CmdletBinding()]
+ param(
+ [Parameter(ValueFromPipeline=$true, Mandatory=$true)]
+ [string] $CommandName
+ )
+
+ begin {
+ # Get a list of params that should be ignored (they're common to all advanced functions)
+ $CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) |
+ Get-Member -MemberType Properties |
+ Select-Object -ExpandProperty Name
+ }
+
+ process {
+ # Create the dictionary that this scriptblock will return:
+ $DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary
+
+ # Convert to object array and get rid of Common params:
+ (Get-Command $CommandName | Select-Object -exp Parameters).GetEnumerator() |
+ Where-Object { $CommonParameterNames -notcontains $_.Key } |
+ ForEach-Object {
+ $DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter (
+ $_.Key,
+ $_.Value.ParameterType,
+ $_.Value.Attributes
+ )
+ $DynParamDictionary.Add($_.Key, $DynamicParameter)
+ }
+
+ # Return the dynamic parameters
+ return $DynParamDictionary
+ }
+}
+function ParameterDefinitions {
+ param(
+ [Parameter(ValueFromRemainingArguments=$true,Position = 1)][string[]] $opts
+ )
+}
+
+function psmain {
+ [CmdletBinding()]
+ #Empty param block (extra params can be added)
+ param(
+ [Parameter(Mandatory=$false, Position = 0)][string] $action = ""
+ )
+ dynamicparam {
+ if ($action -eq 'list') {
+ $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
+ ParameterSetName = "listruntime"
+ Mandatory = $false
+ }
+ $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
+ $attributeCollection.Add($parameterAttribute)
+ $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
+ 'remote', [switch], $attributeCollection
+ )
+ $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
+ $paramDictionary.Add('remote', $dynParam1)
+ return $paramDictionary
+ } elseif ($action -eq 'fetch') {
+ #GetDynamicParamDictionary ParameterDefinitions
+ $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
+ ParameterSetName = "fetchruntime"
+ Mandatory = $false
+ Position = 1
+ }
+ $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
+ $attributeCollection.Add($parameterAttribute)
+
+ $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
+ 'runtime', [string], $attributeCollection
+ )
+
+ $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
+ $paramDictionary.Add('runtime', $dynParam1)
+ return $paramDictionary
+ } elseif ($action -eq 'run') {
+ #GetDynamicParamDictionary ParameterDefinitions
+ $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
+ ParameterSetName = "runargs"
+ Mandatory = $false
+ ValueFromRemainingArguments = $true
+ }
+ $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
+ $attributeCollection.Add($parameterAttribute)
+
+ $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
+ 'opts', [string[]], $attributeCollection
+ )
+
+ $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
+ $paramDictionary.Add('opts', $dynParam1)
+ return $paramDictionary
+ } else {
+ #accept all args when action is unrecognised - so we can go to help anyway
+ $parameterAttribute = [System.Management.Automation.ParameterAttribute]@{
+ ParameterSetName = "invalidaction"
+ Mandatory = $false
+ ValueFromRemainingArguments = $true
+ }
+ $attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new()
+ $attributeCollection.Add($parameterAttribute)
+
+ $dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new(
+ 'opts', [string[]], $attributeCollection
+ )
+
+ $paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new()
+ $paramDictionary.Add('opts', $dynParam1)
+ return $paramDictionary
+ }
+ }
+ process {
+ #Called once - we get a single item being our PSBoundParameters dictionary
+ #write-host "Bound Parameters:$($PSBoundParameters.Keys)"
+ switch ($PSBoundParameters.keys) {
+ 'action' {
+ write-host "got action " $PSBoundParameters.action
+ Set-Variable -Name $_ -Value $PSBoundParameters."$_"
+ $known_actions = @("fetch", "list", "run")
+ if (-not($known_actions -contains $action)) {
+ write-host "fetch '$action' not understood. Known_actions: $known_actions"
+ exit 1
+ }
+ }
+ 'opts' {
+ # write-warning "Unused parameters: $($PSBoundParameters.$_)"
+ }
+ Default {
+ # write-warning "Unhandled parameter -> [$($_)]"
+ }
+ }
+ #foreach ($boundparam in $PSBoundParameters.Keys) {
+ # write-host "k: $boundparam"
+ #}
+ }
+ end {
+ # PSBoundParameters
+ #write-host "action:'$action'"
+ $outbase = $PSScriptRoot
+ $outbase = Resolve-Path -Path $outbase
+ #expected script location is the bin folder of a punk project
+ $rtfolder = Join-Path -Path $outbase -ChildPath "runtime"
+ #Binary artifact server url. (git is not ideal for this - but will do for now - todo - use artifact system within gitea?)
+ $artifacturl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master"
+ switch ($action) {
+ 'fetch' {
+ $arch = "win32-x86_64"
+ $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch"
+ $archurl = "$artifacturl/$arch"
+ $sha1url = "$archurl/sha1sums.txt"
+ $runtime = "tclsh902z.exe"
+ foreach ($boundparam in $PSBoundParameters.Keys) {
+ write-host "fetchopt: $boundparam $($PSBoundParameters[$boundparam])"
+ }
+ if ( $PSBoundParameters["runtime"].Length ) {
+ $runtime = $PSBoundParameters["runtime"]
+ }
+ $fileurl = "$archurl/$runtime"
+
+ $output = join-path -Path $archfolder -ChildPath $runtime
+ $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt"
+
+ $container = split-path -Path $output -Parent
+ new-item -Path $container -ItemType Directory -force #create with intermediary folders if not already present
+
+ try {
+ Write-Host "Fetching $sha1url"
+ Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop
+ Write-Host "sha1 saved at $sha1local"
+ } catch {
+ Write-Host "An error occurred while downloading ${sha1url}: $($_.Exception.Message)"
+ if ($_.Exception.Response) {
+ Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)"
+ }
+ }
+ if (Test-Path -Path $sha1local -PathType Leaf) {
+ $sha1Content = Get-Content -Path $sha1local
+ $stored_sha1 = ""
+ foreach ($line in $sha1Content) {
+ #all sha1sums have * (binary indicator) - review
+ $match = [regex]::Match($line,"(.*) [*]${runtime}$")
+ if ($match.Success) {
+ $stored_sha1 = $match.Groups[1].Value
+ Write-host "stored hash from sha1sums.txt: $storedhash"
+ break
+ }
+ }
+ if ($stored_sha1 -eq "") {
+ Write-Host "Unable to locate hash for $runtime in $sha1local - Aborting"
+ Write-Host "Please download and verify manually"
+ return
+ }
+
+ $need_download = $false
+ if (Test-Path -Path $output -PathType Leaf) {
+ Write-Host "Runtime already found at $output"
+ Write-Host "Checking sha1 checksum of local file versus sha1 of server file"
+ $file_sha1 = Get-FileHash -Path "$output" -Algorithm SHA1
+ if (${file_sha1}.Hash -ne $stored_sha1) {
+ Write-Host "$runtime on server has different sha1 hash - Download required"
+ $need_download = $true
+ }
+ } else {
+ Write-Host "$runtime not found locally - Download required"
+ $need_download = $true
+ }
+
+ if ($need_download) {
+ Write-Host "Downloading from $fileurl ..."
+ try {
+ Invoke-WebRequest -Uri $fileurl -OutFile "${output}.tmp" -ErrorAction Stop
+ Write-Host "Runtime saved at $output.tmp"
+ }
+ catch {
+ Write-Host "An error occurred while downloading $fileurl $($_.Exception.Message)"
+ if ($_.Exception.Response) {
+ Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)"
+ }
+ return
+ }
+ Write-Host "comparing sha1 checksum of downloaded file with data in sha1sums.txt"
+ Start-Sleep -Seconds 1 #REVIEW - give at least some time for windows to do its thing? (av filters?)
+ $newfile_sha1 = Get-FileHash -Path "${output}.tmp" -Algorithm SHA1
+ if (${newfile_sha1}.Hash -eq $stored_sha1) {
+ Write-Host "sha1 checksum ok"
+ Move-Item -Path "${output}.tmp" -Destination "${output}" -Force
+ Write-Host "Runtime is available at ${output}"
+ } else {
+ Write-Host "WARNING! sha1 of downloaded file at $output.tmp does not match stored sha1 from sha1sums.txt"
+ return
+ }
+ } else {
+ Write-Host "Local copy of runtime at $output seems to match sha1 checksum of file on server."
+ Write-Host "No download required"
+ }
+ } else {
+ Write-Host "Unable to consult local copy of sha1sums.txt at $sha1local"
+ if (Test-Path -Path $output -PathType Leaf) {
+ Write-Host "A runtime is available at $output - but we failed to retrieve the list of sha1sums from the server"
+ Write-Host "Unable to check for updated version at this time."
+ } else {
+ Write-Host "Please retry - or manually download a runtime from $archurl and verify checksums"
+ }
+ }
+ }
+ 'run' {
+ #select first (or configured default) runtime and launch, passing arguments
+ $arch = "win32-x86_64"
+ $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch"
+ if (-not(Test-Path -Path $archfolder -PathType Container)) {
+ write-host "No runtimes seem to be installed for $arch`nPlease use 'runtime.cmd fetch' to install"
+ } else {
+ $dircontents = (get-childItem -Path $archfolder -File | Sort-Object Name)
+ if ($dircontents.Count -gt 0) {
+ #write-host "run.."
+ write-host "num params: $($PSBoundParameters.opts.count)"
+
+ #todo - use 'active' runtime - need to lookup (PSToml?)
+ #when no 'active' runtime for this os-arch - use last item (sorted in dictionary order)
+ $active = $dircontents[-1].FullName
+ write-host "using: $active"
+ if ($PSBoundParameters.opts.Length -gt 0) {
+ $optsType = $PSBoundParameters.opts.GetType() #method can only be called if .opts is not null
+ write-host "type of opts: $($optsType.FullName)"
+ foreach ($boundparam in $PSBoundParameters.opts) {
+ write-host $boundparam
+ }
+ Write-Host "opts: $($PSBoundParameters.opts)"
+ Write-Host "args: $args"
+ Write-HOst "argscount: $($args.Count)"
+ $arglist = @()
+ foreach ($o in $PSBoundParameters.opts) {
+ $oquoted = $o -replace '"', "`\`""
+ #$oquoted = $oquoted -replace "'", "`'"
+ if ($oquoted -match "\s") {
+ $oquoted = "`"$oquoted`""
+ }
+ $arglist += @($oquoted)
+ }
+ $arglist = $arglist.TrimEnd(' ')
+ write-host "arglist: $arglist"
+ #$arglist = $PSBoundParameters.opts
+ Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait
+ } else {
+ #powershell 5.1 and earlier can't accept an empty -ArgumentList value :/ !!
+ #$arglist = @()
+ #Start-Process -FilePath $active -ArgumentList $arglist -NoNewWindow -Wait
+ #Start-Process -FilePath $active -ArgumentList "" -NoNewWindow -Wait
+ Start-Process -FilePath $active -NoNewWindow -Wait
+ }
+ } else {
+ write-host "No files found in $archfolder"
+ write-host "No runtimes seem to be installed for $arch`nPlease use 'runtime.cmd fetch' to install."
+ }
+ }
+ }
+ 'list' {
+ #todo - option to list for other os-arch
+ $arch = 'win32-x86_64'
+ $archfolder = Join-Path -Path $rtfolder -ChildPath "$arch"
+ $sha1local = join-path -Path $archfolder -ChildPath "sha1sums.txt"
+ $archurl = "$artifacturl/$arch"
+ $sha1url = "$archurl/sha1sums.txt"
+ if ( $PSBoundParameters.ContainsKey('remote') ) {
+ if (-not (test-path -Path $archfolder -Type Container)) {
+ new-item -Path $container -ItemType Directory -force #create with intermediary folders if not already present
+ }
+ write-host "Checking for available remote runtimes for"
+ Write-Host "Fetching $sha1url"
+ Invoke-WebRequest -Uri $sha1url -OutFile $sha1local -ErrorAction Stop
+ Write-Host "sha1 saved at $sha1local"
+ $sha1Content = Get-Content -Path $sha1local
+ $remotedict = @{}
+ foreach ($line in $sha1Content) {
+ #all sha1sums have * (binary indicator) - review
+ $match = [regex]::Match($line,"(.*) [*](.*)$")
+ if ($match.Success) {
+ $server_sha1 = $match.Groups[1].Value
+ $server_rt = $match.Groups[2].Value
+ $remotedict[$server_rt] = $server_sha1
+ }
+ }
+
+ $localdict = @{}
+ if (test-path -Path $archfolder -Type Container) {
+ $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) })
+ foreach ($f in $dircontents) {
+ $local_sha1 = Get-FileHash -Path $(${f}.FullName) -Algorithm SHA1
+ $localdict[$f.Name] = ${local_sha1}.Hash
+ }
+ }
+
+ Write-host "-----------------------------------------------------------------------"
+ Write-host "Runtimes for $arch"
+ Write-host "Local $archfolder"
+ Write-host "Remote $archurl"
+ Write-host "-----------------------------------------------------------------------"
+ Write-host "Local Remote"
+ Write-host "-----------------------------------------------------------------------"
+ # 12345678910234567892023456789302345
+ $G = "`e[32m" #Green
+ $Y = "`e[33m" #Yellow
+ $R = "`e[31m" #Red
+ $RST = "`e[m"
+ foreach ($key in $localdict.Keys) {
+ $local_sha1 = $($localdict[$key])
+ if ($remotedict.ContainsKey($key)) {
+ if ($local_sha1 -eq $remotedict[$key]) {
+ $rhs = "Same version"
+ $C = $G
+ } else {
+ $rhs = "UPDATE AVAILABLE"
+ $C = $Y
+ }
+ } else {
+ $C = $R
+ $rhs = "(not listed on server)"
+ }
+ #ansi problems from cmd.exe not in windows terminal - review
+ $C = ""
+ $RST = ""
+ $lhs = "$key".PadRight(35, ' ')
+ write-host -nonewline "${C}${lhs}${RST}"
+ write-host $rhs
+ }
+ $lhs_missing = "-".PadRight(35, ' ')
+ foreach ($key in $remotedict.Keys) {
+ if (-not ($localdict.ContainsKey($key))) {
+ write-host -nonewline $lhs_missing
+ write-host $key
+ }
+ }
+ Write-host "-----------------------------------------------------------------------"
+
+ } else {
+ if (test-path -Path $archfolder -Type Container) {
+ Write-host "-----------------------------------------------------------------------"
+ Write-Host "Local runtimes for $arch"
+ $dircontents = (get-childItem -Path $archfolder -File | Where-object {-not ($(".txt",".tm") -contains $_.Extension) })
+ write-host "$(${dircontents}.count) files in $archfolder"
+ Write-host "-----------------------------------------------------------------------"
+ foreach ($f in $dircontents) {
+ write-host $f.Name
+ }
+ Write-host "-----------------------------------------------------------------------"
+ Write-host "Use: 'list -remote' to compare local runtimes with those available on the artifact server"
+ } else {
+ write-host "No runtimes seem to be installed for $arch in $archfolder`nPlease use 'runtime.cmd fetch' to install."
+ write-host "Use 'runtime.cmd list -remote' to see available runtimes for $arch"
+ }
+ }
+ }
+ default {
+ $actions = @("fetch", "list", "run")
+ write-host "Available actions: $actions"
+ write-host "received"
+ foreach ($boundparam in $PSBoundParameters.opts) {
+ write-host $boundparam
+ }
+ }
+ }
+
+ return $PSBoundParameters
+ }
+}
+#write-host (psmain @args)
+#$returnvalue = psmain @args
+#Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan
+#return $returnvalue
+psmain @args | out-null
+exit 0
+
#
diff --git a/src/bootsupport/modules/metaface-1.2.8.tm b/src/bootsupport/modules/metaface-1.2.8.tm
new file mode 100644
index 00000000..39a54c8c
--- /dev/null
+++ b/src/bootsupport/modules/metaface-1.2.8.tm
@@ -0,0 +1,6447 @@
+package require dictutils
+package provide metaface [namespace eval metaface {
+ variable version
+ set version 1.2.8
+}]
+
+# 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+
+# 2023-07 - add .. MetaMethods
+
+
+#example datastructure:
+#$_ID_
+#{
+#i
+# {
+# this
+# {
+# {16 ::p::16 item ::>x {}}
+# }
+# role2
+# {
+# {17 ::p::17 item ::>y {}}
+# {18 ::p::18 item ::>z {}}
+# }
+# }
+#context {}
+#}
+
+#$MAP
+#invocantdata {16 ::p::16 item ::>x {}}
+#interfaces {level0
+# {
+# api0 {stack {123 999}}
+# api1 {stack {333}}
+# }
+# level0_default api0
+# level1
+# {
+# }
+# level1_default {}
+# }
+#patterndata {patterndefaultmethod {}}
+
+
+namespace eval ::p::predator {}
+#temporary alternative to ::p::internals namespace.
+# - place predator functions here until ready to replace internals.
+
+
+namespace eval ::p::snap {
+ variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks.
+}
+
+
+
+
+# not called directly. Retrieved using 'info body ::p::predator::getprop_template'
+#review - why use a proc instead of storing it as a string?
+proc ::p::predator::getprop_template {_ID_ args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {"%varspace%" eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" "%varspace%"]} {
+ set ns "%varspace%"
+ } else {
+ set ns ::p::${OID}::%varspace%
+ }
+ }
+
+
+ if {[llength $args]} {
+ #lassign [lindex $invocant 0] OID alias itemCmd cmd
+ if {[array exists ${ns}::o_%prop%]} {
+ #return [set ${ns}::o_%prop%($args)]
+ if {[llength $args] == 1} {
+ return [set ::p::${OID}::o_%prop%([lindex $args 0])]
+ } else {
+ return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]]
+ }
+ } else {
+ set val [set ${ns}::o_%prop%]
+
+ set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}]
+ if {$rType eq "object"} {
+ #return [$val . item {*}$args]
+ return [$val {*}$args]
+ } else {
+ #treat as list?
+ return [lindex $val $args]
+ }
+ }
+ } else {
+ return [set ${ns}::o_%prop%]
+ }
+}
+
+
+proc ::p::predator::getprop_template_immediate {_ID_ args} {
+ if {[llength $args]} {
+ if {[array exists %ns%::o_%prop%]} {
+ return [set %ns%::o_%prop%($args)]
+ } else {
+ set val [set %ns%::o_%prop%]
+ set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}]
+ if {$rType eq "object"} {
+ #return [$val . item {*}$args]
+ #don't assume defaultmethod named 'item'!
+ return [$val {*}$args]
+ } else {
+ #treat as list?
+ return [lindex $val $args]
+ }
+ }
+ } else {
+ return [set %ns%::o_%prop%]
+ }
+}
+
+
+
+
+
+
+
+
+proc ::p::predator::getprop_array {_ID_ prop args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+
+ #upvar 0 ::p::${OID}::o_${prop} prop
+ #1st try: assume array
+ if {[catch {array get ::p::${OID}::o_${prop}} result]} {
+ #treat as list (why?)
+ #!review
+ if {[info exists ::p::${OID}::o_${prop}]} {
+ array set temp [::list]
+ set i 0
+ foreach element ::p::${OID}::o_${prop} {
+ set temp($i) $element
+ incr i
+ }
+ set result [array get temp]
+ } else {
+ error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format"
+ }
+ }
+ return $result
+}
+
+proc ::p::predator::setprop_template {prop _ID_ args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {"%varspace%" eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" "%varspace%"]} {
+ set ns "%varspace%"
+ } else {
+ set ns ::p::${OID}::%varspace%
+ }
+ }
+
+
+ if {[llength $args] == 1} {
+ #return [set ::p::${OID}::o_%prop% [lindex $args 0]]
+ return [set ${ns}::o_%prop% [lindex $args 0]]
+
+ } else {
+ if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} {
+ #treat attempt to perform indexed write to nonexistant var, same as indexed write to array
+
+ #2 args - single index followed by a value
+ if {[llength $args] == 2} {
+ return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]]
+ } else {
+ #multiple indices
+ #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]]
+ return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ]
+ }
+ } else {
+ #treat as list
+ return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]]
+ }
+ }
+}
+
+#--------------------------------------
+#property read & write traces
+#--------------------------------------
+
+
+proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} {
+
+ #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' "
+
+ #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain.
+
+ if {[llength $idx]} {
+ if {[llength $idx] == 1} {
+ set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx]
+ } else {
+ lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx]
+ }
+ return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value
+ } else {
+ if {![info exists $refname]} {
+ set $refname [$get_cmd $_ID_ {*}$indices]
+ } else {
+ set newval [$get_cmd $_ID_ {*}$indices]
+ if {[set $refname] ne $newval} {
+ set $refname $newval
+ }
+ }
+ return
+ }
+}
+
+
+
+
+proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} {
+ #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname
+ #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'"
+
+
+ #derive the name of the write command from the ref var.
+ set indices [lassign [split [namespace tail $refname] +] prop]
+
+
+ #assert - we will never have both a list in indices and an idx value
+ if {[llength $indices] && ($idx ne "")} {
+ #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x
+ #review - are there any datastructures which would/should allow this?
+ #this assertion is really just here as a sanity check for now
+ error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value"
+ }
+
+ #upvar #0 ::p::${OID}::_meta::map MAP
+ #puts "-->propref_trace_write map: $MAP"
+
+ #temporarily deactivate refsync trace
+ #puts stderr -->1>--removing_trace_o_${field}
+### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop]
+
+ #we need to catch, and re-raise any error that we may receive when writing the property
+ # because we have to reinstate the propvar_write_TraceHandler after the call.
+ #(e.g there may be a propertywrite handler that deliberately raises an error)
+
+ set excludesync_refs $refname
+ set cmd ::p::${OID}::(SET)$prop
+
+
+ set f_error 0
+ if {[catch {
+
+ if {![llength $indices]} {
+ if {[string length $idx]} {
+ $cmd $_ID_ $idx [set ${refname}($idx)]
+ #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx]
+
+ } else {
+ $cmd $_ID_ [set $refname]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list]
+ }
+ } else {
+ #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n"
+ $cmd $_ID_ {*}$indices [set $refname]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices
+ }
+
+ } result]} {
+ set f_error 1
+ }
+
+
+
+
+ #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write
+ #reactivate refsync trace
+ #puts stderr "****** reactivating refsync trace on o_$field"
+ #puts stderr -->2>--reactivating_trace_o_${field}
+ ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop]
+
+
+ if {$f_error} {
+ #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging.
+ # ? return -code error $errMsg ? -errorinfo
+
+ #!quick n dirty
+ #error $errorMsg
+ return -code error -errorinfo $::errorInfo $result
+ } else {
+ return $result
+ }
+}
+
+
+
+
+
+proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} {
+ #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'"
+ #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array')
+
+ set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set
+
+ #set updated_value [::p::predator::getprop_array $prop $_ID_]
+ #puts stderr "-->array_Trace updated_value:$updated_value"
+ if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} {
+ puts stderr "-->propref_trace_array error $errm"
+ array set $refname {}
+ }
+
+ #return value ignored for
+}
+
+
+#--------------------------------------
+#
+proc ::p::predator::object_array_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+
+
+ #don't rely on variable name passed by trace - may have been 'upvar'ed
+ set refvar ::p::${OID}::_ref::__OBJECT
+
+ #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar"
+
+ set iflist [dict get $MAP interfaces level0]
+
+ set plist [list]
+
+ #!todo - get propertylist from cache on object(?)
+ foreach IFID [lreverse $iflist] {
+ dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] {
+ #lassign $pdef v
+ if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} {
+ if {[array exists ::p::${OID}::o_${prop}]} {
+ lappend plist $prop [array get ::p::${OID}::o_${prop}]
+ } else {
+ #ignore - array only represents properties that have been set.
+ #error "property $v is not set"
+ #!todo - unset corresponding items in $refvar if needed?
+ }
+ }
+ }
+ }
+ array set $refvar $plist
+}
+
+
+proc ::p::predator::object_read_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+ #don't rely on variable name passed by trace.
+ set refvar ::p::${OID}::_ref::__OBJECT
+
+ #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n"
+
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+
+ if {[string length $IID]} {
+ #property
+ if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} {
+ puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg"
+ }
+ } else {
+ #method
+ error "property '$idx' not found"
+ }
+}
+
+
+proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+
+ #!todo - ???
+
+ if {![llength [info commands ::p::${OID}::$idx]]} {
+ error "no such method or property: '$idx'"
+ } else {
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set found 0
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set found 1
+ break
+ }
+ }
+
+ if {$found} {
+ unset ::p::${OID}::o_$idx
+ } else {
+ puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx"
+ }
+ }
+}
+
+
+proc ::p::predator::object_write_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+ #don't rely on variable name passed by trace.
+ set refvar ::p::${OID}::_ref::__OBJECT
+ #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar"
+
+
+ if {![llength [info commands ::p::${OID}::$idx]]} {
+ #!todo - create new property in interface upon attempt to write to non-existant?
+ # - or should we require some different kind of object-reference for that?
+ array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx
+ error "no such method or property: '$idx'"
+ } else {
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+
+ #$IID is now topmost interface in default iStack which has this property
+
+ if {[string length $IID]} {
+ #write to defined property
+
+ ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)]
+ } else {
+ #!todo - allow write of method body back to underlying object?
+ #attempted write to 'method' ..undo(?)
+ array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx
+ error "cannot write to method '$idx'"
+ #for now - disallow
+ }
+ }
+
+}
+
+
+
+proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} {
+ #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname
+
+ set refindices [lassign [split [namespace tail $refname] +] prop]
+ #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop
+ #if there is no PropertyUnset command - we unset the underlying variable directly
+
+ trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop]
+
+
+ if {[catch {
+
+ #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value
+ #i.e
+ if {[llength $refindices] && [string length $idx]} {
+ puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'"
+ error "unexpected call to propref_trace_unset"
+ }
+
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set iflist [dict get $MAP interfaces level0]
+ #find topmost interface containing this $prop
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+ if {![string length $IID]} {
+ error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])"
+ }
+
+
+
+
+
+
+ if {[string length $idx]} {
+ #eval "$_alias ${unset_}$field $idx"
+ #what happens to $refindices???
+
+
+ #!todo varspace
+
+ if {![llength $refindices]} {
+ #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ unset ::p::${OID}::o_${prop}($idx)
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx
+ }
+
+
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx
+ } else {
+ #assert - won't get here
+ error 1a
+
+ }
+
+ } else {
+ if {[llength $refindices]} {
+ #error 2a
+ #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ #review - what about list-type property?
+ #if {[array exists ::p::${OID}::o_${prop}]} ???
+ unset ::p::${OID}::o_${prop}($refindices)
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices
+ }
+
+
+
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices
+
+
+ } else {
+ #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ #ref is not of form prop+x etc and no idx in the trace - this is a plain unset
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ unset ::p::${OID}::o_${prop}
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ ""
+ }
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {}
+
+ }
+ }
+
+
+
+
+ } errM]} {
+ #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]"
+ set ruler [string repeat - 80]
+ puts stderr "\t$ruler"
+ puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+ puts stderr "\t$ruler"
+ puts stderr $errM
+ puts stderr "\t$ruler"
+
+ } else {
+ #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+ #puts stderr "*@*@*@*@ end propref_trace_unset - no error"
+ }
+
+ trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop]
+
+
+}
+
+
+
+
+proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} {
+
+ #Do not use 'info exists' (avoid triggering read trace) - use info vars
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ #puts " **> lappending '::p::REF::${OID}::$prop'"
+ lappend refvars ::p::${OID}::_ref::$prop
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*]
+
+
+
+ if {[string length $triggeringRef]} {
+ set idx [lsearch -exact $refvars $triggeringRef]
+ if {$idx >= 0} {
+ set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}]
+ }
+ }
+ if {![llength $refvars]} {
+ #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx"
+ return
+ }
+
+
+ #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset
+ # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b"
+ if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} {
+ #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???"
+ puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'"
+ }
+
+
+ puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' "
+
+
+
+ upvar $vtraced SYNCVARIABLE
+
+
+ #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars
+ array set traces [::list]
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ if {$ops in {read write unset array}} {
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ }
+ }
+ }
+ }
+
+
+
+
+ if {[array exists SYNCVARIABLE]} {
+
+ #underlying variable is an array - we are presumably unsetting just an element
+ set vtracedIsArray 1
+ } else {
+ #!? maybe the var was an array - but it's been unset?
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+ #some things we don't want to repeat for each refvar in case there are lots of them..
+
+ #set triggeringRefIdx $vidx
+
+ if {[string match "${prop}+*" [namespace tail $triggeringRef]]} {
+ set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end]
+ } else {
+ set triggering_indices [list]
+ }
+
+
+
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "--- unset branch refvar:$refvar"
+
+
+
+ if {[llength $vidx]} {
+ #trace called with an index - must be an array
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #!todo - add test
+ if {$vidx eq [lrange [split $reftail +] 1 end]} {
+ #unset if indices match
+ error "untested, possibly unused branch spuds1"
+ #puts "1111111111111111111111111"
+ unset $refvar
+ }
+ } else {
+ #test exists - #!todo - document which one
+
+ #see if we succeeded in unsetting this element in the underlying variables
+ #(may have been blocked by a PropertyUnset body)
+ set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]]
+ #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists"
+ if {$element_exists} {
+ #do nothing it wasn't actually unset
+ } else {
+ #puts "JJJJJ unsetting ${refvar}($vidx)"
+ unset ${refvar}($vidx)
+ }
+ }
+ }
+
+
+
+
+
+ } else {
+
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #check indices of triggering refvar match this refvars indices
+
+
+ if {$reftail eq [namespace tail $triggeringRef]} {
+ #!todo - add test
+ error "untested, possibly unused branch spuds2"
+ #puts "222222222222222222"
+ unset $refvar
+ } else {
+
+ #error "untested - branch spuds2a"
+
+
+ }
+
+ } else {
+ #!todo -add test
+ #reference is directly to property var
+ error "untested, possibly unused branch spuds3"
+ #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string?
+ puts "\t33333333333333333333"
+
+ if {[string length $triggeringRefIdx]} {
+ unset $refvar($triggeringRefIdx)
+ }
+ }
+ }
+
+ }
+
+
+
+
+ #!todo - understand.
+ #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n"
+ #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?)
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing setGet trace '$ops' on variable $rv"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+
+
+
+
+}
+
+
+proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} {
+
+ upvar $vtraced SYNCVARIABLE
+
+ set refvars [::list]
+ #Do not use 'info exists' (avoid triggering read trace) - use info vars
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ lappend refvars ::p::${OID}::_ref::$prop
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*]
+
+
+
+ #short_circuit breaks unset traces for array elements (why?)
+
+
+ if {![llength $refvars]} {
+ #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'"
+ return
+ } else {
+ puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'"
+ }
+
+ if {[catch {
+
+
+
+ #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars
+ array set traces [::list]
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ if {$ops in {read write unset array}} {
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ }
+ }
+ }
+ }
+
+
+
+
+ if {[array exists SYNCVARIABLE]} {
+
+ #underlying variable is an array - we are presumably unsetting just an element
+ set vtracedIsArray 1
+ } else {
+ #!? maybe the var was an array - but it's been unset?
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+ #some things we don't want to repeat for each refvar in case there are lots of them..
+ set triggeringRefIdx $vidx
+
+
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "--- unset branch refvar:$refvar"
+
+
+
+ if {[llength $vidx]} {
+ #trace called with an index - must be an array
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #!todo - add test
+ if {$vidx eq [lrange [split $reftail +] 1 end]} {
+ #unset if indices match
+ error "untested, possibly unused branch spuds1"
+ #puts "1111111111111111111111111"
+ unset $refvar
+ }
+ } else {
+ #test exists - #!todo - document which one
+
+ #see if we succeeded in unsetting this element in the underlying variables
+ #(may have been blocked by a PropertyUnset body)
+ set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]]
+ #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists"
+ if {$element_exists} {
+ #do nothing it wasn't actually unset
+ } else {
+ #puts "JJJJJ unsetting ${refvar}($vidx)"
+ unset ${refvar}($vidx)
+ }
+ }
+ }
+
+
+
+
+
+ } else {
+
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+ unset $refvar
+
+ }
+
+ }
+
+
+
+
+ #!todo - understand.
+ #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n"
+ #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?)
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing setGet trace '$ops' on variable $rv"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+ } errM]} {
+ set ruler [string repeat * 80]
+ puts stderr "\t$ruler"
+ puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op"
+ puts stderr "\t$ruler"
+ puts stderr $::errorInfo
+ puts stderr "\t$ruler"
+
+ }
+
+}
+
+proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} {
+ error hmmmmm
+ upvar $vtraced SYNCVARIABLE
+ #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' "
+ set refvars [::list]
+
+ #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace )
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references
+ #assert triggeringRef is in the list
+ if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} {
+ error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars"
+ }
+ set refposn [lsearch -exact $refvars $triggeringRef]
+ #assert - due to test above, we know $triggeringRef is in the list so refposn > 0
+ set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}]
+ if {![llength $refvars]} {
+ #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop"
+ return [list refs_updates [list]]
+ }
+
+ #suppress the propref_trace_* traces on all refvars
+ array set traces [::list]
+ array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ."
+ #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync
+ #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error?
+ #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref)
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+
+
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ } else {
+ #all other traces are 'external'
+ lappend external_traces($rv) $tinfo
+ #trace remove variable $rv $ops $cmd
+ }
+
+ }
+ }
+ #--------------------------------------------------------------------------------------------------------------------------
+ if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} {
+ if {![info exists SYNCVARIABLE]} {
+ error "WARNING: REVIEW why does $vartraced not exist here?"
+ }
+ #either the underlying variable is an array
+ # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern
+ set treat_vtraced_as_array 1
+ } else {
+ set treat_vtraced_as_array 0
+ }
+
+ set refs_updated [list]
+ set refs_deleted [list] ;#unset due to index no longer being relevant
+ if {$treat_vtraced_as_array} {
+ foreach refvar $refvars {
+ #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'"
+ set refvar_tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $refvar_tail]} {
+ #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y
+ set ref_indices [lrange [split $refvar_tail +] 1 end]
+ if {[llength $indices]} {
+ if {[llength $indices] == 1} {
+ if {[lindex $ref_indices 0] eq [lindex $indices 0]} {
+ #error "untested xxx-a"
+ set ${refvar} [set SYNCVARIABLE([lindex $indices 0])]
+ lappend refs_updated $refvar
+ } else {
+ #test exists
+ #error "xxx-ok single index"
+ #updating a different part of the property - nothing to do
+ }
+ } else {
+ #nested index
+ if {[lindex $ref_indices 0] eq [lindex $indices 0]} {
+ if {[llength $ref_indices] == 1} {
+ #error "untested xxx-b1"
+ set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ]
+ } else {
+ #assert llength $ref_indices > 1
+ #NOTE - we cannot test index equivalence reliably/simply just by comparing indices
+ #compare by value
+
+ if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} {
+ #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'"
+ if {[set $refvar] ne $possiblyNewVal} {
+ set $refvar $possiblyNewVal
+ }
+ } else {
+ #fail to retrieve underlying value corrsponding to these $indices
+ unset $refvar
+ }
+ }
+ } else {
+ #test exists
+ #error "untested xxx-ok deepindex"
+ #updating a different part of the property - nothing to do
+ }
+ }
+ } else {
+ error "untested xxx-c"
+
+ }
+
+ } else {
+ #refvar to update is plain e.g ::p::${OID}::_ref::${prop}
+ if {[llength $indices]} {
+ if {[llength $indices] == 1} {
+ set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])]
+ } else {
+ lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]]
+ }
+ lappend refs_updated $refvar
+ } else {
+ error "untested yyy"
+ set $refvar $SYNCVARIABLE
+ }
+ }
+ }
+ } else {
+ #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x)
+ #
+ foreach refvar $refvars {
+ #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'"
+ set refvar_tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $refvar_tail]} {
+ #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y
+ set ref_indices [lrange [split $refvar_tail +] 1 end]
+
+ if {[llength $indices]} {
+ #see if this update would affect this curried ref
+ #1st see if we can short-circuit our comparison based on numeric-indices
+ if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} {
+ #both sets of indices are purely numeric (no end end-1 etc)
+ set rlen [llength $ref_indices]
+ set ilen [llength $indices]
+ set minlen [expr {min($rlen,$ilen)}]
+ set matched_firstfew_indices 1 ;#assume the best
+ for {set i 0} {$i < $minlen} {incr i} {
+ if {[lindex $ref_indices $i] ne [lindex $indices $i]} {
+ break ;#
+ }
+ }
+ if {!$matched_firstfew_indices} {
+ #update of this refvar not required
+ #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices"
+ break ;#break to next refvar in the foreach loop
+ }
+ }
+ #failed to short-circuit
+
+ #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here
+ set newval [lindex $SYNCVARIABLE $ref_indices]
+ if {[set $refvar] ne $newval} {
+ set $refvar $newval
+ lappend refs_updated $refvar
+ }
+
+ } else {
+ #we must be updating the entire variable - so this curried ref will either need to be updated or unset
+ set newval [lindex $SYNCVARIABLE $ref_indices]
+ if {[set ${refvar}] ne $newval} {
+ set ${refvar} $newval
+ lappend refs_updated $refvar
+ }
+ }
+ } else {
+ #refvar to update is plain e.g ::p::${OID}::_ref::${prop}
+ if {[llength $indices]} {
+ #error "untested zzz-a"
+ set newval [lindex $SYNCVARIABLE $indices]
+ if {[lindex [set $refvar] $indices] ne $newval} {
+ lset ${refvar} $indices $newval
+ lappend refs_updated $refvar
+ }
+ } else {
+ if {[set ${refvar}] ne $SYNCVARIABLE} {
+ set ${refvar} $SYNCVARIABLE
+ lappend refs_updated $refvar
+ }
+ }
+
+ }
+
+ }
+ }
+ #--------------------------------------------------------------------------------------------------------------------------
+
+ #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ if {$rv ni $refs_deleted} {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+ }
+ foreach rv [array names external_traces] {
+ if {$rv ni $refs_deleted} {
+ foreach tinfo $external_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #trace add variable $rv $ops $cmd
+ }
+ }
+ }
+
+
+ return [list updated_refs $refs_updated]
+}
+
+#purpose: update all relevant references when context variable changed directly
+proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} {
+ #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way.
+ #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler
+
+ upvar $vtraced SYNCVARIABLE
+ #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op"
+ set t_info [trace info variable $vtraced]
+ foreach t_spec $t_info {
+ set t_ops [lindex $t_spec 0]
+ if {$op in $t_ops} {
+ puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]"
+ }
+ }
+
+ #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*-
+ #vtype = array | array-item | list | simple
+
+ set refvars [::list]
+
+ ############################
+ #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!!
+ #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs)
+ #The alternative 'info vars' does not trigger traces
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ #puts " **> lappending '::p::REF::${OID}::$prop'"
+ lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ }
+ ############################
+
+ #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references
+
+
+ if {![llength $refvars]} {
+ #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop"
+ return
+ }
+
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+ #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars
+ array set predator_traces [::list]
+ #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace..
+ #ie for something like 'trace add variable someref {write read array} somefunc'
+ # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace
+ array set external_read_traces [::list] ;#pure read traces the library user may have added
+ array set external_readetc_traces [::list] ;#read + something else traces the library user may have added
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ #if {$ops in {read write unset array}} {}
+
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend predator_traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ } else {
+ #other traces
+ # puts "##trace $tinfo"
+ if {"read" in $ops} {
+ if {[llength $ops] == 1} {
+ #pure read -
+ lappend external_read_traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ } else {
+ #mixed operation trace - remove and reinstall without the 'read'
+ lappend external_readetc_traces($rv) $tinfo
+ set other_ops [lsearch -all -inline -not $ops "read"]
+ trace remove variable $rv $ops $cmd
+ #reinstall trace for non-read operations only
+ trace add variable $rv $other_ops $cmd
+ }
+ }
+ }
+ }
+ }
+
+
+ if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} {
+ #either the underlying variable is an array
+ # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern
+ set vtracedIsArray 1
+ } else {
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op"
+ #puts "**write*********** refvars: $refvars"
+
+ #!todo? unroll foreach into multiple foreaches within ifs?
+ #foreach refvar $refvars {}
+
+
+ #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar"
+ if {[string length $vidx]} {
+ #indexable
+ if {$vtracedIsArray} {
+
+ foreach refvar $refvars {
+ #puts stderr " - - a refvar $refvar vidx: $vidx"
+ set tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $tail]} {
+ #refvar is curried
+ #only set if vidx matches curried index
+ #!todo -review
+ set idx [lrange [split $tail +] 1 end]
+ if {$idx eq $vidx} {
+ set newval [set SYNCVARIABLE($vidx)]
+ if {[set $refvar] ne $newval} {
+ set ${refvar} $newval
+ }
+ #puts stderr "=a.1=> updated $refvar"
+ }
+ } else {
+ #refvar is simple
+ set newval [set SYNCVARIABLE($vidx)]
+ if {![info exists ${refvar}($vidx)]} {
+ #new key for this array
+ #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' "
+ array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ]
+ } else {
+ set oldval [set ${refvar}($vidx)]
+ if {$oldval ne $newval} {
+ #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' "
+ array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ]
+ }
+ }
+ #puts stderr "=a.2=> updated ${refvar} $vidx"
+ }
+ }
+
+
+
+ } else {
+
+
+ foreach refvar $refvars {
+ upvar $refvar internal_property_reference
+ #puts stderr " - - b vidx: $vidx"
+
+ #!? could be object not list??
+ #!!but what is the difference between an object, and a list of object names which happens to only contain one object??
+ #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations)
+ #There would still be an edge case of an initial write of a list of objects of length 1.
+ if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} {
+ error "untested review!"
+ #the o_prop is object-shaped
+ #assumes object has a defaultmethod which accepts indices
+ set newval [[set $SYNCVARIABLE] {*}$vidx]
+
+ } else {
+ set newval [lindex $SYNCVARIABLE {*}$vidx]
+ #if {[set $refvar] ne $newval} {
+ # set $refvar $newval
+ #}
+ if {$internal_property_reference ne $newval} {
+ set internal_property_reference $newval
+ }
+
+ }
+ #puts stderr "=b=> updated $refvar"
+ }
+
+
+ }
+
+
+
+ } else {
+ #no vidx
+
+ if {$vtracedIsArray} {
+
+
+ foreach refvar $refvars {
+ set targetref_tail [namespace tail $refvar]
+ set targetref_is_indexed [string match "${prop}+*" $targetref_tail]
+
+
+ #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef"
+ if {$targetref_is_indexed} {
+ #curried array item ref of the form ${prop}+x or ${prop}+x+y etc
+
+ #unindexed write on a property that is acting as an array..
+
+ #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok.
+
+ #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index).
+ # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing.
+ puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op"
+ } else {
+ #How do we know what to write to array ref?
+ puts stderr "\tc.2 WARNING: unimplemented/unused?"
+ #error no_tests_for_branch
+
+ #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation
+ #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate
+ array unset ${refvar}
+ array set ${refvar} [array get SYNCVARIABLE]
+ }
+ }
+
+
+
+ } else {
+ foreach refvar $refvars {
+ #puts stderr "\t\t_________________[namespace current]"
+ set targetref_tail [namespace tail $refvar]
+ upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail
+ set targetref_is_indexed [string match "${prop}+*" $targetref_tail]
+
+ if {$targetref_is_indexed} {
+ #puts "XXXXXXXXX vtraced:$vtraced"
+ #reference curried with index(es)
+ #we only set indexed refs if value has changed
+ # - this not required to be consistent with standard list-containing variable traces,
+ # as normally list elements can't be traced seperately anyway.
+ #
+
+
+ #only bother checking a ref if no setVia index
+ # i.e some operation on entire variable so need to test synchronisation for each element-ref
+ set targetref_indices [lrange [split $targetref_tail +] 1 end]
+ set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices]
+ #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal"
+ if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} {
+ set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal
+ #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]"
+ }
+
+
+ } else {
+ #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed!
+
+ #puts stderr "- d2 set"
+ #puts "refvar: [set $refvar]"
+ #puts "SYNCVARIABLE: $SYNCVARIABLE"
+
+ #if {[set $refvar] ne $SYNCVARIABLE} {
+ # set $refvar $SYNCVARIABLE
+ #}
+ if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} {
+ set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE
+ }
+
+ }
+ }
+
+
+ }
+
+ }
+
+
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names predator_traces] {
+ foreach tinfo $predator_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+ foreach rv [array names external_traces] {
+ foreach tinfo $external_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+
+
+}
+
+# end propvar_write_TraceHandler
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#
+
+#returns 0 if method implementation not present for interface
+proc ::p::predator::method_chainhead {iid method} {
+ #Interface proc
+ # examine the existing command-chain
+ set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex)
+ set cmdchain [list]
+
+ set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}]
+ set maxversion 0
+ #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob.
+ foreach test [lsort -dictionary $candidates] {
+ set c [namespace tail $test]
+ if {[regexp $re $c _match version]} {
+ lappend cmdchain $c
+ if {$version > $maxversion} {
+ set maxversion $version
+ }
+ }
+ }
+ return $maxversion
+}
+
+
+
+
+
+#this returns a script that upvars vars for all interfaces on the calling object -
+# - must be called at runtime from a method
+proc ::p::predator::upvar_all {_ID_} {
+ #::set OID [lindex $_ID_ 0 0]
+ ::set OID [::lindex [::dict get $_ID_ i this] 0 0]
+ ::set decl {}
+ #[set ::p::${OID}::_meta::map]
+ #[dict get [lindex [dict get $_ID_ i this] 0 1] map]
+
+ ::upvar #0 ::p::${OID}::_meta::map MAP
+ #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n"
+ #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0]
+
+ ::foreach ifid [dict get $MAP interfaces level0] {
+ if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} {
+ ::array unset nsvars
+ ::array set nsvars [::list]
+ ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] {
+ ::set varspace [::dict get $vinfo varspace]
+ ::lappend nsvars($varspace) $vname
+ }
+ #nsvars now contains vars grouped by varspace.
+
+ ::foreach varspace [::array names nsvars] {
+ if {$varspace eq ""} {
+ ::set ns ::p::${OID}
+ } else {
+ if {[::string match "::*" $varspace]} {
+ ::set ns $varspace
+ } else {
+ ::set ns ::p::${OID}::$varspace
+ }
+ }
+
+ ::append decl "namespace upvar $ns "
+ ::foreach vname [::set nsvars($varspace)] {
+ ::append decl "$vname $vname "
+ }
+ ::append decl " ;\n"
+ }
+ ::array unset nsvars
+ }
+ }
+ ::return $decl
+}
+
+#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator)
+proc ::p::predator::runtime_vardecls {} {
+ set result "::eval \[::p::predator::upvar_all \$_ID_\]"
+ #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_"
+
+ #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]"
+ #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]"
+ #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'"
+ return $result
+}
+
+
+
+
+
+
+#OBSOLETE!(?) - todo - move stuff out of here.
+proc ::p::predator::compile_interface {IFID caller_ID_} {
+ upvar 0 ::p::${IFID}:: IFACE
+
+ #namespace eval ::p::${IFID} {
+ # namespace ensemble create
+ #}
+
+ #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables
+
+ namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces
+
+ #set varDecls {}
+ #if {[llength $o_variables]} {
+ # #puts "*********!!!! $vlist"
+ # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] "
+ # foreach vdef $o_variables {
+ # append varDecls "[lindex $vdef 0] [lindex $vdef 0] "
+ # }
+ # append varDecls \n
+ #}
+
+ #runtime gathering of vars from other interfaces.
+ #append varDecls [runtime_vardecls]
+
+ set varDecls [runtime_vardecls]
+
+
+
+ #implement methods
+
+ #!todo - avoid globs on iface array? maintain list of methods in another slot?
+ #foreach {n mname} [array get IFACE m-1,name,*] {}
+
+
+ #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble.
+
+
+
+ #implement property getters/setters/unsetters
+ #'setter' overrides
+ #pw short for propertywrite
+ foreach {n property} [array get IFACE pw,name,*] {
+ if {[string length $property]} {
+ #set property [lindex [split $n ,] end]
+
+ #!todo - next_script
+ #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property]
+
+ set maxversion [::p::predator::method_chainhead $IFID (SET)$property]
+ set chainhead [expr {$maxversion + 1}]
+ set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1
+
+ set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??
+
+ set body $IFACE(pw,body,$property)
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body"
+ }
+
+ #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+
+ set maxversion [::p::predator::method_chainhead $IFID $property]
+ set headid [expr {$maxversion + 1}]
+
+ proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body
+
+ interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid
+
+ #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body
+ }
+ }
+ #'unset' overrides
+
+ dict for {property handler_info} $o_propertyunset_handlers {
+
+ set body [dict get $handler_info body]
+ set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array
+
+ set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (UNSET)$property.$headid
+
+ set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ???
+
+
+
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body"
+
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+
+
+ #implement
+ #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements)
+ if {[string trim $arraykeypattern] eq ""} {
+ set arraykeypattern "_dontcare_"
+ }
+ proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body
+
+
+ #chainhead pointer
+ interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid
+ }
+
+
+
+ interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE)
+
+ #the usual case will have no destructor - so use info exists to check.
+
+ if {[info exists ::p::${IFID}::_iface::o_destructor_body]} {
+ #!todo - chained destructors (support @next@).
+ #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID]
+ set next NEXT
+
+ set body [set ::p::${IFID}::_iface::o_destructor_body]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body"
+ }
+ #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body]
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ proc ::p::${IFID}::___system___destructor _ID_ $body
+ }
+
+
+ if {[info exists o_unknown]} {
+ #use 'apply' somehow?
+ interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown
+
+ #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown]
+ }
+
+
+ return
+}
+
+
+
+
+
+
+
+#'info args' - assuming arbitrary chain of 'interp aliases'
+proc ::p::predator::command_info_args {cmd} {
+ if {[llength [set next [interp alias {} $cmd]]]} {
+ set curriedargs [lrange $next 1 end]
+
+ if {[catch {set arglist [info args [lindex $next 0]]}]} {
+ set arglist [command_info_args [lindex $next 0]]
+ }
+ #trim curriedargs
+ return [lrange $arglist [llength $curriedargs] end]
+ } else {
+ info args $cmd
+ }
+}
+
+
+proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} {
+ if {[llength $args]} {
+ tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args
+ } else {
+ if {[llength $nextArgs] > 1} {
+ set argVals [::list]
+ set i 0
+ foreach arg [lrange $nextArgs 1 end] {
+ upvar 1 $arg $i
+ if {$arg eq "args"} {
+ #need to check if 'args' is actually available in caller
+ if {[info exists $i]} {
+ set argVals [concat $argVals [set $i]]
+ }
+ } else {
+ lappend argVals [set $i]
+ }
+ }
+ tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals
+ } else {
+ tailcall ::p::${IFID}::_iface::$mname $_ID_
+ }
+ }
+}
+
+#----------------------------------------------------------------------------------------------
+proc ::p::predator::next_script {IFID method caller caller_ID_} {
+
+ if {$caller eq "(CONSTRUCTOR).1"} {
+ return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}]
+ } elseif {$caller eq "$method.1"} {
+ #delegate to next interface lower down the stack which has a member named $method
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ } elseif {[string match "(GET)*.2" $caller]} {
+ # .1 is the getprop procedure, .2 is the bottom-most PropertyRead.
+
+ #jmn
+ set prop [string trimright $caller 1234567890]
+ set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing .
+
+ if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} {
+ #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}]
+ return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}]
+ } else {
+ #we can actually have a property read without a property or a method of that name - but it could also match the name of a method.
+ # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something)
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ }
+ } elseif {[string match "(SET)*.2" $caller]} {
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ } else {
+ #this branch will also handle (SET)*.x and (GET)*.x where x >2
+
+ #puts stdout "............next_script IFID:$IFID method:$method caller:$caller"
+ set callerid [string range $caller [string length "$method."] end]
+ set nextid [expr {$callerid - 1}]
+
+ if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} {
+ #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface.
+ #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid"
+ set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid]
+ }
+
+ return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}]
+ }
+}
+
+proc ::p::predator::do_next_if {_ID_ IFID method args} {
+ #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' ((("
+
+ #set invocants [dict get $_ID_ i]
+ #set this_invocantdata [lindex [dict get $invocants this] 0]
+ #lassign $this_invocantdata OID this_info
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set interfaces [dict get $MAP interfaces level0]
+ set patterninterfaces [dict get $MAP interfaces level1]
+
+ set L0_posn [lsearch $interfaces $IFID]
+ if {$L0_posn == -1} {
+ error "(::p::predator::do_next_if) called with interface not present at level0 for this object"
+ } elseif {$L0_posn > 0} {
+ #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack
+ set lower_interfaces [lrange $interfaces 0 $L0_posn-1]
+
+ foreach if_sub [lreverse $lower_interfaces] {
+ if {[string match "(GET)*" $method]} {
+ #do not test o_properties here! We need to call even if there is no underlying property on this interface
+ #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface)
+ # relevant test: higher_order_propertyread_chaining
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ } elseif {[string match "(SET)*" $method]} {
+ #must be called even if there is no matching $method in o_properties
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ } elseif {[string match "(UNSET)*" $method]} {
+ #review untested
+ #error "do_next_if (UNSET) untested"
+ #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'"
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+
+ } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} {
+ if {[llength $args]} {
+ #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args"
+
+ #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args
+
+ #!todo - handle case where llength $args is less than number of args for subinterface command
+ #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set)
+
+ #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature)
+ set head [interp alias {} ::p::${if_sub}::_iface::$method]
+ set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc
+ set argx [list]
+ foreach a $nextArgs {
+ lappend argx "\$a"
+ }
+
+ #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared
+
+ if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} {
+ tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args
+ } else {
+ #todo - upvars required for tail end of arglist
+ tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args
+ }
+
+ } else {
+ #auto-set: upvar vars from calling scope
+ #!todo - robustify? alias not necessarily matching command name..
+ set head [interp alias {} ::p::${if_sub}::_iface::$method]
+
+
+ set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc
+ if {[llength $nextArgs] > 1} {
+ set argVals [::list]
+ set i 0
+ foreach arg [lrange $nextArgs 1 end] {
+ upvar 1 $arg $i
+ if {$arg eq "args"} {
+ #need to check if 'args' is actually available in caller
+ if {[info exists $i]} {
+ set argVals [concat $argVals [set $i]]
+ }
+ } else {
+ lappend argVals [set $i]
+ }
+ }
+ #return [$head $_ID_ {*}$argVals]
+ tailcall $head $_ID_ {*}$argVals
+ } else {
+ #return [$head $_ID_]
+ tailcall $head $_ID_
+ }
+ }
+ } elseif {$method eq "(CONSTRUCTOR)"} {
+ #chained constructors will only get args if the @next@ caller explicitly provided them.
+ puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!"
+ #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args]
+ xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args
+ }
+ }
+ #no interfaces in the iStack contained a matching method.
+ return
+ } else {
+ #no further interfaces in this iStack
+ return
+ }
+}
+
+
+#only really makes sense for (CONSTRUCTOR) calls.
+#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class.
+proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} {
+ #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' ((("
+
+ #set invocants [dict get $_ID_ i]
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID this_info
+ #set OID [lindex [dict get $invocants this] 0 0]
+ #upvar #0 ::p::${OID}::_meta::map map
+ #lassign [lindex $map 0] OID alias itemCmd cmd
+
+
+ set caller_OID [lindex [dict get $caller_ID_ i this] 0 0]
+ upvar #0 ::p::${caller_OID}::_meta::map callermap
+
+ #set interfaces [lindex $map 1 0]
+ set patterninterfaces [dict get $callermap interfaces level1]
+
+ set L0_posn [lsearch $patterninterfaces $IFID]
+ if {$L0_posn == -1} {
+ error "do_next_pattern_if called with interface not present at level1 for this object"
+ } elseif {$L0_posn > 0} {
+
+
+ set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1]
+
+ foreach if_sub [lreverse $lower_interfaces] {
+ if {$method eq "(CONSTRUCTOR)"} {
+ #chained constructors will only get args if the @next@ caller explicitly provided them.
+ #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!"
+ tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args
+ }
+ }
+ #no interfaces in the iStack contained a matching method.
+ return
+ } else {
+ #no further interfaces in this iStack
+ return
+ }
+}
+
+
+
+
+
+#------------------------------------------------------------------------------------------------
+
+
+
+
+
+#-------------------------------------------------------------------------------------
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+
+
+#!todo - can we just call new_object somehow to create this?
+
+ #until we have a version of Tcl that doesn't have 'creative writing' scope issues -
+ # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword.
+ # (see http://mini.net/tcl/1030 'Dangers of creative writing')
+namespace eval ::p::-1 {
+ #namespace ensemble create
+
+ namespace eval _ref {}
+ namespace eval _meta {}
+
+ namespace eval _iface {
+ variable o_usedby
+ variable o_open
+ variable o_constructor
+ variable o_variables
+ variable o_properties
+ variable o_methods
+ variable o_definition
+ variable o_varspace
+ variable o_varspaces
+
+ array set o_usedby [list i0 1] ;#!todo - review
+ #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value?
+
+ set o_open 1
+ set o_constructor [list]
+ set o_variables [list]
+ set o_properties [dict create]
+ set o_methods [dict create]
+ array set o_definition [list]
+ set o_varspace ""
+ set o_varspaces [list]
+ }
+}
+
+
+#
+
+#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}]
+interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}]
+
+
+upvar #0 ::p::-1::_iface::o_definition def
+
+
+#! concatenate -> compose ??
+dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}}
+proc ::p::-1::Concatenate {_ID_ target args} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ if {![string match "::*" $target]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set target ::$target
+ } else {
+ set target ${ns}::$target
+ }
+ }
+ #add > character if not already present
+ set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >]
+ set _target [string map {::> ::} $target]
+
+ set ns [namespace qualifiers $target]
+ if {$ns eq ""} {
+ set ns "::"
+ } else {
+ namespace eval $ns {}
+ }
+
+ if {![llength [info commands $target]]} {
+ #degenerate case - target does not exist
+ #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone'
+ #review - should be 'Copy' so it has object state from namespaces and variables?
+ return [::p::-1::Clone $_ID_ $target {*}$args]
+
+ #set TARGETMAP [::p::predator::new_object $target]
+ #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd
+
+ } else {
+ #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1]
+ set TARGETMAP [$target --]
+
+ lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd
+
+ #Merge lastmodified(?) level0 and level1 interfaces.
+
+ }
+
+ return $target
+}
+
+
+
+#Object's Base-Interface proc with itself as curried invocant.
+#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant
+#namespace eval ::p::-1 {namespace export Create}
+dict set ::p::-1::_iface::o_methods Define {arglist definitions}
+#define objects in one step
+proc ::p::-1::Define {_ID_ definitions} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias default_method cmd
+ set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces
+ set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces
+
+ #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack
+ #set IFID0 [lindex $interfaces 0]
+ #set IFID1 [lindex $patterns 0] ;#1st pattern
+
+ #set IFID_TOP [lindex $interfaces end]
+ set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID]
+
+ #set ns ::p::${OID}
+
+ #set script [string map [list %definitions% $definitions] {
+ # if {[lindex [namespace path] 0] ne "::p::-1"} {
+ # namespace path [list ::p::-1 {*}[namespace path]]
+ # }
+ # %definitions%
+ # namespace path [lrange [namespace path] 1 end]
+ #
+ #}]
+
+ set script [string map [list %id% $_ID_ %definitions% $definitions] {
+ set ::p::-1::temp_unknown [namespace unknown]
+
+ namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}]
+
+
+ #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ]
+
+
+ %definitions%
+
+
+ namespace unknown ${::p::-1::temp_unknown}
+ return
+ }]
+
+
+
+ #uplevel 1 $script ;#this would run the script in the global namespace
+ #run script in the namespace of the open interface, this allows creating of private helper procs
+ #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack
+ #namespace inscope ::p::${OID} $script
+ namespace eval ::p::${OID} $script
+ #return $cmd
+}
+
+
+proc ::p::predator::redirect {func args} {
+
+ #todo - review tailcall - tests?
+ if {![llength [info commands ::p::-1::$func]]} {
+ #error "invalid command name \"$func\""
+ tailcall uplevel 1 [list ::unknown $func {*}$args]
+ } else {
+ tailcall uplevel 1 [list ::p::-1::$func {*}$args]
+ }
+}
+
+
+#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review.
+dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}}
+proc ::p::-1::Construct {_ID_ argpairs body args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+ namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ set ARGSETTER {}
+ foreach {argname argval} $argpairs {
+ append ARGSETTER "set $argname $argval\n"
+ }
+ #$_self (VIOLATE) $ARGSETTER$body
+
+ set body $ARGSETTER\n$body
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls\n[dict get $processed body]
+ # puts stderr "\t runtime_vardecls in Construct $varDecls"
+ }
+
+ set next "\[error {next not implemented}\]"
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ #namespace eval ::p::${iid_top} $body
+
+ #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_]
+ #does this handle Varspace before constructor?
+ return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args]
+}
+
+
+
+
+
+#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects
+namespace eval ::p::3 {}
+proc ::p::3::_create {child {OID "-2"}} {
+ #puts stderr "::p::3::_create $child $OID"
+ set _child [string map {::> ::} $child]
+ if {$OID eq "-2"} {
+ #set childmapdata [::p::internals::new_object $child]
+ #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ]
+ set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0]
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+ } else {
+ set child_ID $OID
+ #set _childmap [::p::internals::new_object $child "" $child_ID]
+ ::p::internals::new_object $child "" $child_ID
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+ }
+
+ #--------------
+
+ set oldinterfaces [dict get $CHILDMAP interfaces]
+ dict set oldinterfaces level0 [list 2]
+ set modifiedinterfaces $oldinterfaces
+ dict set CHILDMAP interfaces $modifiedinterfaces
+
+ #--------------
+
+
+
+
+ #puts stderr ">>>> creating alias for ::p::$child_ID"
+ #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]"
+
+ #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing!
+ #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]]
+ #puts stderr ">>>[interp alias {} ::p::$child_ID]"
+
+
+
+ #---------------
+ namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties
+ foreach method [dict keys $o_methods] {
+ #todo - change from interp alias to context proc
+ interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method
+ }
+ #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods]
+ #implement property even if interface already compiled because we need to create defaults for each new child obj.
+ # also need to add alias on base interface
+ #make sure we are only implementing properties from the current CREATOR
+ dict for {prop pdef} $o_properties {
+ #lassign $pdef prop default
+ interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop
+ interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop
+
+ }
+ ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}]
+ #---------------
+ #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child"
+ return $child
+}
+
+#configure -prop1 val1 -prop2 val2 ...
+dict set ::p::-1::_iface::o_methods Configure {arglist args}
+proc ::p::-1::Configure {_ID_ args} {
+
+ #!todo - add tests.
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd this
+
+ if {![expr {([llength $args] % 2) == 0}]} {
+ error "expected even number of Configure args e.g '-property1 value1 -property2 value2'"
+ }
+
+ #Do a separate loop to check all the arguments before we run the property setting loop
+ set properties_to_configure [list]
+ foreach {argprop val} $args {
+ if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} {
+ error "expected Configure args in the form: '-property1 value1 -property2 value2'"
+ }
+ lappend properties_to_configure [string range $argprop 1 end]
+ }
+
+ #gather all valid property names for all level0 interfaces in the relevant interface stack
+ set valid_property_names [list]
+ set iflist [dict get $MAP interfaces level0]
+ foreach id [lreverse $iflist] {
+ set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]]
+ foreach if_prop $interface_property_names {
+ if {$if_prop ni $valid_property_names} {
+ lappend valid_property_names $if_prop
+ }
+ }
+ }
+
+ foreach argprop $properties_to_configure {
+ if {$argprop ni $valid_property_names} {
+ error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names"
+ }
+ }
+
+ set top_IID [lindex $iflist end]
+ #args ok - go ahead and set all properties
+ foreach {prop val} $args {
+ set property [string range $prop 1 end]
+ #------------
+ #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update
+ #ie don't do this here: set [$this . $property .] $val
+ #-------------
+ ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val]
+ }
+ return
+}
+
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid}
+proc ::p::-1::AddPatternInterface {_ID_ iid} {
+ #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid"
+ if {![string is integer -strict $iid]} {
+ error "adding interface by name not yet supported. Please use integer id"
+ }
+
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ #lassign [lindex $invocant 0] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces
+
+
+
+ #it is theoretically possible to have the same interface present multiple times in an iStack.
+ # #!todo -review why/whether this is useful. should we disallow it and treat as an error?
+
+ lappend existing_ifaces $iid
+ #lset map {1 1} $existing_ifaces
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 $existing_ifaces
+ dict set MAP interfaces $extracted_sub_dict
+
+ #lset invocant {1 1} $existing_ifaces
+
+}
+
+
+#!todo - update usedby ??
+dict set ::p::-1::_iface::o_methods AddInterface {arglist iid}
+proc ::p::-1::AddInterface {_ID_ iid} {
+ #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid"
+ if {![string is integer -strict $iid]} {
+ error "adding interface by name not yet supported. Please use integer id"
+ }
+
+
+ lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list.
+ set this_invocant [lindex $list_of_invocants_for_role_this 0]
+
+ lassign $this_invocant OID _etc
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set existing_ifaces [dict get $MAP interfaces level0]
+
+ lappend existing_ifaces $iid
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 $existing_ifaces
+ dict set MAP interfaces $extracted_sub_dict
+ return [dict get $extracted_sub_dict level0]
+}
+
+
+
+# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module.
+# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist
+# and 'CreateOverlay' for the case where the target/child object already exists.
+# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence,
+# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object.
+# 'CreateNew' will raise an error if the target already exists
+# 'CreateOverlay' will raise an error if the target object does not exist.
+# 'Create' will work in either case. Creating the target if necessary.
+
+
+#simple form:
+# >somepattern .. Create >child
+#simple form with arguments to the constructor:
+# >somepattern .. Create >child arg1 arg2 etc
+#complex form - specify more info about the target (dict keyed on childobject name):
+# >somepattern .. Create {>child {-id 1}}
+#or
+# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}]
+#complex form - with arguments to the contructor:
+# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc
+dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}}
+proc ::p::-1::Create {_ID_ target_spec args} {
+ #$args are passed to constructor
+ if {[llength $target_spec] ==1} {
+ set child $target_spec
+ set targets [list $child {}]
+ } else {
+ set targets $target_spec
+ }
+
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case)
+
+ foreach {child target_spec_dict} $targets {
+ #puts ">>>::p::-1::Create $_ID_ $child $args <<<"
+
+
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+
+
+
+ #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID"
+
+ #child should already be fully ns qualified (?)
+ #ensure it is has a pattern-object marker >
+ #puts stderr ".... $child (nsqual: [namespace qualifiers $child])"
+
+
+ lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd
+ set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces
+ set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces
+ #puts "parent: $OID -> child:$child Patterns $patterns"
+
+ #todo - change to dict of interface stacks
+ set IFID0 [lindex $interfaces 0]
+ set IFID1 [lindex $patterns 0] ;#1st pattern
+
+ #upvar ::p::${OID}:: INFO
+
+ if {![string match {::*} $child]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set child ::$child
+ } else {
+ set child ${ns}::$child
+ }
+ }
+
+
+ #add > character if not already present
+ set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >]
+ set _child [string map {::> ::} $child]
+
+ set ns [namespace qualifiers $child]
+ if {$ns eq ""} {
+ set ns "::"
+ } else {
+ namespace eval $ns {}
+ }
+
+
+ #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls.
+ set new_interfaces [list]
+
+ if {![llength $patterns]} {
+ ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child"
+ #lappend patterns [::p::internals::new_interface $OID]
+
+ #lset invocant {1 1} $patterns
+ ##update our command because we changed the interface list.
+ #set IFID1 [lindex $patterns 0]
+
+ #set patterns [list [::p::internals::new_interface $OID]]
+
+ #set patterns [list [::p::internals::new_interface]]
+
+ #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id
+ #set patterns [list [set iid [incr ::p::ID]]]
+ set patterns [list [set iid [::p::get_new_object_id]]]
+
+ #---------
+ #set iface [::p::>interface .. Create ::p::ifaces::>$iid]
+ #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid
+
+ #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation
+ lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid]
+
+ #---------
+
+ #puts "??> p::>interface .. Create ::p::ifaces::>$iid"
+ #puts "??> [::p::ifaces::>$iid --]"
+ #set [$iface . UsedBy .]
+ }
+ set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod]
+
+ #if {![llength [info commands $child]]} {}
+
+ if {[namespace which $child] eq ""} {
+ #normal case - target/child does not exist
+ set is_new_object 1
+
+ if {[dict exists $target_spec_dict -id]} {
+ set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]]
+ } else {
+ set childmapdata [::p::internals::new_object $child]
+ }
+ lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+
+
+
+ #child initially uses parent's level1 interface as it's level0 interface
+ # child has no level1 interface until PatternMethods or PatternProperties are added
+ # (or applied via clone; or via create with a parent with level2 interface)
+ #set child_IFID $IFID1
+
+ #lset CHILDMAP {1 0} [list $IFID1]
+ #lset CHILDMAP {1 0} $patterns
+
+ set extracted_sub_dict [dict get $CHILDMAP interfaces]
+ dict set extracted_sub_dict level0 $patterns
+ dict set CHILDMAP interfaces $extracted_sub_dict
+
+ #why write back when upvared???
+ #review
+ set ::p::${child_ID}::_meta::map $CHILDMAP
+
+ #::p::predator::remap $CHILDMAP
+
+ #interp alias {} $child {} ::p::internals::predator $CHILDMAP
+
+ #set child_IFID $IFID1
+
+ #upvar ::p::${child_ID}:: child_INFO
+
+ #!todo review
+ #set n ::p::${child_ID}
+ #if {![info exists ${n}::-->PATTERN_ANCHOR]} {
+ # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'"
+ # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack
+ # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset"
+ # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n]
+ #}
+
+ set ifaces_added $patterns
+
+ } else {
+ #overlay/mixin case - target/child already exists
+ set is_new_object 0
+
+ #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1]
+ set childmapdata [$child --]
+
+
+ #puts stderr " *** $cmd .. Create -> target $child already exists!!!"
+ #puts " **** CHILDMAP: $CHILDMAP"
+ #puts " ****"
+
+ #puts stderr " ---> Properties: [$child .. Properties . names]"
+ #puts stderr " ---> Methods: [$child .. Properties . names]"
+
+ lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+
+ #set child_IFID [lindex $CHILDMAP 1 0 end]
+ #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} {
+ # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID]
+ # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP
+ #}
+ ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces
+ #::p::merge_interface $IFID1 $child_IFID
+
+
+ set existing_interfaces [dict get $CHILDMAP interfaces level0]
+ set ifaces_added [list]
+ foreach p $patterns {
+ if {$p ni $existing_interfaces} {
+ lappend ifaces_added $p
+ }
+ }
+
+ if {[llength $ifaces_added]} {
+ #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added]
+ set extracted_sub_dict [dict get $CHILDMAP interfaces]
+ dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added]
+ dict set CHILDMAP interfaces $extracted_sub_dict
+ #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why?
+ #::p::predator::remap $CHILDMAP
+ }
+ }
+
+ #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty
+ if {$parent_patterndefaultmethod ne ""} {
+ set child_defaultmethod $parent_patterndefaultmethod
+ set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata]
+ lset CHILD_INVOCANTDATA 2 $child_defaultmethod
+ dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA
+ #update the child's _ID_
+ interp alias {} $child_alias {} ;#first we must delete it
+ interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}]
+
+ #! object_command was initially created as the renamed alias - so we have to do it again
+ rename $child_alias $child
+ trace add command $child rename [list $child .. Rename]
+ }
+ #!todo - review - dont we already have interp alias entries for every method/prop?
+ #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child"
+
+
+
+
+
+ set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call.
+
+
+
+ #------------------------------------------------------------------------------------
+ #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail.
+ # - All variables under the namespace - not just those declared as Variables or Properties
+ # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces.
+ # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write.
+
+ #NOTE - do not use the objectID as the sole identifier for the snapshot namespace.
+ # - there may be multiple active snapshots for a single object if it overlays itself during a constructor,
+ # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call.
+ # - we will use an ever-increasing snapshotid to form part of ns_snap
+ set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create.
+
+ #!todo - this should look at child namespaces (recursively?)
+ #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces.
+ # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace)
+
+ namespace eval $ns_snap {}
+ foreach vname [info vars ::p::${child_ID}::*] {
+ set shortname [namespace tail $vname]
+ if {[array exists $vname]} {
+ array set ${ns_snap}::${shortname} [array get $vname]
+ } elseif {[info exists $vname]} {
+ set ${ns_snap}::${shortname} [set $vname]
+ } else {
+ #variable exists without value (e.g created by 'variable' command)
+ namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist'
+ }
+ }
+ #------------------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+ #puts "====>>> ifaces_added $ifaces_added"
+ set idx 0
+ set idx_count [llength $ifaces_added]
+ set highest_constructor_IFID ""
+ foreach IFID $ifaces_added {
+ incr idx
+ #puts "--> adding iface $IFID "
+ namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces
+
+ if {[llength $o_varspaces]} {
+ foreach vs $o_varspaces {
+ #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work.
+ if {[string match "::*" $vs]} {
+ namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all.
+ } else {
+ namespace eval ::p::${child_ID}::$vs {}
+ }
+ }
+ }
+
+ if {$IFID != 2} {
+ #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list.
+ if {![info exists o_usedby(i$child_ID)]} {
+ set o_usedby(i$child_ID) $child_alias
+ }
+
+ #compile and close the interface only if it is shared
+ if {$o_open} {
+ ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_
+ set o_open 0
+ }
+ }
+
+
+
+ package require struct::set
+
+ set propcmds [list]
+ foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] {
+ set cmd [namespace tail $cmd]
+ #may contain multiple results for same prop e.g (GET)x.3
+ set cmd [string trimright $cmd 0123456789]
+ set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals
+ lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here.
+ }
+ set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes.
+ #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface.
+ foreach property $propcmds {
+ #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n"
+ interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces
+ interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property
+ }
+
+ set propcmds [list]
+ foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] {
+ set cmd [namespace tail $cmd]
+ #may contain multiple results for same prop e.g (GET)x.3
+ set cmd [string trimright $cmd 0123456789]
+ set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals
+ lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here.
+ }
+ set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes.
+ #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface.
+ foreach property $propcmds {
+ interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces
+ }
+
+
+ foreach method [dict keys $o_methods] {
+ set arglist [dict get $o_methods $method arglist]
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+
+ #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method
+
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #proc calls the method in the interface - which is an interp alias to the head of the implementation chain
+
+
+ proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${IFID}::_iface::$method \$_ID_ $argvals
+ }]
+
+ #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] {
+ # ::p::@ID@::_iface::@m@ $_ID_ @argvals@
+ #}]
+
+
+ }
+
+ #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods]
+
+ #implement property even if interface already compiled because we need to create defaults for each new child obj.
+ # also need to add alias on base interface
+ #make sure we are only implementing properties from the current CREATOR
+ dict for {prop pdef} $o_properties {
+ set varspace [dict get $pdef varspace]
+ if {![string length $varspace]} {
+ set ns ::p::${child_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${child_ID}::$varspace
+ }
+ }
+ if {[dict exists $pdef default]} {
+ if {![info exists ${ns}::o_$prop]} {
+ #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset)
+ set ${ns}::o_$prop [dict get $pdef default]
+ }
+ }
+ #! May be replaced by a method with the same name
+ if {$prop ni [dict keys $o_methods]} {
+ interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop
+ }
+ interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop
+ interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop
+ }
+
+
+
+ #variables
+ #foreach vdef $o_variables {
+ # if {[llength $vdef] == 2} {
+ # #there is a default value defined.
+ # lassign $vdef v default
+ # if {![info exists ::p::${child_ID}::$v]} {
+ # set ::p::${child_ID}::$v $default
+ # }
+ # }
+ #}
+ dict for {vname vdef} $o_variables {
+ if {[dict exists $vdef default]} {
+ #there is a default value defined.
+ set varspace [dict get $vdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${child_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${child_ID}::$varspace
+ }
+ }
+ set ${ns}::$vname [dict get $vdef default]
+ }
+ }
+
+
+ #!todo - review. Write tests for cases of multiple constructors!
+
+ #We don't want to the run constructor for each added interface with the same set of args!
+ #run for last one - rely on constructor authors to use @next@ properly?
+ if {[llength [set ::p::${IFID}::_iface::o_constructor]]} {
+ set highest_constructor_IFID $IFID
+ }
+
+ if {$idx == $idx_count} {
+ #we are processing the last interface that was added - now run the latest constructor found
+ if {$highest_constructor_IFID ne ""} {
+ #at least one interface has a constructor
+ if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} {
+ #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP"
+ if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} {
+ set constructor_failure 1
+ set constructor_errorInfo $::errorInfo ;#cache it immediately.
+ break
+ }
+ }
+ }
+ }
+
+ if {[info exists o_unknown]} {
+ interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown
+ interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown
+
+
+ #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown
+ #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown]
+ #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown]
+ }
+ }
+
+ if {$constructor_failure} {
+ if {$is_new_object} {
+ #is Destroy enough to ensure that no new interfaces or objects were left dangling?
+ $child .. Destroy
+ } else {
+ #object needs to be returned to a sensible state..
+ #attempt to rollback all interface additions and object state changes!
+ puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n"
+ #remove variables from the object's namespace - which don't exist in the snapshot.
+ set snap_vars [info vars ${ns_snap}::*]
+ puts "ns_snap '$ns_snap' vars'${snap_vars}'"
+ foreach vname [info vars ::p::${child_ID}::*] {
+ set shortname [namespace tail $vname]
+ if {"${ns_snap}::$shortname" ni "$snap_vars"} {
+ #puts "--- >>>>> unsetting $shortname "
+ unset -nocomplain $vname
+ }
+ }
+
+ #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces)
+ #values of vars may also have Changed
+ #todo - consider traces? what is the correct behaviour?
+ # - some application traces may have fired before the constructor error occurred.
+ # Should the rollback now also trigger traces?
+ #probably yes.
+
+ #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value
+ foreach vname $snap_vars {
+ #puts stdout "@@@@@@@@@@@ restoring $vname"
+ #flush stdout
+
+
+ set shortname [namespace tail $vname]
+ set target ::p::${child_ID}::$shortname
+ if {$target in [info vars ::p::${child_ID}::*]} {
+ set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only'
+ } else {
+ set present 0
+ }
+
+ if {[array exists $vname]} {
+ #restore 'array' variable
+ if {!$present} {
+ array set $target [array get $vname]
+ } else {
+ if {[array exists $target]} {
+ #unset superfluous elements
+ foreach key [array names $target] {
+ if {$key ni [array names $vname]} {
+ array unset $target $key
+ }
+ }
+ #.. and write only elements that have changed.
+ foreach key [array names $vname] {
+ if {[set ${target}($key)] ne [set ${vname}($key)]} {
+ set ${target}($key) [set ${vname}($key)]
+ }
+ }
+ } else {
+ #target has been changed to a simple variable - unset it and recreate the array.
+ unset $target
+ array set $target [array get $vname]
+ }
+ }
+ } elseif {[info exists $vname]} {
+ #restore 'simple' variable
+ if {!$present} {
+ set $target [set $vname]
+ } else {
+ if {[array exists $target]} {
+ #target has been changed to array - unset it and recreate the simple variable.
+ unset $target
+ set $target [set $vname]
+ } else {
+ if {[set $target] ne [set $vname]} {
+ set $target [set $vname]
+ }
+ }
+ }
+ } else {
+ #restore 'declared' variable
+ if {[array exists $target] || [info exists $target]} {
+ unset -nocomplain $target
+ }
+ namespace eval ::p::${child_ID} [list variable $shortname]
+ }
+ }
+ }
+ namespace delete $ns_snap
+ return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error
+ }
+ namespace delete $ns_snap
+
+ }
+
+
+
+ return $child
+}
+
+dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}}
+#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied*
+# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*)
+# Also: Any 'open' interfaces on the parent become closed on clone!
+proc ::p::-1::Clone {_ID_ clone args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set invocants [dict get $_ID_ i]
+ lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd
+
+ set _cmd [string map {::> ::} $cmd]
+ set tail [namespace tail $_cmd]
+
+
+ #obsolete?
+ ##set IFID0 [lindex $map 1 0 end]
+ #set IFID0 [lindex [dict get $MAP interfaces level0] end]
+ ##set IFID1 [lindex $map 1 1 end]
+ #set IFID1 [lindex [dict get $MAP interfaces level1] end]
+
+
+ if {![string match "::*" $clone]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set clone ::$clone
+ } else {
+ set clone ${ns}::$clone
+ }
+ }
+
+
+ set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >]
+ set _clone [string map {::> ::} $clone]
+
+
+ set cTail [namespace tail $_clone]
+
+ set ns [namespace qualifiers $clone]
+ if {$ns eq ""} {
+ set ns "::"
+ }
+
+ namespace eval $ns {}
+
+
+ #if {![llength [info commands $clone]]} {}
+ if {[namespace which $clone] eq ""} {
+ set clonemapdata [::p::internals::new_object $clone]
+ } else {
+ #overlay/mixin case - target/clone already exists
+ #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1]
+ set clonemapdata [$clone --]
+ }
+ set clone_ID [lindex [dict get $clonemapdata invocantdata] 0]
+
+ upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP
+
+
+ #copy patterndata element of MAP straight across
+ dict set CLONEMAP patterndata [dict get $MAP patterndata]
+ set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata]
+ lset CLONE_INVOCANTDATA 2 $parent_defaultmethod
+ dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA
+ lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone
+
+ #update the clone's _ID_
+ interp alias {} $clone_alias {} ;#first we must delete it
+ interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}]
+
+ #! object_command was initially created as the renamed alias - so we have to do it again
+ rename $clone_alias $clone
+ trace add command $clone rename [list $clone .. Rename]
+
+
+
+
+ #obsolete?
+ #upvar ::p::${clone_ID}:: clone_INFO
+ #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone.
+ #upvar ::p::${OID}:: INFO
+
+
+ array set clone_INFO [array get INFO]
+
+ array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby'
+
+
+ #!review!
+ #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} {
+ #puts "***************"
+ #puts "clone"
+ #parray IFINFO
+ #puts "***************"
+ #}
+
+ #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern
+
+
+ #clone's interface maps must be a superset of original's
+ foreach lev {0 1} {
+ #set parent_ifaces [lindex $map 1 $lev]
+ set parent_ifaces [dict get $MAP interfaces level$lev]
+
+ #set existing_ifaces [lindex $CLONEMAP 1 $lev]
+ set existing_ifaces [dict get $CLONEMAP interfaces level$lev]
+
+ set added_ifaces_$lev [list]
+ foreach ifid $parent_ifaces {
+ if {$ifid ni $existing_ifaces} {
+
+ #interface must not remain extensible after cloning.
+ if {[set ::p::${ifid}::_iface::o_open]} {
+ ::p::predator::compile_interface $ifid $_ID_
+ set ::p::${ifid}::_iface::o_open 0
+ }
+
+
+
+ lappend added_ifaces_$lev $ifid
+ #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list.
+ set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone
+ }
+ }
+ set extracted_sub_dict [dict get $CLONEMAP interfaces]
+ dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]]
+ dict set CLONEMAP interfaces $extracted_sub_dict
+ #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]]
+ }
+
+ #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE)
+
+
+ #foreach *added* level0 interface..
+ foreach ifid $added_ifaces_0 {
+ namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown
+
+
+ dict for {prop pdef} $o_properties {
+ #lassign $pdef prop default
+ if {[dict exists $pdef default]} {
+ set varspace [dict get $pdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${clone_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${clone_ID}::$varspace
+ }
+ }
+
+ if {![info exists ${ns}::o_$prop]} {
+ #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset)
+ set ${ns}::o_$prop [dict get $pdef default]
+ }
+ }
+
+ #! May be replaced by method of same name
+ if {[namespace which ::p::${clone_ID}::$prop] eq ""} {
+ interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop
+ }
+ interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop
+ interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop
+ }
+
+ #variables
+ dict for {vname vdef} $o_variables {
+ if {[dict exists $vdef default]} {
+ set varspace [dict get $vdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${clone_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${clone_ID}::$varspace
+ }
+ }
+ if {![info exists ${ns}::$vname]} {
+ set ::p::${clone_ID}::$vname [dict get $vdef default]
+ }
+ }
+ }
+
+
+ #update the clone object's base interface to reflect the new methods.
+ #upvar 0 ::p::${ifid}:: IFACE
+ #set methods [list]
+ #foreach {key mname} [array get IFACE m-1,name,*] {
+ # set method [lindex [split $key ,] end]
+ # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP
+ # lappend methods $method
+ #}
+ #namespace eval ::p::${clone_ID} [list namespace export {*}$methods]
+
+
+ foreach method [dict keys $o_methods] {
+
+ set arglist [dict get $o_methods $method arglist]
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+ #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method
+
+
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #proc calls the method in the interface - which is an interp alias to the head of the implementation chain
+ proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${ifid}::_iface::$method \$_ID_ $argvals
+ }]
+
+ }
+ #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods]
+
+
+ if {[info exists o_unknown]} {
+ #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown
+ interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown
+ interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown
+
+ #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown]
+ #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown]
+
+ }
+
+
+ #2021
+ #Consider >parent with constructor that sets height
+ #.eg >parent .. Constructor height {
+ # set o_height $height
+ #}
+ #>parent .. Create >child 5
+ # - >child has height 5
+ # now when we peform a clone operation - it is the >parent's constructor that will run.
+ # A clone will get default property and var values - but not other variable values unless the constructor sets them.
+ #>child .. Clone >fakesibling 6
+ # - >sibling has height 6
+ # Consider if >child had it's own constructor created with .. Construct prior to the clone operation.
+ # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead.
+ # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining...
+ # when we now do >sibling .. Create >grandchild
+ # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild
+ # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.)
+ # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild
+ #(though other arguments can be manually passed)
+ # #!review - does this make sense? What if we add
+ #
+ #constructor for each interface called after properties initialised.
+ #run each interface's constructor against child object, using the args passed into this clone method.
+ if {[llength [set constructordef [set o_constructor]]]} {
+ #error
+ puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID"
+ ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args
+
+ }
+
+ }
+
+
+ return $clone
+
+}
+
+
+
+interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?)
+dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}}
+proc ::p::-1::Constructor {_ID_ arglist body} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ #lassign [lindex $invocant 0 ] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ #set iid_top [::p::get_new_object_id]
+
+ #the >interface constructor takes a list of IDs for o_usedby
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+
+ #::p::predator::remap $invocant
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces
+
+
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1
+
+ set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_]
+
+ #set varspaces [::pattern::varspace_list]
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls]
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t runtime_vardecls in Constructor $varDecls"
+ }
+
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #puts stderr ----
+ #puts stderr $body
+ #puts stderr ----
+
+ proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body
+ interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid
+
+
+
+ set o_constructor [list $arglist $body]
+ set o_open 1
+
+ return
+}
+
+
+
+dict set ::p::-1::_iface::o_methods UsedBy {arglist {}}
+proc ::p::-1::UsedBy {_ID_} {
+ return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby]
+}
+
+
+dict set ::p::-1::_iface::o_methods Ready {arglist {}}
+proc ::p::-1::Ready {_ID_} {
+ return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}]
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}}
+
+#'force' 1 indicates object command & variable will also be removed.
+#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var.
+#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4)
+#
+proc ::p::-1::Destroy {_ID_ {force 1}} {
+ #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]"
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+
+ if {$OID eq "null"} {
+ puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_"
+ return
+ }
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+
+ #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout
+
+ #explicit Destroy - remove traces
+ #puts ">>TRACES: [trace info variable $cmd]"
+ #foreach tinfo [trace info variable $cmd] {
+ # trace remove variable $cmd {*}$tinfo
+ #}
+ #foreach tinfo [trace info command $cmd] {
+ # trace remove command $cmd {*}$tinfo
+ #}
+
+
+ set _cmd [string map {::> ::} $cmd]
+
+ #set ifaces [lindex $map 1]
+ set iface_stacks [dict get $MAP interfaces level0]
+ #set patterns [lindex $map 2]
+ set pattern_stacks [dict get $MAP interfaces level1]
+
+
+
+ set ifaces $iface_stacks
+
+
+ set patterns $pattern_stacks
+
+
+ #set i 0
+ #foreach iflist $ifaces {
+ # set IFID$i [lindex $iflist 0]
+ # incr i
+ #}
+
+
+ set IFTOP [lindex $ifaces end]
+
+ set DESTRUCTOR ::p::${IFTOP}::___system___destructor
+ #may be a proc, or may be an alias
+ if {[namespace which $DESTRUCTOR] ne ""} {
+ set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}]
+
+ if {[catch {$DESTRUCTOR $temp_ID_} prob]} {
+ #!todo - ensure correct calling order of interfaces referencing the destructor proc
+
+
+ #!todo - emit destructor errors somewhere - logger?
+ #puts stderr "underlying proc already removed??? ---> $prob"
+ #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------"
+ #puts stderr $::errorInfo
+ #puts stderr "---------------------"
+ }
+ }
+
+
+ #remove ourself from each interfaces list of referencers
+ #puts stderr "--- $ifaces"
+
+ foreach var {ifaces patterns} {
+
+ foreach i [set $var] {
+
+ if {[string length $i]} {
+ if {$i == 2} {
+ #skip the >ifinfo interface which doesn't maintain a usedby list anyway.
+ continue
+ }
+
+ if {[catch {
+
+ upvar #0 ::p::${i}::_iface::o_usedby usedby
+
+ array unset usedby i$OID
+
+
+ #puts "\n***>>***"
+ #puts "IFACE: $i usedby: $usedby"
+ #puts "***>>***\n"
+
+ #remove interface if no more referencers
+ if {![array size usedby]} {
+ #puts " **************** DESTROYING unused interface $i *****"
+ #catch {namespace delete ::p::$i}
+
+ #we happen to know where 'interface' object commands are kept:
+
+ ::p::ifaces::>$i .. Destroy
+
+ }
+
+ } errMsg]} {
+ #warning
+ puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg"
+ }
+ }
+
+ }
+
+ }
+
+ set ns ::p::${OID}
+ #puts "-- destroying objects below namespace:'$ns'"
+ ::p::internals::DestroyObjectsBelowNamespace $ns
+ #puts "--.destroyed objects below '$ns'"
+
+
+ #set ns ::p::${OID}::_sub
+ #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace
+ #( ::p::OBJECT::$OID )
+ #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n"
+ #::p::internals::DestroyObjectsBelowNamespace $ns
+
+ #same for _meta objects (e.g Methods,Properties collections)
+ #set ns ::p::${OID}::_meta
+ #::p::internals::DestroyObjectsBelowNamespace $ns
+
+
+
+ #foreach obj [info commands ${ns}::>*] {
+ # #Assume it's one of ours, and ask it to die.
+ # catch {::p::meta::Destroy $obj}
+ # #catch {$cmd .. Destroy}
+ #}
+ #just in case the user created subnamespaces.. kill objects there too.
+ #foreach sub [namespace children $ns] {
+ # ::p::internals::DestroyObjectsBelowNamespace $sub
+ #}
+
+
+ #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value!
+ #use info commands ::p::${OID}::_ref::* to find all references - including variables never set
+ #remove variable traces on REF vars
+ #foreach rv [info vars ::p::${OID}::_ref::*] {
+ # foreach tinfo [trace info variable $rv] {
+ # #puts "-->removing traces on $rv: $tinfo"
+ # trace remove variable $rv {*}$tinfo
+ # }
+ #}
+
+ #!todo - write tests
+ #refs create aliases and variables at the same place
+ #- but variable may not exist if it was never set e.g if it was only used with info exists
+ foreach rv [info commands ::p::${OID}::_ref::*] {
+ foreach tinfo [trace info variable $rv] {
+ #puts "-->removing traces on $rv: $tinfo"
+ trace remove variable $rv {*}$tinfo
+ }
+ }
+
+
+
+
+
+
+
+ #if {[catch {namespace delete $nsMeta} msg]} {
+ # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg "
+ #} else {
+ # #puts stderr "------ -- -- -- -- deleted $nsMeta "
+ #}
+
+
+ #!todo - remove
+ #temp
+ #catch {interp alias "" ::>$OID ""}
+
+ if {$force} {
+ #rename $cmd {}
+
+ #removing the alias will remove the command - even if it's been renamed
+ interp alias {} $alias {}
+
+ #if {[catch {rename $_cmd {} } why]} {
+ # #!todo - work out why some objects don't have matching command.
+ # #puts stderr "\t rename $_cmd {} failed"
+ #} else {
+ # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!"
+ #}
+
+ }
+
+ set refns ::p::${OID}::_ref
+ #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns"
+ #puts "- children: [llength [namespace children $refns]]"
+ #puts "- vars : [llength [info vars ${refns}::*]]"
+ #puts "- commands: [llength [info commands ${refns}::*]]"
+ #puts "- procs : [llength [info procs ${refns}::*]]"
+ #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]"
+ #puts "- matching command: [llength [info commands ${refns}]]"
+ #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns"
+
+
+ #foreach v [info vars ${refns}::*] {
+ # unset $v
+ #}
+ #foreach p [info procs ${refns}::*] {
+ # rename $p {}
+ #}
+ #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] {
+ # interp alias {} $a {}
+ #}
+
+
+ #set ts1 [clock seconds]
+ #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns."
+ #puts "- children: [llength [namespace children $refns]]"
+ #puts "- vars : [llength [info vars ${refns}::*]]"
+
+ #puts "- commands: [llength [info commands ${refns}::*]]"
+ #puts "- procs : [llength [info procs ${refns}::*]]"
+ #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]"
+ #puts "- exact command: [info commands ${refns}]"
+
+
+
+
+ #puts "--delete ::p::${OID}::_ref"
+ if {[namespace exists ::p::${OID}::_ref]} {
+ #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted.
+ namespace delete ::p::${OID}::_ref::
+ }
+ set ts2 [clock seconds]
+ #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]"
+
+
+ #delete namespace where instance variables reside
+ #catch {namespace delete ::p::$OID}
+ namespace delete ::p::$OID
+
+ #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout
+ return
+}
+
+
+interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility
+
+
+dict set ::p::-1::_iface::o_methods Destructor {arglist {args}}
+#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction?
+#install a Destructor on the invocant's open level1 interface.
+proc ::p::-1::Destructor {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ #lassign [lindex $map 0] OID alias itemCmd cmd
+
+ set patterns [dict get $MAP interfaces level1]
+
+ if {[llength $args] > 2} {
+ error "too many arguments to 'Destructor' - expected at most 2 (arglist body)"
+ }
+
+ set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface.
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ error "NOT TESTED"
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+
+ #::p::predator::remap $invocant
+ }
+
+
+ set ::p::${IID}::_iface::o_destructor_body [lindex $args end]
+
+ if {[llength $args] > 1} {
+ #!todo - allow destructor args(?)
+ set arglist [lindex $args 0]
+ } else {
+ set arglist [list]
+ }
+
+ set ::p::${IID}::_iface::o_destructor_args $arglist
+
+ return
+}
+
+
+
+
+
+interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit)
+
+
+dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}}
+proc ::p::-1::PatternMethod {_ID_ method arglist body} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - get 'open' interface.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+
+ namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces
+
+
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID $method]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME $method.$headid ;#first version will be $method.1
+
+ set next [::p::predator::next_script $IID $method $THISNAME $_ID_]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls"
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls"
+ }
+
+
+ set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist]
+
+ #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n]
+ #puts "\t\t--------------------"
+ #puts "\n"
+ #puts $body
+ #puts "\n"
+ #puts "\t\t--------------------"
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body
+
+
+
+ #pointer from method-name to head of the interface's command-chain
+ interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME
+
+
+
+ if {$method in [dict keys $o_methods]} {
+ #error "patternmethod '$method' already present in interface $IID"
+ set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)"
+ if {[string match "*@next@*" $body]} {
+ append msg "\n EXTRA-WARNING: method contains @next@"
+ }
+
+ puts stdout $msg
+ } else {
+ dict set o_methods $method [list arglist $arglist]
+ }
+
+ #::p::-1::update_invocant_aliases $_ID_
+ return
+}
+
+#MultiMethod
+#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants
+# e.g1 $obj .. MultiMethod add {these 2} $arglist $body
+# e.g2 $obj .. MultiMethod add {these n} $arglist $body
+#
+# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body
+#
+# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature.
+# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature)
+# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces)
+# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter?
+# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed?
+# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code?
+# (and how would we define the call order? - presumably as it appears in the conglomerate)
+# (or could that be done with a more general method-wrapping mechanism?)
+#...should multimethods use some sort of event mechanism, and/or message-passing system?
+#
+dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}}
+proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} {
+ set invocants [dict get $_ID_ i]
+
+ error "not implemented"
+}
+
+dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}}
+# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- )
+#we can create a method named "." by using the argprotect operator --
+# e.g >x .. Method -- . {args} $body
+#It can then be called like so: >x . .
+#This is not guaranteed to work and is not in the test suite
+#for now we'll just use a highly unlikely string to indicate no argument was supplied
+proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } {
+ set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped
+ if {$methodname eq $non_argument_magicstring} {
+ return $default_method
+ } else {
+ set extracted_value [dict get $MAP invocantdata]
+ lset extracted_value 2 $methodname
+ dict set MAP invocantdata $extracted_value ;#write modified value back
+ #update the object's command alias to match
+ interp alias {} $alias {} ;#first we must delete it
+ interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}]
+
+ #! $object_command was initially created as the renamed alias - so we have to do it again
+ rename $alias $object_command
+ trace add command $object_command rename [list $object_command .. Rename]
+ return $methodname
+ }
+}
+
+dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}}
+proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } {
+ set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set extracted_patterndata [dict get $MAP patterndata]
+ set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod]
+ if {$methodname eq $non_argument_magicstring} {
+ return $pattern_default_method
+ } else {
+ dict set extracted_patterndata patterndefaultmethod $methodname
+ dict set MAP patterndata $extracted_patterndata
+ return $methodname
+ }
+}
+
+
+dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}}
+proc ::p::-1::Method {_ID_ method arglist bodydef args} {
+ set invocants [dict get $_ID_ i]
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+ set invocant_signature [list] ;
+ ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway.
+ foreach role [lsort [dict keys $invocants]] {
+ lappend invocant_signature $role [llength [dict get $invocants $role]]
+ }
+ #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this')
+
+
+
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command
+ set interfaces [dict get $MAP interfaces level0]
+
+
+
+ #################################################################################
+ if 0 {
+ set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface
+ set prev_open [set ::p::${iid_top}::_iface::o_open]
+
+ set iface ::p::ifaces::>$iid_top
+
+ set f_new 0
+ if {![string length $iid_top]} {
+ set f_new 1
+ } else {
+ if {[$iface . isClosed]} {
+ set f_new 1
+ }
+ }
+ if {$f_new} {
+ #create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+
+ }
+ set IID $iid_top
+
+ }
+ #################################################################################
+
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+
+ #upvar 0 ::p::${IID}:: IFACE
+
+ namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces
+
+
+ #Interface proc
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID $method]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME $method.$headid ;#first version will be $method.1
+
+ if {$method ni [dict keys $o_methods]} {
+ dict set o_methods $method [list arglist $arglist]
+ }
+
+ #next_script will call to lower interface in iStack if we are $method.1
+ set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_
+ #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<"
+
+
+ #implement
+ #-----------------------------------
+ set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ set varDecls ""
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls\n[dict get $processed body]
+ }
+
+
+ set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist]
+
+
+
+
+
+
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #if {[string length $varDecls]} {
+ # puts stdout "\t---------------------------------------------------------------"
+ # puts stdout "\t----- efficiency warning - implicit var declarations used -----"
+ # puts stdout "\t-------- $object_command .. Method $method $arglist ---------"
+ # puts stdout "\t[string map [list \n \t\t\n] $body]"
+ # puts stdout "\t--------------------------"
+ #}
+ #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role
+ # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position.
+ #(as specified by the @ operator during object conglomeration)
+ #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n]
+
+ #puts stdout "\t\t----------------------------"
+ #puts stdout "$body"
+ #puts stdout "\t\t----------------------------"
+
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body
+
+ #-----------------------------------
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME
+
+
+ #point to the interface command only. The dispatcher will supply the invocant data
+ #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain
+
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${IID}::_iface::$method \$_ID_ $argvals
+ }]
+
+
+ if 0 {
+ if {[llength $argvals]} {
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] {
+ apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@
+ }]
+ } else {
+
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] {
+ apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@
+ }]
+
+ }
+ }
+
+
+ #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst {
+ # ::p::${IID}::_iface::$method \$_ID_ $argvals
+ #}]
+
+ #todo - for o_varspaces
+ #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method
+ #- this should work correctly with the 'uplevel 1' procs in the interfaces
+
+
+ if {[string length $o_varspace]} {
+ if {[string match "::*" $o_varspace]} {
+ namespace eval $o_varspace {}
+ } else {
+ namespace eval ::p::${OID}::$o_varspace {}
+ }
+ }
+
+
+ #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed.
+ set colMethods ::p::${OID}::_meta::>colMethods
+
+ if {[namespace which $colMethods] ne ""} {
+ if {![$colMethods . hasKey $method]} {
+ $colMethods . add [::p::internals::predator $_ID_ . $method .] $method
+ }
+ }
+
+ #::p::-1::update_invocant_aliases $_ID_
+ return
+ #::>pattern .. Create [::>pattern .. Namespace]::>method_???
+ #return $method_object
+}
+
+
+dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}}
+proc ::p::-1::V {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+
+
+ set vlist [list]
+ foreach IID $ifaces {
+ dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] {
+ if {[string match $glob $vname]} {
+ lappend vlist $vname
+ }
+ }
+ }
+
+
+ return $vlist
+}
+
+#experiment from http://wiki.tcl.tk/4884
+proc p::predator::pipeline {args} {
+ set lambda {return -level 0}
+ foreach arg $args {
+ set lambda [list apply [dict get {
+ toupper {{lambda input} {string toupper [{*}$lambda $input]}}
+ tolower {{lambda input} {string tolower [{*}$lambda $input]}}
+ totitle {{lambda input} {string totitle [{*}$lambda $input]}}
+ prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}}
+ suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}}
+ } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]]
+ }
+ return $lambda
+}
+
+proc ::p::predator::get_apply_arg_0_oid {} {
+ set apply_args [lrange [info level 0] 2 end]
+ puts stderr ">>>>> apply_args:'$apply_args'<<<<"
+ set invocant [lindex $apply_args 0]
+ return [lindex [dict get $invocant i this] 0 0]
+}
+proc ::p::predator::get_oid {} {
+ #puts stderr "---->> [info level 1] <<-----"
+ set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2
+ tailcall lindex [dict get $_ID_ i this] 0 0
+}
+
+#todo - make sure this is called for all script installations - e.g propertyread etc etc
+#Add tests to check code runs in correct namespace
+#review - how does 'Varspace' command affect this?
+proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} {
+ #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues)
+ set arglist_apply ""
+ append arglist_apply "\$_ID_ "
+ foreach a $arglist {
+ if {$a eq "args"} {
+ append arglist_apply "{*}\$args"
+ } else {
+ append arglist_apply "\$[lindex $a 0] "
+ }
+ }
+ #!todo - allow fully qualified varspaces
+ if {[string length $varspace]} {
+ if {[string match ::* $varspace]} {
+ return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply"
+ } else {
+ #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n"
+ return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply"
+ }
+ } else {
+ #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n"
+ #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]"
+
+ set script "tailcall apply \[list \{_ID_"
+
+ if {[llength $arglist]} {
+ append script " $arglist"
+ }
+ append script "\} \{"
+ append script $body
+ append script "\} ::p::@OID@\] "
+ append script $arglist_apply
+ #puts stderr "\n88888888888888888888888888\n\t$script\n"
+ #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply"
+ #return $script
+
+
+ #-----------------------------------------------------------------------------
+ # 2018 candidates
+ #
+ #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled
+ #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled
+
+
+ #this has problems with @next@ arguments! (also script variables will possibly interfere with each other)
+ #faster though.
+ #return "uplevel 1 \{$body\}"
+ return "uplevel 1 [list $body]"
+ #-----------------------------------------------------------------------------
+
+
+
+
+ #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply"
+ #return "uplevel 1 \{$script\}"
+
+ #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail
+ #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail
+
+
+
+ #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong
+
+ #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns
+
+
+ #experiment with different dispatch mechanism (interp alias with 'namespace inscope')
+ #-----------
+ #return "apply { {_ID_ $arglist} {$body}} $arglist_apply"
+
+
+ #return "uplevel 1 \{$body\}" ;#do nothing
+
+ #----------
+
+ #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??)
+
+ #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body
+
+ #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker
+
+ #return "tailcall "
+
+
+ }
+}
+
+
+#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies.
+#expand 'var' statements inline in method bodies
+#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements.
+#
+#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces
+#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches!
+# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements.
+#Think of var & varspace statments as a form of compile-time 'macro'
+#
+#caters for 2-element lists as arguments to var statement to allow 'aliasing'
+#e.g var o_thing {o_data mydata}
+# this will upvar o_thing as o_thing & o_data as mydata
+#
+proc ::p::predator::expand_var_statements {rawbody {varspace ""}} {
+ set body {}
+
+ #keep count of any explicit var statments per varspace in 'numDeclared' array
+ # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements.
+
+ #default varspace is ""
+ #varspace should only have leading :: if it is an absolute namespace path.
+
+
+ foreach ln [split $rawbody \n] {
+ set trimline [string trim $ln]
+
+ if {$trimline eq "var"} {
+ #plain var statement alone indicates we don't have any explicit declarations in this branch
+ # and we don't want implicit declarations for the current varspace either.
+ #!todo - implement test
+
+ incr numDeclared($varspace)
+
+ #may be further var statements e.g - in other code branches
+ #return [list body $rawbody varspaces_with_explicit_vars 1]
+ } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} {
+
+ #append body " upvar #0 "
+ #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} "
+ #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} "
+
+ if {$varspace eq ""} {
+ append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] "
+ } else {
+ if {[string match "::*" $varspace]} {
+ append body " namespace upvar $varspace "
+ } else {
+ append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} "
+ }
+ }
+
+ #any whitespace before or betw var names doesn't matter - about to use as list.
+ foreach varspec [string range $trimline 4 end] {
+ lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element.
+ ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias "
+ #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias "
+
+ append body "$var $alias "
+
+ }
+ append body \n
+
+ incr numDeclared($varspace)
+ } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} {
+ #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ???
+ #it is assumed there is a single word following the 'varspace' keyword.
+ set varspace [string trim [string range $trimline 9 end]]
+
+ if {$varspace in [list {{}} {""}]} {
+ set varspace ""
+ }
+ if {[string length $varspace]} {
+ #set varspace ::${varspace}::
+ #no need to initialize numDeclared($varspace) incr will work anyway.
+ #if {![info exists numDeclared($varspace)]} {
+ # set numDeclared($varspace) 0
+ #}
+
+ if {[string match "::*" $varspace]} {
+ append body "namespace eval $varspace {} \n"
+ } else {
+ append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n"
+ }
+
+ #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} "
+ #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n"
+ #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n"
+
+ #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n"
+ }
+ #!review - why? why do we need the magic 'default' name instead of just using the empty string?
+ #if varspace argument was empty string - leave it alone
+ } else {
+ append body $ln\n
+ }
+ }
+
+
+
+ set varspaces [array names numDeclared]
+ return [list body $body varspaces_with_explicit_vars $varspaces]
+}
+
+
+
+
+#Interface Variables
+dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}}
+proc ::p::-1::IV {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+
+ #!todo - test
+ #return [dict keys ::p::${OID}::_iface::o_variables $glob]
+
+ set members [list]
+ foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] {
+ if {[string match $glob $vname]} {
+ lappend members $vname
+ }
+ }
+ return $members
+}
+
+dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}}
+proc ::p::-1::MetaMethods {_ID_ {glob *}} {
+ upvar ::p::-1::_iface::o_methods metaface_methods
+ set metamethod_names [lsort [dict keys $metaface_methods]]
+ if {$glob ne "*"} {
+ set metamethod_names [lsearch -all -inline $metamethod_names $glob]
+ }
+ return $metamethod_names
+}
+
+
+dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}}
+proc ::p::-1::Methods {_ID_ {idx ""}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set col ::p::${OID}::_meta::>colMethods
+
+ if {[namespace which $col] eq ""} {
+ patternlib::>collection .. Create $col
+ foreach IID $ifaces {
+ foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] {
+ if {![$col . hasIndex $m]} {
+ #todo - create some sort of lazy-evaluating method object?
+ #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist]
+ $col . add [::p::internals::predator $_ID_ . $m .] $m
+ }
+ }
+ }
+ }
+ if {[string length $idx]} {
+ return [$col . item $idx]
+ } else {
+ return $col
+ }
+}
+
+dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}}
+proc ::p::-1::M {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set members [list]
+ foreach IID $ifaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob]
+ }
+ return $members
+}
+
+#PatternMethods
+dict set ::p::-1::_iface::o_methods PM {arglist {{glob *}}}
+proc ::p::-1::PM {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+ set members [list]
+ foreach IID $ifaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob]
+ }
+ return [lsort $members]
+}
+
+
+#review
+#Interface Methods
+dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}}
+proc ::p::-1::IM {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ return [dict keys [set ::p::${OID}::_iface::o_methods] $glob]
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}}
+proc ::p::-1::InterfaceStacks {_ID_} {
+ upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP
+ return [dict get $MAP interfaces level0]
+}
+
+
+dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}}
+proc ::p::-1::PatternStacks {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ return [dict get $MAP interfaces level1]
+}
+
+
+#!todo fix. need to account for references which were never set to a value
+dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}}
+proc ::p::-1::DeletePropertyReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ set cleared_references [list]
+ set refvars [info vars ::p::${OID}::_ref::*]
+ #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st.
+ foreach rv $refvars {
+ foreach tinfo [trace info variable $rv] {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ trace remove variable $rv $ops $cmd
+ }
+ unset $rv
+ lappend cleared_references $rv
+ }
+
+
+ return [list deleted_property_references $cleared_references]
+}
+
+dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}}
+proc ::p::-1::DeleteMethodReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ set cleared_references [list]
+
+ set iflist [dict get $MAP interfaces level0]
+ set iflist_reverse [lreferse $iflist]
+ #set iflist [dict get $MAP interfaces level0]
+
+
+ set refcommands [info commands ::p::${OID}::_ref::*]
+ foreach c $refcommands {
+ set reftail [namespace tail $c]
+ set field [lindex [split $c +] 0]
+ set field_is_a_method 0
+ foreach IFID $iflist_reverse {
+ if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} {
+ set field_is_a_method 1
+ break
+ }
+ }
+ if {$field_is_a_method} {
+ #what if it's also a property?
+ interp alias {} $c {}
+ lappend cleared_references $c
+ }
+ }
+
+
+ return [list deleted_method_references $cleared_references]
+}
+
+
+dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}}
+proc ::p::-1::DeleteReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method this
+
+ set result [dict create]
+ dict set result {*}[$this .. DeletePropertyReferences]
+ dict set result {*}[$this .. DeleteMethodReferences]
+
+ return $result
+}
+
+##
+#Digest
+#
+#!todo - review
+# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!)
+#
+#!todo - write tests - check that digest changes when properties of contained objects change value
+#
+#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method?
+#
+dict set ::p::-1::_iface::o_methods Digest {arglist {args}}
+proc ::p::-1::Digest {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway.
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] _OID alias default_method this
+
+
+ set interface_ids [dict get $MAP interfaces level0]
+ set IFID0 [lindex $interface_ids end]
+
+ set known_flags {-recursive -algorithm -a -indent}
+ set defaults {-recursive 1 -algorithm md5 -indent ""}
+ if {[dict exists $args -a] && ![dict exists $args -algorithm]} {
+ dict set args -algorithm [dict get $args -a]
+ }
+
+ set opts [dict merge $defaults $args]
+ foreach key [dict keys $opts] {
+ if {$key ni $known_flags} {
+ error "unknown option $key. Expected only: $known_flags"
+ }
+ }
+
+
+ set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256}
+ if {[dict get $opts -algorithm] ni $known_algos} {
+ error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos"
+ }
+ set algo [string tolower [dict get $opts -algorithm]]
+
+ # append comma for each var so that all changes in adjacent vars detectable.
+ # i.e set x 34; set y 5
+ # must be distinguishable from:
+ # set x 3; set y 45
+
+ if {[dict get $opts -indent] ne ""} {
+ set state ""
+ set indent "[dict get $opts -indent]"
+ } else {
+ set state "---\n"
+ set indent " "
+ }
+ append state "${indent}object_command: $this\n"
+ set indent "${indent} "
+
+ #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state.
+ append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state.
+
+
+
+
+ #!todo - recurse into 'varspaces'
+ set varspaces_found [list]
+ append state "${indent}interfaces:\n"
+ foreach IID $interface_ids {
+ append state "${indent} - interface: $IID\n"
+ namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces
+ append state "${indent} varspaces:\n"
+ foreach vs $local_o_varspaces {
+ if {$vs ni $varspaces_found} {
+ lappend varspaces_found $vs
+ append state "${indent} - varspace: $vs\n"
+ }
+ }
+ }
+
+ append state "${indent}vars:\n"
+ foreach var [info vars ::p::${OID}::*] {
+ append state "${indent} - [namespace tail $var] : \""
+ if {[catch {append state "[set $var]"}]} {
+ append state "[array get $var]"
+ }
+ append state "\"\n"
+ }
+
+ if {[dict get $opts -recursive]} {
+ append state "${indent}sub-objects:\n"
+ set subargs $args
+ dict set subargs -indent "$indent "
+ foreach obj [info commands ::p::${OID}::>*] {
+ append state "[$obj .. Digest {*}$subargs]\n"
+ }
+
+ append state "${indent}sub-namespaces:\n"
+ set subargs $args
+ dict set subargs -indent "$indent "
+ foreach ns [namespace children ::p::${OID}] {
+ append state "${indent} - namespace: $ns\n"
+ foreach obj [info commands ${ns}::>*] {
+ append state "[$obj .. Digest {*}$subargs]\n"
+ }
+ }
+ }
+
+
+ if {$algo in {"" raw none}} {
+ return $state
+ } else {
+ if {$algo eq "md5"} {
+ package require md5
+ return [::md5::md5 -hex $state]
+ } elseif {$algo eq "sha256"} {
+ package require sha256
+ return [::sha2::sha256 -hex $state]
+ } elseif {$algo eq "blowfish"} {
+ package require patterncipher
+ patterncipher::>blowfish .. Create >b1
+ set [>b1 . key .] 12341234
+ >b1 . encrypt $state -final 1
+ set result [>b1 . ciphertext]
+ >b1 .. Destroy
+
+ } elseif {$algo eq "blowfish-binary"} {
+
+ } else {
+ error "can't get here"
+ }
+
+ }
+}
+
+
+dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}}
+proc ::p::-1::Variable {_ID_ varname args} {
+ set invocants [dict get $_ID_ i]
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ #this interface itself is always a co-invocant
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set interfaces [dict get $MAP interfaces level0]
+
+ #set existing_IID [lindex $map 1 0 end]
+ set existing_IID [lindex $interfaces end]
+
+ set prev_openstate [set ::p::${existing_IID}::_iface::o_open]
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #IID changed
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+
+ #update original object command
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set ::p::${IID}::_iface::o_open $prev_openstate
+ }
+
+ set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface)
+
+ if {[llength $args]} {
+ #!assume var not already present on interface - it is an error to define twice (?)
+ #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]]
+ dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace]
+
+
+ #Implement if there is a default
+ #!todo - correct behaviour when overlaying on existing object with existing var of this name?
+ #if {[string length $varspace]} {
+ # set ::p::${OID}::${varspace}::$varname [lindex $args 0]
+ #} else {
+ set ::p::${OID}::$varname [lindex $args 0]
+ #}
+ } else {
+ #lappend ::p::${IID}::_iface::o_variables [list $varname]
+ dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace]
+ }
+
+ #varspace '_iface'
+
+ return
+}
+
+
+#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility
+
+dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}}
+proc ::p::-1::PatternVariable {_ID_ varname args} {
+ set invocants [dict get $_ID_ i]
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ ##this interface itself is always a co-invocant
+ #lassign [lindex $invocant 0 ] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - get 'open' interface.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+ }
+ set IID $iid_top
+
+ set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified.
+
+
+ if {[llength $args]} {
+ #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]]
+ dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace]
+ } else {
+ dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace]
+ }
+
+ return
+}
+
+dict set ::p::-1::_iface::o_methods Varspaces {arglist args}
+proc ::p::-1::Varspaces {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ if {![llength $args]} {
+ #query
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ set iface ::p::ifaces::>$iid_top
+ if {![string length $iid_top]} {
+ error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] "
+ } elseif {[$iface . isClosed]} {
+ error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] "
+ }
+ return [set ::p::${iid_top}::_iface::o_varspaces]
+ }
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+
+ set varspaces $args
+ foreach vs $varspaces {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ if {[string match ::* $vs} {
+ namespace eval $vs {}
+ } else {
+ namespace eval ::p::${OID}::$vs {}
+ }
+ lappend o_varspaces $vs
+ }
+ }
+ return $o_varspaces
+}
+
+#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface
+dict set ::p::-1::_iface::o_methods Varspace {arglist args}
+# set the default varspace for the interface, so that new methods/properties refer to it.
+# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces.
+proc ::p::-1::Varspace {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ if {![llength $args]} {
+ #query
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ set iface ::p::ifaces::>$iid_top
+ if {![string length $iid_top]} {
+ error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] "
+ } elseif {[$iface . isClosed]} {
+ error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] "
+ }
+ return [set ::p::${iid_top}::_iface::o_varspace]
+ }
+ set varspace [lindex $args 0]
+
+ #set interfaces [dict get $MAP interfaces level0]
+ #set iid_top [lindex $interfaces end]
+
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+
+
+ #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+
+ if {[string length $varspace]} {
+ #ensure namespace exists !? do after list test?
+ if {[string match ::* $varspace]} {
+ namespace eval $varspace {}
+ } else {
+ namespace eval ::p::${OID}::$varspace {}
+ }
+ if {$varspace ni $o_varspaces} {
+ lappend o_varspaces $varspace
+ }
+ }
+ set o_varspace $varspace
+}
+
+
+proc ::p::predator::get_possibly_new_open_interface {OID} {
+ #we need to re-upvar MAP rather than using a parameter - as we need to write back to it
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+
+
+ set iface ::p::ifaces::>$iid_top
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ #puts stderr ">>>>creating new interface $iid_top"
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+
+ return $iid_top
+}
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}}
+# set the default varspace for the interface, so that new methods/properties refer to it.
+# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces.
+proc ::p::-1::PatternVarspace {_ID_ varspace args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end]
+
+ set iface ::p::ifaces::>$iid_top
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+ if {[string length $varspace]} {
+ if {$varspace ni $o_varspaces} {
+ lappend o_varspaces $varspace
+ }
+ }
+ #o_varspace is the currently active varspace
+ set o_varspace $varspace
+
+}
+###################################################################################################################################################
+
+#get varspace and default from highest interface - return all interface ids which define it
+dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}}
+proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0]
+
+ array set propinfo {}
+ set found_property_names [list]
+ #start at the lowest and work up (normal storage order of $interfaces)
+ foreach iid $interfaces {
+ set propinfodict [set ::p::${iid}::_iface::o_properties]
+ set matching_propnames [dict keys $propinfodict $propnamepattern]
+ foreach propname $matching_propnames {
+ if {$propname ni $found_property_names} {
+ lappend found_property_names $propname
+ }
+ lappend propinfo($propname,interfaces) $iid
+ ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one
+ if {[dict exists $propinfodict $propname default]} {
+ set propinfo($propname,default) [dict get $propinfodict $propname default]
+ }
+ set propinfo($propname,varspace) [dict get $propinfodict $propname varspace]
+ }
+ }
+
+ set resultdict [dict create]
+ foreach propname $found_property_names {
+ set fields [list varspace $propinfo($propname,varspace)]
+ if {[array exists propinfo($propname,default)]} {
+ lappend fields default [set propinfo($propname,default)]
+ }
+ lappend fields interfaces $propinfo($propname,interfaces)
+ dict set resultdict $propname $fields
+ }
+ return $resultdict
+}
+
+
+dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args}
+proc ::p::-1::GetTopPattern {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level1]
+ set iid_top [lindex $interfaces end]
+ if {![string length $iid_top]} {
+ lassign [dict get $MAP invocantdata] OID _alias _default_method object_command
+ error "No installed level1 interfaces (patterns) for object $object_command"
+ }
+ return ::p::ifaces::>$iid_top
+}
+
+
+
+dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args}
+proc ::p::-1::GetTopInterface {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ if {![string length $iid_top]} {
+ lassign [dict get $MAP invocantdata] OID _alias _default_method object_command
+ error "No installed level0 interfaces for object $object_command"
+ }
+ return ::p::ifaces::>$iid_top
+}
+
+
+dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args}
+proc ::p::-1::GetExpandableInterface {_ID_ args} {
+
+}
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods Property {arglist {property args}}
+proc ::p::-1::Property {_ID_ property args} {
+ #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args"
+ #set invocants [dict get $_ID_ i]
+ #set invocant_roles [dict keys $invocants]
+ if {[llength $args] > 1} {
+ error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)"
+ }
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+
+ set prev_openstate [set ::p::${iid_top}::_iface::o_open]
+
+ set iface ::p::ifaces::>$iid_top
+
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+
+ namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+
+
+ if {$headid == 1} {
+ #implementation
+ #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property
+
+ #if {$o_varspace eq ""} {
+ # set ns ::p::${OID}
+ #} else {
+ # if {[string match "::*" $o_varspace]} {
+ # set ns $o_varspace
+ # } else {
+ # set ns ::p::${OID}::$o_varspace
+ # }
+ #}
+ #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]]
+
+ proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]]
+
+
+ #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property
+ proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]]
+
+
+ #chainhead pointers
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1
+
+
+ }
+
+ if {($property ni [dict keys $o_methods])} {
+ interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+
+
+
+ #installation on object
+
+ #namespace eval ::p::${OID} [list namespace export $property]
+
+
+
+ #obsolete?
+ #if {$property ni [P $_ID_]} {
+ #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces
+ #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant
+ #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant
+ #}
+
+ #link main (GET)/(SET) to this interface
+ interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property
+ interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property
+
+ #Only install property if no method of same name already installed here.
+ #(Method takes precedence over property because property always accessible via 'set' reference)
+ #convenience pointer to chainhead pointer.
+ if {$property ni [M $_ID_]} {
+ interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property
+ } else {
+ #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed
+
+
+ }
+
+
+ set varspace [set ::p::${IID}::_iface::o_varspace]
+
+
+
+ #Install the matching Variable
+ #!todo - which should take preference if Variable also given a default?
+ #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} {
+ # set o_variables [lreplace $o_variables $posn $posn o_$property]
+ #} else {
+ # lappend o_variables [list o_$property]
+ #}
+ dict set o_variables o_$property [list varspace $varspace]
+
+
+
+
+ if {[llength $args]} {
+ #should store default once only!
+ #set IFINFO(v,default,o_$property) $default
+
+ set default [lindex $args end]
+
+ dict set o_properties $property [list default $default varspace $varspace]
+
+ #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} {
+ # set o_properties [lreplace $o_properties $posn $posn [list $property $default]]
+ #} else {
+ # lappend o_properties [list $property $default]
+ #}
+
+ if {$varspace eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${OID}::$o_varspace
+ }
+ }
+
+ set ${ns}::o_$property $default
+ #set ::p::${OID}::o_$property $default
+ } else {
+
+ #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} {
+ # set o_properties [lreplace $o_properties $posn $posn [list $property]]
+ #} else {
+ # lappend o_properties [list $property]
+ #}
+ dict set o_properties $property [list varspace $varspace]
+
+
+ #variable ::p::${OID}::o_$property
+ }
+
+
+
+
+
+ #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed.
+ #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?)
+ #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property}
+
+ set colProperties ::p::${OID}::_meta::>colProperties
+ if {[namespace which $colProperties] ne ""} {
+ if {![$colProperties . hasKey $property]} {
+ $colProperties . add [::p::internals::predator $_ID_ . $property .] $property
+ }
+ }
+
+ return
+}
+###################################################################################################################################################
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility
+dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}}
+proc ::p::-1::PatternProperty {_ID_ property args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end]
+
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+
+
+
+ if {$headid == 1} {
+ #implementation
+ #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property
+ proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]]
+ #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property
+ proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]]
+
+
+ #chainhead pointers
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1
+
+ }
+
+ if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} {
+ interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+
+ set varspace [set ::p::${IID}::_iface::o_varspace]
+
+ #Install the matching Variable
+ #!todo - which should take preference if Variable also given a default?
+ #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} {
+ # set o_variables [lreplace $o_variables $posn $posn o_$property]
+ #} else {
+ # lappend o_variables [list o_$property]
+ #}
+ dict set o_variables o_$property [list varspace $varspace]
+
+ set argc [llength $args]
+
+ if {$argc} {
+ if {$argc == 1} {
+ set default [lindex $args 0]
+ dict set o_properties $property [list default $default varspace $varspace]
+ } else {
+ #if more than one arg - treat as a dict of options.
+ if {[dict exists $args -default]} {
+ set default [dict get $args -default]
+ dict set o_properties $property [list default $default varspace $varspace]
+ } else {
+ #no default value
+ dict set o_properties $property [list varspace $varspace]
+ }
+ }
+ #! only set default for property... not underlying variable.
+ #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]]
+ } else {
+ dict set o_properties $property [list varspace $varspace]
+ }
+ return
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}}
+proc ::p::-1::PatternPropertyRead {_ID_ property args} {
+ set invocants [dict get $_ID_ i]
+
+ set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this'
+ set OID [lindex $this_invocant 0]
+ #set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias defaut_command cmd
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end]
+
+ set idxlist [::list]
+ if {[llength $args] == 1} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args idxlist body
+ } else {
+ error "wrong # args: should be \"property body\" or \"property idxlist body\""
+ }
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ if {$headid == 1} {
+ set headid 2 ;#reserve 1 for the getprop of the underlying property
+ }
+
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+ set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_
+
+
+ #implement
+ #-----------------------------------
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ #implementation
+ if {![llength $idxlist]} {
+ proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body
+ } else {
+ #what are we trying to achieve here? ..
+ proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body
+ }
+
+
+ #-----------------------------------
+
+
+ #adjust chain-head pointer to point to new head.
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid
+
+ return
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}}
+proc ::p::-1::PropertyRead {_ID_ property args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead)
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end]
+
+
+ set idxlist [::list]
+ if {[llength $args] == 1} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args idxlist body
+ } else {
+ error "wrong # args: should be \"property body\" or \"property idxlist body\""
+ }
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd]
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ if {$headid == 1} {
+ set headid 2
+ }
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself)
+
+ set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_]
+
+ #implement
+ #-----------------------------------
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body
+
+ #-----------------------------------
+
+
+
+ #pointer from prop-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid
+
+
+ interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name.
+ if {$property ni [M $_ID_]} {
+ interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}}
+proc ::p::-1::PropertyWrite {_ID_ property argname body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface.
+
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ #pw short for propertywrite
+ #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd]
+ array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property]
+
+
+ set maxversion [::p::predator::method_chainhead $IID (SET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (SET)$property.$headid
+
+ set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_]
+
+ #implement
+ #-----------------------------------
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body
+
+ #-----------------------------------
+
+
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}}
+proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface.
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set existing_ifaces [lindex $map 1 1]
+ set posn [lsearch $existing_ifaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID]
+
+ #set ::p::${IID}::_iface::o_open 0
+ } else {
+ }
+
+ #pw short for propertywrite
+ array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd]
+
+
+
+
+ return
+
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}}
+proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand.
+
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers
+ #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers
+ dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern]
+
+ set maxversion [::p::predator::method_chainhead $IID (UNSET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (UNSET)$property.$headid
+
+ set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #note $arraykeypattern actually contains the name of the argument
+ if {[string trim $arraykeypattern] eq ""} {
+ set arraykeypattern _dontcare_ ;#
+ }
+ proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body
+
+ #-----------------------------------
+
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid
+
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}}
+proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #set ::p::${IID}::_iface::o_open 0
+ }
+
+
+ upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers
+ dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern]
+
+ return
+}
+###################################################################################################################################################
+
+
+
+#lappend ::p::-1::_iface::o_methods Implements
+#!todo - some way to force overriding of any abstract (empty) methods from the source object
+#e.g leave interface open and raise an error when closing it if there are unoverridden methods?
+
+
+
+
+
+#implementation reuse - sugar for >object .. Clone >target
+dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}}
+proc ::p::-1::Extends {_ID_ pattern} {
+ if {!([string range [namespace tail $pattern] 0 0] eq ">")} {
+ error "'Extends' expected a pattern object"
+ }
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd object_command
+
+
+ tailcall $pattern .. Clone $object_command
+
+}
+#implementation reuse - sugar for >pattern .. Create >target
+dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}}
+proc ::p::-1::PatternExtends {_ID_ pattern} {
+ if {!([string range [namespace tail $pattern] 0 0] eq ">")} {
+ error "'PatternExtends' expected a pattern object"
+ }
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd object_command
+
+
+ tailcall $pattern .. Create $object_command
+}
+
+
+dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}}
+proc ::p::-1::Extend {_ID_ {idx ""}} {
+ puts stderr "Extend is DEPRECATED - use Expand instead"
+ tailcall ::p::-1::Expand $_ID_ $idx
+}
+
+#set the topmost interface on the iStack to be 'open'
+dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}}
+proc ::p::-1::Expand {_ID_ {idx ""}} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set iid_top [lindex $interfaces end]
+ set iface ::p::ifaces::>$iid_top
+
+ if {![string length $iid_top]} {
+ #no existing interface - create a new one
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [list $iid_top]
+ dict set MAP interfaces $extracted_sub_dict ;#write new interface into map
+ $iface . open
+ return $iid_top
+ } else {
+ if {[$iface . isOpen]} {
+ #already open..
+ #assume ready to expand.. shared or not!
+ return $iid_top
+ }
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ if {[$iface . refCount] > 1} {
+ if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} {
+ #!warning! not exercised by test suites!
+
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${iid_top}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ #remove existing interface & add
+ set posn [lsearch $interfaces $iid_top]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+
+ set iid_top $IID
+ set iface ::p::ifaces::>$iid_top
+ }
+ }
+ }
+
+ $iface . open
+ return $iid_top
+}
+
+dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}}
+proc ::p::-1::PatternExtend {_ID_ {idx ""}} {
+ puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead"
+ tailcall ::p::-1::PatternExpand $_ID_ $idx
+}
+
+
+
+#set the topmost interface on the pStack to be 'open' if it's not shared
+# if shared - 'copylink' to new interface before opening for extension
+dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}}
+proc ::p::-1::PatternExpand {_ID_ {idx ""}} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ #puts stderr "no tests written for PatternExpand "
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+ set iid_top [lindex $ifaces end]
+ set iface ::p::ifaces::>$iid_top
+
+ if {![string length $iid_top]} {
+ #no existing interface - create a new one
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [list $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [list $iid_top]
+ $iface . open
+ return $iid_top
+ } else {
+ if {[$iface . isOpen]} {
+ #already open..
+ #assume ready to expand.. shared or not!
+ return $iid_top
+ }
+
+ if {[$iface . refCount] > 1} {
+ if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} {
+ #!WARNING! not exercised by test suite!
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${iid_top}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $ifaces $iid_top]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID]
+
+ set iid_top $IID
+ set iface ::p::ifaces::>$iid_top
+ }
+ }
+ }
+
+ $iface . open
+ return $iid_top
+}
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}}
+proc ::p::-1::Properties {_ID_ {idx ""}} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set col ::p::${OID}::_meta::>colProperties
+
+ if {[namespace which $col] eq ""} {
+ patternlib::>collection .. Create $col
+ foreach IID $ifaces {
+ dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] {
+ if {![$col . hasIndex $prop]} {
+ $col . add [::p::internals::predator $_ID_ . $prop .] $prop
+ }
+ }
+ }
+ }
+
+ if {[string length $idx]} {
+ return [$col . item $idx]
+ } else {
+ return $col
+ }
+}
+
+dict set ::p::-1::_iface::o_methods P {arglist {{glob *}}}
+proc ::p::-1::P {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set members [list]
+ foreach IID $interfaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob]
+ }
+ return [lsort $members]
+}
+
+#PatternProperties
+dict set ::p::-1::_iface::o_methods PP {arglist {{glob *}}}
+proc ::p::-1::PP {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+
+ set members [list]
+ foreach IID $interfaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob]
+ }
+ return [lsort $members]
+}
+
+
+
+#Interface Properties
+dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}}
+proc ::p::-1::IP {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set members [list]
+
+ foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] {
+ if {[string match $glob [lindex $m 0]]} {
+ lappend members [lindex $m 0]
+ }
+ }
+ return $members
+}
+
+
+#used by rename.test - theoretically should be on a separate interface!
+dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}}
+proc ::p::-1::CheckInvocants {_ID_ args} {
+ #check all invocants in the _ID_ are consistent with data stored in their MAP variable
+ set status "ok" ;#default to optimistic assumption
+ set problems [list]
+
+ set invocant_dict [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocant_dict]
+
+ foreach role $invocant_roles {
+ set invocant_list [dict get $invocant_dict $role]
+ foreach aliased_invocantdata $invocant_list {
+ set OID [lindex $aliased_invocantdata 0]
+ set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata]
+ #we use lrange to make sure the lists are in canonical form
+ if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} {
+ set status "not-ok"
+ lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata]
+ }
+ }
+
+ }
+
+
+ set result [dict create]
+ dict set result status $status
+ dict set result problems $problems
+
+ return $result
+}
+
+
+#get or set t
+dict set ::p::-1::_iface::o_methods Namespace {arglist {args}}
+proc ::p::-1::Namespace {_ID_ args} {
+ #set invocants [dict get $_ID_ i]
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID this_info
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set IID [lindex [dict get $MAP interfaces level0] end]
+
+ namespace upvar ::p::${IID}::_iface o_varspace active_varspace
+
+ if {[string length $active_varspace]} {
+ set ns ::p::${OID}::$active_varspace
+ } else {
+ set ns ::p::${OID}
+ }
+
+ #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object?
+ # - should .. Namespace be usable at all from outside the object?
+
+
+ if {[llength $args]} {
+ #special case some of the namespace subcommands.
+
+ #delete
+ if {[string match "d*" [lindex $args 0]]} {
+ error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object."
+ }
+ #upvar,ensemble,which,code,origin,expor,import,forget
+ if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} {
+ return [namespace eval $ns [list namespace {*}$args]]
+ }
+ #current
+ if {[string match "cu*" [lindex $args 0]]} {
+ return $ns
+ }
+
+ #children,eval,exists,inscope,parent,qualifiers,tail
+ return [namespace {*}[linsert $args 1 $ns]]
+ } else {
+ return $ns
+ }
+}
+
+
+
+
+
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}}
+proc ::p::-1::PatternUnknown {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+ #::p::predator::remap $invocant
+ }
+
+ set handlermethod [lindex $args 0]
+
+
+ if {[llength $args]} {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ return
+ } else {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ }
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Unknown {arglist {args}}
+proc ::p::-1::Unknown {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand.
+
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+
+ set handlermethod [lindex $args 0]
+
+ if {[llength $args]} {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ #set ::p::${IID}::(unknown) $handlermethod
+
+
+ #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod
+ interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod
+ interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod
+
+ #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod]
+ #namespace eval ::p::${OID} [list namespace unknown $handlermethod]
+
+ return
+ } else {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ }
+
+}
+
+
+#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []'
+# should also work for non-object results
+dict set ::p::-1::_iface::o_methods As {arglist {varname}}
+proc ::p::-1::As {_ID_ varname} {
+ set invocants [dict get $_ID_ i]
+ #puts stdout "invocants: $invocants"
+ #!todo - handle multiple invocants with other roles, not just 'this'
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ tailcall set $varname $cmd
+ } else {
+ #puts stdout "info level 1 [info level 1]"
+ set role_members [dict get $_ID_ i this]
+ if {[llength $role_members] == 1} {
+ set member [lindex $role_members 0]
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ tailcall set $varname $stackvalue
+ } else {
+ #multiple invocants - return all results as a list
+ set resultlist [list]
+ foreach member $role_members {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ lappend resultlist $stackvalue
+ }
+ tailcall set $varname $resultlist
+ }
+ }
+}
+
+#!todo - AsFileStream ??
+dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}}
+proc ::p::-1::AsFile {_ID_ filename args} {
+ dict set default -force 0
+ dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object
+ set opts [dict merge $default $args]
+ set force [dict get $opts -force]
+ set dumpmethod [dict get $opts -dumpmethod]
+
+
+ if {[file pathtype $filename] eq "relative"} {
+ set filename [pwd]/$filename
+ }
+ set filedir [file dirname $filename]
+ if {![sf::file_writable $filedir]} {
+ error "(method AsFile) ERROR folder $filedir is not writable"
+ }
+ if {[file exists $filename]} {
+ if {!$force} {
+ error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite"
+ }
+ if {![sf::file_writable $filename]} {
+ error "(method AsFile) ERROR file $filename is not writable - check permissions"
+ }
+ }
+ set fd [open $filename w]
+ fconfigure $fd -translation binary
+
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ #tailcall set $varname $cmd
+ set object_data [$cmd {*}$dumpmethod]
+ puts -nonewline $fd $object_data
+ close $fd
+ return [list status 1 bytes [string length $object_data] filename $filename]
+ } else {
+ #puts stdout "info level 1 [info level 1]"
+ set role_members [dict get $_ID_ i this]
+ if {[llength $role_members] == 1} {
+ set member [lindex $role_members 0]
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ puts -nonewline $fd $stackvalue
+ close $fd
+ #tailcall set $varname $stackvalue
+ return [list status 1 bytes [string length $stackvalue] filename $filename]
+ } else {
+ #multiple invocants - return all results as a list
+ set resultlist [list]
+ foreach member $role_members {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ lappend resultlist $stackvalue
+ }
+ puts -nonewline $fd $resultset
+ close $fd
+ return [list status 1 bytes [string length $resultset] filename $filename]
+ #tailcall set $varname $resultlist
+ }
+ }
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Object {arglist {}}
+proc ::p::-1::Object {_ID_} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ set result [string map [list ::> ::] $cmd]
+ if {![catch {info level -1} prev_level]} {
+ set called_by "(called by: $prev_level)"
+ } else {
+ set called_by "(called by: interp?)"
+
+ }
+
+ puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n"
+ puts stdout " (returning $result)"
+
+ return $result
+}
+
+#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname
+dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}}
+proc ::p::-1::MakeAlias {_ID_cmdname } {
+ set OID [::p::obj_get_this_oid $_ID_]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ error "concept probably won't work - try making dispatcher understand trailing '= cmdname' "
+}
+dict set ::p::-1::_iface::o_methods ID {arglist {}}
+proc ::p::-1::ID {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ return $OID
+}
+
+dict set ::p::-1::_iface::o_methods IFINFO {arglist {}}
+proc ::p::-1::IFINFO {_ID_} {
+ puts stderr "--_ID_: $_ID_--"
+ set OID [::p::obj_get_this_oid $_ID_]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ puts stderr "-- MAP: $MAP--"
+
+ set interfaces [dict get $MAP interfaces level0]
+ set IFID [lindex $interfaces 0]
+
+ if {![llength $interfaces]} {
+ puts stderr "No interfaces present at level 0"
+ } else {
+ foreach IFID $interfaces {
+ set iface ::p::ifaces::>$IFID
+ puts stderr "$iface : [$iface --]"
+ puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]"
+ set variables [set ::p::${IFID}::_iface::o_variables]
+ puts stderr "\tvariables: $variables"
+ }
+ }
+
+}
+
+
+
+
+dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}}
+proc ::p::-1::INVOCANTDATA {_ID_} {
+ #same as a call to: >object ..
+ return $_ID_
+}
+
+#obsolete?
+dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}}
+proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} {
+ set updated_ID_ $_ID_
+ array set updated_roles [list]
+
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants]
+ foreach role $invocant_roles {
+
+ set role_members [dict get $invocants $role]
+ foreach member [dict get $invocants $role] {
+ #each member is a 2-element list consisting of the OID and a dictionary
+ #each member is a 5-element list
+ #set OID [lindex $member 0]
+ #set object_dict [lindex $member 1]
+ lassign $member OID alias itemcmd cmd wrapped
+
+ set MAP [set ::p::${OID}::_meta::map]
+ #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {}
+
+ if {[dict get $MAP invocantdata] eq $member}
+ #same - nothing to do
+
+ } else {
+ package require overtype
+ puts stderr "---------------------------------------------------------"
+ puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version"
+ set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]]
+ puts stderr "[overtype::left $col1 {_ID_ map value}]: $member"
+ puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]"
+ puts stderr "---------------------------------------------------------"
+ #take _meta::map version
+ lappend updated_roles($role) [dict get $MAP invocantdata]
+ }
+
+ }
+
+ #overwrite changed roles only
+ foreach role [array names updated_roles] {
+ dict set updated_ID_ i $role [set updated_roles($role)]
+ }
+
+ return $updated_ID_
+}
+
+
+
+dict set ::p::-1::_iface::o_methods INFO {arglist {}}
+proc ::p::-1::INFO {_ID_} {
+ set result ""
+ append result "_ID_: $_ID_\n"
+
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants]
+ append result "invocant roles: $invocant_roles\n"
+ set total_invocants 0
+ foreach key $invocant_roles {
+ incr total_invocants [llength [dict get $invocants $key]]
+ }
+
+ append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n"
+ foreach key $invocant_roles {
+ append result "\t-------------------------------\n"
+ append result "\trole: $key\n"
+ set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants
+ append result "\t Raw data for this role: $role_members\n"
+ append result "\t Number of invocants in this role: [llength $role_members]\n"
+ foreach member $role_members {
+ #set OID [lindex [dict get $invocants $key] 0 0]
+ set OID [lindex $member 0]
+ append result "\t\tOID: $OID\n"
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ append result "\t\tmap:\n"
+ foreach key [dict keys $MAP] {
+ append result "\t\t\t$key\n"
+ append result "\t\t\t\t [dict get $MAP $key]\n"
+ append result "\t\t\t----\n"
+ }
+ lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped
+ append result "\t\tNamespace: $namespace\n"
+ append result "\t\tDefault method: $default_method\n"
+ append result "\t\tCommand: $cmd\n"
+ append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n"
+ append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n"
+ append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n"
+ } else {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ append result "\t\t last item on the predator stack is a value not an object"
+ append result "\t\t Value is: $stackvalue"
+
+ }
+ }
+ append result "\n"
+ append result "\t-------------------------------\n"
+ }
+
+
+
+ return $result
+}
+
+
+
+
+dict set ::p::-1::_iface::o_methods Rename {arglist {args}}
+proc ::p::-1::Rename {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ if {![llength $args]} {
+ error "Rename expected \$newname argument"
+ }
+
+ #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant?
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ #puts ">>.>> Rename. _ID_: $_ID_"
+
+ if {[catch {
+
+ if {([llength $args] == 3) && [lindex $args 2] eq "rename"} {
+
+ #appears to be a 'trace command rename' firing
+ #puts "\t>>>> rename trace fired $MAP $args <<<"
+
+ lassign $args oldcmd newcmd
+ set extracted_invocantdata [dict get $MAP invocantdata]
+ lset extracted_invocantdata 3 $newcmd
+ dict set MAP invocantdata $extracted_invocantdata
+
+
+ lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped
+
+ #Write the same info into the _ID_ value of the alias
+ interp alias {} $alias {} ;#first we must delete it
+ interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}]
+
+
+
+ #! $object_command was initially created as the renamed alias - so we have to do it again
+ uplevel 1 [list rename $alias $object_command]
+ trace add command $object_command rename [list $object_command .. Rename]
+
+ } elseif {[llength $args] == 1} {
+ #let the rename trace fire and we will be called again to do the remap!
+ uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]]
+ } else {
+ error "Rename expected \$newname argument ."
+ }
+
+ } errM]} {
+ puts stderr "\t@@@@@@ rename error"
+ set ruler "\t[string repeat - 80]"
+ puts stderr $ruler
+ puts stderr $errM
+ puts stderr $ruler
+
+ }
+
+ return
+
+
+}
+
+proc ::p::obj_get_invocants {_ID_} {
+ return [dict get $_ID_ i]
+}
+#The invocant role 'this' is special and should always have only one member.
+# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX
+proc ::p::obj_get_this_oid {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 0]
+}
+proc ::p::obj_get_this_ns {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 1]
+}
+
+proc ::p::obj_get_this_cmd {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 3]
+}
+proc ::p::obj_get_this_data {_ID_} {
+ lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd
+ #set this_invocant_data {*}[dict get $_ID_ i this]
+ return [list oid $OID ns $ns cmd $cmd]
+}
+proc ::p::map {OID varname} {
+ tailcall upvar #0 ::p::${OID}::_meta::map $varname
+}
+
+
+
diff --git a/src/bootsupport/modules/natsort-0.1.1.6.tm b/src/bootsupport/modules/natsort-0.1.1.6.tm
index 7f7c33cd..07c29895 100644
--- a/src/bootsupport/modules/natsort-0.1.1.6.tm
+++ b/src/bootsupport/modules/natsort-0.1.1.6.tm
@@ -1,6 +1,7 @@
#! /usr/bin/env tclsh
+#todo - remove flagfilter - use punk::args?
package require flagfilter
namespace import ::flagfilter::check_flags
diff --git a/src/bootsupport/modules/pattern-1.2.8.tm b/src/bootsupport/modules/pattern-1.2.8.tm
new file mode 100644
index 00000000..7f5cf4c0
--- /dev/null
+++ b/src/bootsupport/modules/pattern-1.2.8.tm
@@ -0,0 +1,1288 @@
+# -*- tcl -*-
+# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt
+#
+#PATTERN
+# - A prototype-based Object system.
+#
+# Julian Noble 2003
+# License: Public domain
+#
+
+# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern.
+#
+#
+# Pattern uses a mixture of class-based and prototype-based object instantiation.
+#
+# A pattern object has 'properties' and 'methods'
+# The system makes a distinction between them with regards to the access syntax for write operations,
+# and yet provides unity in access syntax for read operations.
+# e.g >object . myProperty
+# will return the value of the property 'myProperty'
+# >ojbect . myMethod
+# will return the result of the method 'myMethod'
+# contrast this with the write operations:
+# set [>object . myProperty .] blah
+# >object . myMethod blah
+# however, the property can also be read using:
+# set [>object . myProperty .]
+# Note the trailing . to give us a sort of 'reference' to the property.
+# this is NOT equivalent to
+# set [>object . myProperty]
+# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property
+# i.e it is equivalent in this case to: set blah
+
+#All objects are represented by a command, the name of which contains a leading ">".
+#Any commands in the interp which use this naming convention are assumed to be a pattern object.
+#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined)
+
+#All user-added properties & methods of the wrapped object are accessed
+# using the separator character "."
+#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".."
+# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype)
+# you would use the 'Create' metamethod on the pattern object like so:
+# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject
+# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties
+# of the object it was created from. (
+
+
+#The use of the access-syntax separator character "." allows objects to be kept
+# 'clean' in the sense that the only methods &/or properties that can be called this way are ones
+# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax
+# so you are free to implement your own 'Create' method on your object that doesn't conflict with
+# the metamethod.
+
+#Chainability (or how to violate the Law of Demeter!)
+#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other
+# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference
+# structure, without the need to regress to enter matching brackets as is required when using
+# standard TCL command syntax.
+# ie instead of:
+# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething
+# we can use:
+# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething
+#
+# This separates out the object-traversal syntax from the TCL command syntax.
+
+# . is the 'traversal operator' when it appears between items in a commandlist
+# . is the 'reference operator' when it is the last item in a commandlist
+# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'.
+# It marks breaks in the multidimensional structure that correspond to how the data is stored.
+# e.g obj . arraydata x y , x1 y1 z1
+# represents an element of a 5-dimensional array structured as a plane of cubes
+# e.g2 obj . arraydata x y z , x1 y1
+# represents an element of a 5-dimensional array structured as a cube of planes
+# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1
+# .. is the 'meta-traversal operator' when it appears between items in a commandlist
+# .. is the 'meta-info operator'(?) when it is the last item in a commandlist
+
+
+#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing
+# implement iStacks & pStacks (interface stacks & pattern stacks)
+
+#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975
+
+
+#------------------------------------------------------------
+# System objects.
+#------------------------------------------------------------
+#::p::-1 ::p::internals::>metaface
+#::p::0 ::p::ifaces::>null
+#::p::1 ::>pattern
+#------------------------------------------------------------
+
+#TODO
+
+#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?)
+
+
+#CHANGES
+#2018-09 - v 1.2.2
+# varied refactoring
+# Changed invocant datastructure curried into commands (the _ID_ structure)
+# Changed MAP structure to dict
+# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns)
+# updated test suites
+#2018-08 - v 1.2.1
+# split ::p::predatorX functions into separate files (pkgs)
+# e.g patternpredator2-1.0.tm
+# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken
+#
+#2017-08 - v 1.1.6 Fairly big overhaul
+# New predator function using coroutines
+# Added bang operator !
+# Fixed Constructor chaining
+# Added a few tests to test::pattern
+#
+#2008-03 - preserve ::errorInfo during var writes
+
+#2007-11
+#Major overhaul + new functionality + new tests v 1.1
+# new dispatch system - 'predator'.
+# (preparing for multiple interface stacks, multiple invocants etc)
+#
+#
+#2006-05
+# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature.
+#
+#2005-12
+# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top.
+#
+# Fixed so that PatternVariable default applied on Create.
+#
+# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE::::
+# - heading towards multiple-interface objects
+#
+#2005-10-28
+# 1.0.8.1 passes 80/80 tests
+# >object .. Destroy - improved cleanup of interfaces & namespaces.
+#
+#2005-10-26
+# fixes to refsync (still messy!)
+# remove variable traces on REF vars during .. Destroy
+# passes 76/76
+#
+#2005-10-24
+# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined.
+# 1.0.8.0 now passes 75/76
+#
+#2005-10-19
+# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before)
+# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names)
+# 1.0.8.0 (passes 74/76)
+# tests now in own package
+# usage:
+# package require test::pattern
+# test::p::list
+# test::p::run ?nameglob? ?-version ?
+#
+#2005-09?-12
+#
+# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc.
+# fixed @next@ so that destination method resolved at interface compile time instead of call time
+# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x.
+# (before, the overlay only occured when '.. Method' was used to override.)
+#
+#
+# miscellaneous tidy-ups
+#
+# 1.0.7.8 (passes 71/73)
+#
+#2005-09-10
+# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value
+# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier.
+#
+#2005-09-07
+# bugfix indexed write to list property
+# bugfix Variable default value
+# 1.0.7.7 (passes 70/72)
+# fails:
+# arrayproperty.test - array-entire-reference
+# properties.test - property_getter_filter_via_ObjectRef
+#
+#2005-04-22
+# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!)
+#
+# 1.0.7.4
+#
+#2004-11-05
+# basic PropertyRead implementation (non-indexed - no tests!)
+#
+#2004-08-22
+# object creation speedups - (pattern::internals::obj simplified/indirected)
+#
+#2004-08-17
+# indexed property setter fixes + tests
+# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values)
+#
+#2004-08-16
+# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset)
+#
+#2004-08-15
+# reference syncing: ensure writes to properties always trigger traces on property references (+ tests)
+# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger
+# - also trigger on curried traces to indexed properties i.e list and array elements.
+# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties.
+#
+# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .]
+#
+#2004-08-05
+# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write)
+#
+# fix + add tests to support method & property of same name. (method precedence)
+#
+#2004-08-04
+# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var)
+#
+# 1.0.7.1
+# use objectref array access to read properties even when some props unset; + test
+# unset property using array access on object reference; + test
+#
+#
+#2004-07-21
+# object reference changes - array property values appear as list value when accessed using upvared array.
+# bugfixes + tests - properties containing lists (multidimensional access)
+#
+#1.0.7
+#
+#2004-07-20
+# fix default property value append problem
+#
+#2004-07-17
+# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods
+# (
+#
+#2004-06-18
+# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces.
+#
+#2004-06-05
+# change argsafety operator to be anything with leading -
+# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-'
+# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg,
+# the entire dash-prefixed operator is also passed in as an argument.
+# e.g >object . doStuff -window .
+# will call the doStuff method with the 2 parameters -window .
+# >object . doStuff - .
+# will call doStuff with single parameter .
+# >object . doStuff - -window .
+# will result in a reference to the doStuff method with the argument -window 'curried' in.
+#
+#2004-05-19
+#1.0.6
+# fix so custom constructor code called.
+# update Destroy metamethod to unset $self
+#
+#1.0.4 - 2004-04-22
+# bug fixes regarding method specialisation - added test
+#
+#------------------------------------------------------------
+
+package provide pattern [namespace eval pattern {variable version; set version 1.2.8}]
+
+
+namespace eval pattern::util {
+
+ # Generally better to use 'package require $minver-'
+ # - this only gives us a different error
+ proc package_require_min {pkg minver} {
+ if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} {
+ package require $pkg
+ } else {
+ error "Package pattern requires package $pkg of at least version $minver. Available: $available"
+ }
+ }
+}
+
+package require patterncmd 1.2.4-
+package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc)
+
+
+
+#package require cmdline
+package require overtype
+
+#package require md5 ;#will be loaded if/when needed
+#package require md4
+#package require uuid
+
+
+
+
+
+namespace eval pattern {
+ variable initialised 0
+
+
+ if 0 {
+ if {![catch {package require twapi_base} ]} {
+ #twapi is a windows only package
+ #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls.
+ # If available - windows seems to provide a fast uuid generator..
+ #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine)
+ # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid}))
+ interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok
+ } else {
+ #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ)
+ # (e.g 200usec 2018 corei9)
+ #(with or without tcllibc?)
+ #very first call is extremely slow though - 3.5seconds on 2018 corei9
+ package require uuid
+ interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate
+ }
+ #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement)
+ }
+
+
+}
+
+
+
+
+
+
+namespace eval p {
+ #this is also the interp alias namespace. (object commands created here , then renamed into place)
+ #the object aliases are named as incrementing integers.. !todo - consider uuids?
+ variable ID 0
+ namespace eval internals {}
+
+
+ #!??
+ #namespace export ??
+ variable coroutine_instance 0
+}
+
+#-------------------------------------------------------------------------------------
+#review - what are these for?
+#note - this function is deliberately not namespaced
+# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features
+proc process_pattern_aliases {object args} {
+ set o [namespace tail $object]
+ interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .]
+ interp alias {} process_method_$o {} [$object .. Method .]
+ interp alias {} process_constructor_$o {} [$object .. Constructor .]
+}
+#-------------------------------------------------------------------------------------
+
+
+
+
+#!store all interface objects here?
+namespace eval ::p::ifaces {}
+
+
+
+#K combinator - see http://wiki.tcl.tk/1923
+#proc ::p::K {x y} {set x}
+#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah]
+
+
+
+
+
+
+
+
+proc ::p::internals::(VIOLATE) {_ID_ violation_script} {
+ #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script]
+ set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]]
+
+ if {![dict get $processed explicitvars]} {
+ #no explicit var statements - we need the implicit ones
+ set self [set ::p::${_ID_}::(self)]
+ set IFID [lindex [set $self] 1 0 end]
+ #upvar ::p::${IFID}:: self_IFINFO
+
+
+ set varDecls {}
+ set vlist [array get ::p::${IFID}:: v,name,*]
+ set _k ""; set v ""
+ if {[llength $vlist]} {
+ append varDecls "upvar #0 "
+ foreach {_k v} $vlist {
+ append varDecls "::p::\${_ID_}::$v $v "
+ }
+ append varDecls "\n"
+ }
+
+ #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out]
+ set violation_script $varDecls\n[dict get $processed body]
+
+ #tidy up
+ unset processed varDecls self IFID _k v
+ } else {
+ set violation_script [dict get $processed body]
+ }
+ unset processed
+
+
+
+
+ #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible.
+ eval "unset violation_script;$violation_script"
+}
+
+
+proc ::p::internals::DestroyObjectsBelowNamespace {ns} {
+ #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n"
+
+ set nsparts [split [string trim [string map {:: :} $ns] :] :]
+ if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} {
+ #ns not of form ::p::?::_ref
+
+ foreach obj [info commands ${ns}::>*] {
+ #catch {::p::meta::Destroy $obj}
+ #puts ">>found object $obj below ns $ns - destroying $obj"
+ $obj .. Destroy
+ }
+ }
+
+ #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR]
+ #foreach tinfo $traces {
+ # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo
+ #}
+ #unset -nocomplain ${ns}::-->PATTERN_ANCHOR
+
+ foreach sub [namespace children $ns] {
+ ::p::internals::DestroyObjectsBelowNamespace $sub
+ }
+}
+
+
+
+
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+
+
+
+
+
+
+
+
+
+proc ::p::get_new_object_id {} {
+ tailcall incr ::p::ID
+ #tailcall ::pattern::new_uuid
+}
+
+#create a new minimal object - with no interfaces or patterns.
+
+#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {}
+proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} {
+
+ #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID"
+
+ if {$OID eq "-2"} {
+ set OID [::p::get_new_object_id]
+ #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?)
+ #set OID [pattern::new_uuid]
+ }
+ #if $wrapped provided it is assumed to be an existing namespace.
+ #if {[string length $wrapped]} {
+ # #???
+ #}
+
+ #sanity check - alias must not exist for this OID
+ if {[llength [interp alias {} ::p::$OID]]} {
+ error "Object alias '::p::$OID' already exists - cannot create new object with this id"
+ }
+
+ #system 'varspaces' -
+
+ #until we have a version of Tcl that doesn't have 'creative writing' scope issues -
+ # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword.
+ # (see http://wiki.tcl.tk/1030 'Dangers of creative writing')
+ #set o_open 1 - every object is initially also an open interface (?)
+ #NOTE! comments within namespace eval slow it down.
+ namespace eval ::p::$OID {
+ #namespace ensemble create
+ namespace eval _ref {}
+ namespace eval _meta {}
+ namespace eval _iface {
+ variable o_usedby;
+ variable o_open 1;
+ array set o_usedby [list];
+ variable o_varspace "" ;
+ variable o_varspaces [list];
+ variable o_methods [dict create];
+ variable o_properties [dict create];
+ variable o_variables;
+ variable o_propertyunset_handlers;
+ set o_propertyunset_handlers [dict create]
+ }
+ }
+
+ #set alias ::p::$OID
+
+ #objectid alis default_method object_command wrapped_namespace
+ set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped]
+
+ #MAP is a dict
+ set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}]
+
+
+
+ #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token
+ #we've already checked that ::p::$OID doesn't pre-exist
+ # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias
+ #interp alias {} ::p::$OID {} ::p::internals::predator $MAP
+
+
+ # _ID_ structure
+ set invocants_dict [dict create this [list $INVOCANTDATA] ]
+ #puts stdout "New _ID_structure: $interfaces_dict"
+ set _ID_ [dict create i $invocants_dict context ""]
+
+
+ interp alias {} ::p::$OID {} ::p::internals::predator $_ID_
+ #rename the command into place - thus the alias & the command name no longer match!
+ rename ::p::$OID $cmd
+
+ set ::p::${OID}::_meta::map $MAP
+
+ # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something
+ interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_
+
+ #set p2 [string map {> ?} $cmd]
+ #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_
+
+
+ #trace add command $cmd delete "$cmd .. Destroy ;#"
+ #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]"
+
+ trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename"
+ #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?)
+
+ #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'"
+
+
+ #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\""
+ #trace add command $cmd delete "puts deleting$cmd ;#"
+ #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\""
+
+
+ #puts "--> new_object returning map $MAP"
+ return $MAP
+}
+
+
+
+
+#>x .. Create >y
+# ".." is special case equivalent to "._."
+# (whereas in theory it would be ".default.")
+# "." is equivalent to ".default." is equivalent to ".default.default." (...)
+
+#>x ._. Create >y
+#>x ._.default. Create >y ???
+#
+#
+
+# create object using 'blah' as source interface-stack ?
+#>x .blah. .. Create >y
+#>x .blah,_. ._. Create .iStackDestination. >y
+
+
+
+#
+# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _]
+# the 1st item, blah in this case becomes the 'default' iStack.
+#
+#>x .*.
+# cast to object with all iStacks
+#
+#>x .*,!_.
+# cast to object with all iStacks except _
+#
+# ---------------------
+#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@'
+# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not.
+#
+#eg1: >x & >y . some_multi_method arg arg
+# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects)
+# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these'
+# The invocant signature is thus {these 2}
+# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1})
+# Invocation roles can be specified in the call using the @ operator.
+# e.g >x & >y @ points . some_multi_method arg arg
+# The invocant signature for this is: {points 2}
+#
+#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path
+# This has the signature {objects n plane 1} where n depends on the length of the list $objects
+#
+#
+# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration.
+# e.g set pointset [>x & >y .]
+# We can now call multimethods on $pointset
+#
+
+
+
+
+
+
+#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package)
+proc ::pattern::predatorversion {{ver ""}} {
+ variable active_predatorversion
+ set allowed_predatorversions {1 2}
+ set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions
+
+ if {![info exists active_predatorversion]} {
+ set first_time_set 1
+ } else {
+ set first_time_set 0
+ }
+
+ if {$ver eq ""} {
+ #get version
+ if {$first_time_set} {
+ set active_predatorversions $default_predatorversion
+ }
+ return $active_predatorversion
+ } else {
+ #set version
+ if {$ver ni $allowed_predatorversions} {
+ error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions"
+ }
+
+ if {!$first_time_set} {
+ if {$active_predatorversion eq $ver} {
+ #puts stderr "Active predator version is already '$ver'"
+ #ok - nothing to do
+ return $active_predatorversion
+ } else {
+ package require patternpredator$ver 1.2.4-
+ if {![llength [info commands ::p::predator$ver]]} {
+ error "Unable to set predatorversion - command ::p::predator$ver not found"
+ }
+ rename ::p::internals::predator ::p::predator$active_predatorversion
+ }
+ }
+ package require patternpredator$ver 1.2.4-
+ if {![llength [info commands ::p::predator$ver]]} {
+ error "Unable to set predatorversion - command ::p::predator$ver not found"
+ }
+
+ rename ::p::predator$ver ::p::internals::predator
+ set active_predatorversion $ver
+
+ return $active_predatorversion
+ }
+}
+::pattern::predatorversion 2
+
+
+
+
+
+
+
+
+
+
+
+
+# >pattern has object ID 1
+# meta interface has object ID 0
+proc ::pattern::init args {
+
+ if {[set ::pattern::initialised]} {
+ if {[llength $args]} {
+ #if callers want to avoid this error, they can do their own check of $::pattern::initialised
+ error "pattern package is already initialised. Unable to apply args: $args"
+ } else {
+ return 1
+ }
+ }
+
+ #this seems out of date.
+ # - where is PatternPropertyRead?
+ # - Object is obsolete
+ # - Coinjoin, Combine don't seem to exist
+ array set ::p::metaMethods {
+ Clone object
+ Conjoin object
+ Combine object
+ Create object
+ Destroy simple
+ Info simple
+ Object simple
+ PatternProperty simple
+ PatternPropertyWrite simple
+ PatternPropertyUnset simple
+ Property simple
+ PropertyWrite simple
+ PatternMethod simple
+ Method simple
+ PatternVariable simple
+ Variable simple
+ Digest simple
+ PatternUnknown simple
+ Unknown simple
+ }
+ array set ::p::metaProperties {
+ Properties object
+ Methods object
+ PatternProperties object
+ PatternMethods object
+ }
+
+
+
+
+
+ #create metaface - IID = -1 - also OID = -1
+ # all objects implement this special interface - accessed via the .. operator.
+
+
+
+
+
+ set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface
+
+
+ #OID = 0
+ ::p::internals::new_object ::p::ifaces::>null "" 0
+
+ #? null object has itself as level0 & level1 interfaces?
+ #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]]
+
+ #null interface should always have 'usedby' members. It should never be extended.
+ array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array
+ set ::p::0::_iface::o_open 0
+
+ set ::p::0::_iface::o_constructor [list]
+ set ::p::0::_iface::o_variables [list]
+ set ::p::0::_iface::o_properties [dict create]
+ set ::p::0::_iface::o_methods [dict create]
+ set ::p::0::_iface::o_varspace ""
+ set ::p::0::_iface::o_varspaces [list]
+ array set ::p::0::_iface::o_definition [list]
+ set ::p::0::_iface::o_propertyunset_handlers [dict create]
+
+
+
+
+ ###############################
+ # OID = 1
+ # >pattern
+ ###############################
+ ::p::internals::new_object ::>pattern "" 1
+
+ #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]]
+
+
+ array set ::p::1::_iface::o_usedby [list] ;#'usedby' array
+
+ set _self ::pattern
+
+ #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1
+ #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1
+
+
+
+ #1)this object references its interfaces
+ #lappend ID $IFID $IFID_1
+ #lset SELFMAP 1 0 $IFID
+ #lset SELFMAP 2 0 $IFID_1
+
+
+ #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND]
+ #proc ::>pattern args $body
+
+
+
+
+ #######################################################################################
+ #OID = 2
+ # >ifinfo interface for accessing interfaces.
+ #
+ ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object
+ set ::p::2::_iface::o_constructor [list]
+ set ::p::2::_iface::o_variables [list]
+ set ::p::2::_iface::o_properties [dict create]
+ set ::p::2::_iface::o_methods [dict create]
+ set ::p::2::_iface::o_varspace ""
+ set ::p::2::_iface::o_varspaces [list]
+ array set ::p::2::_iface::o_definition [list]
+ set ::p::2::_iface::o_open 1 ;#open for extending
+
+ ::p::ifaces::>2 .. AddInterface 2
+
+ #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations
+ #(bootstrap because we can't yet use metaface methods on it)
+
+
+
+ proc ::p::2::_iface::isOpen.1 {_ID_} {
+ return $::p::2::_iface::o_open
+ }
+ interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1
+
+ proc ::p::2::_iface::isClosed.1 {_ID_} {
+ return [expr {!$::p::2::_iface::o_open}]
+ }
+ interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1
+
+ proc ::p::2::_iface::open.1 {_ID_} {
+ set ::p::2::_iface::o_open 1
+ }
+ interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1
+
+ proc ::p::2::_iface::close.1 {_ID_} {
+ set ::p::2::_iface::o_open 0
+ }
+ interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1
+
+
+ #proc ::p::2::_iface::(GET)properties.1 {_ID_} {
+ # set ::p::2::_iface::o_properties
+ #}
+ #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1
+
+ #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties
+
+
+ #proc ::p::2::_iface::(GET)methods.1 {_ID_} {
+ # set ::p::2::_iface::o_methods
+ #}
+ #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1
+ #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods
+
+
+
+
+
+ #link from object to interface (which in this case are one and the same)
+
+ #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --]
+ #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --]
+ #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --]
+ #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --]
+
+ interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen
+ interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed
+ interp alias {} ::p::2::open {} ::p::2::_iface::open
+ interp alias {} ::p::2::close {} ::p::2::_iface::close
+
+
+ #namespace eval ::p::2 "namespace export $method"
+
+ #######################################################################################
+
+
+
+
+
+
+ set ::pattern::initialised 1
+
+
+ ::p::internals::new_object ::p::>interface "" 3
+ #create a convenience object on which to manipulate the >ifinfo interface
+ #set IF [::>pattern .. Create ::p::>interface]
+ set IF ::p::>interface
+
+
+ #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects?
+ # (or is forcing end user to add their own pStack/iStack ok .. ?)
+ #
+ ::p::>interface .. AddPatternInterface 2 ;#
+
+ ::p::>interface .. PatternVarspace _iface
+
+ ::p::>interface .. PatternProperty methods
+ ::p::>interface .. PatternPropertyRead methods {} {
+ varspace _iface
+ var {o_methods alias}
+ return $alias
+ }
+ ::p::>interface .. PatternProperty properties
+ ::p::>interface .. PatternPropertyRead properties {} {
+ varspace _iface
+ var o_properties
+ return $o_properties
+ }
+ ::p::>interface .. PatternProperty variables
+
+ ::p::>interface .. PatternProperty varspaces
+
+ ::p::>interface .. PatternProperty definition
+
+ ::p::>interface .. Constructor {{usedbylist {}}} {
+ #var this
+ #set this @this@
+ #set ns [$this .. Namespace]
+ #puts "-> creating ns ${ns}::_iface"
+ #namespace eval ${ns}::_iface {}
+
+ varspace _iface
+ var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces
+
+ set o_constructor [list]
+ set o_variables [list]
+ set o_properties [dict create]
+ set o_methods [dict create]
+ set o_varspaces [list]
+ array set o_definition [list]
+
+ foreach usedby $usedbylist {
+ set o_usedby(i$usedby) 1
+ }
+
+
+ }
+ ::p::>interface .. PatternMethod isOpen {} {
+ varspace _iface
+ var o_open
+
+ return $o_open
+ }
+ ::p::>interface .. PatternMethod isClosed {} {
+ varspace _iface
+ var o_open
+
+ return [expr {!$o_open}]
+ }
+ ::p::>interface .. PatternMethod open {} {
+ varspace _iface
+ var o_open
+ set o_open 1
+ }
+ ::p::>interface .. PatternMethod close {} {
+ varspace _iface
+ var o_open
+ set o_open 0
+ }
+ ::p::>interface .. PatternMethod refCount {} {
+ varspace _iface
+ var o_usedby
+ return [array size o_usedby]
+ }
+
+ set ::p::2::_iface::o_open 1
+
+
+
+
+ uplevel #0 {pattern::util::package_require_min patternlib 1.2.4}
+ #uplevel #0 {package require patternlib}
+ return 1
+}
+
+
+
+proc ::p::merge_interface {old new} {
+ #puts stderr " ** ** ** merge_interface $old $new"
+ set ns_old ::p::$old
+ set ns_new ::p::$new
+
+ upvar #0 ::p::${new}:: IFACE
+ upvar #0 ::p::${old}:: IFACEX
+
+ if {![catch {set c_arglist $IFACEX(c,args)}]} {
+ #constructor
+ #for now.. just add newer constructor regardless of any existing one
+ #set IFACE(c,args) $IFACEX(c,args)
+
+ #if {![info exists IFACE(c,args)]} {
+ # #target interface didn't have a constructor
+ #
+ #} else {
+ # #
+ #}
+ }
+
+
+ set methods [::list]
+ foreach nm [array names IFACEX m-1,name,*] {
+ lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden)
+ }
+
+ #puts " *** merge interface $old -> $new ****merging-in methods: $methods "
+
+ foreach method $methods {
+ if {![info exists IFACE(m-1,name,$method)]} {
+ #target interface doesn't yet have this method
+
+ set THISNAME $method
+
+ if {![string length [info command ${ns_new}::$method]]} {
+
+ if {![set ::p::${old}::_iface::o_open]} {
+ #interp alias {} ${ns_new}::$method {} ${ns_old}::$method
+ #namespace eval $ns_new "namespace export [namespace tail $method]"
+ } else {
+ #wait to compile
+ }
+
+ } else {
+ error "merge interface - command collision "
+ }
+ #set i 2 ???
+ set i 1
+
+ } else {
+ #!todo - handle how?
+ #error "command $cmd already exists in interface $new"
+
+
+ set i [incr IFACE(m-1,chain,$method)]
+
+ set THISNAME ___system___override_${method}_$i
+
+ #move metadata using subindices for delegated methods
+ set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method)
+ set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method)
+ set IFACE(mp-$i,$method) $IFACE(mp-1,$method)
+
+ set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method)
+ set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method)
+
+
+ #set next [::p::next_script $IFID0 $method]
+ if {![string length [info command ${ns_new}::$THISNAME]]} {
+ if {![set ::p::${old}::_iface::o_open]} {
+ interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method
+ namespace eval $ns_new "namespace export $method"
+ } else {
+ #wait for compile
+ }
+ } else {
+ error "merge_interface - command collision "
+ }
+
+ }
+
+ array set IFACE [::list \
+ m-1,chain,$method $i \
+ m-1,body,$method $IFACEX(m-1,body,$method) \
+ m-1,args,$method $IFACEX(m-1,args,$method) \
+ m-1,name,$method $THISNAME \
+ m-1,iface,$method $old \
+ ]
+
+ }
+
+
+
+
+
+ #array set ${ns_new}:: [array get ${ns_old}::]
+
+
+ #!todo - review
+ #copy everything else across..
+
+ foreach {nm v} [array get IFACEX] {
+ #puts "-.- $nm"
+ if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} {
+ set IFACE($nm) $v
+ }
+ }
+
+ #!todo -write a test
+ set ::p::${new}::_iface::o_open 1
+
+ #!todo - is this done also when iface compiled?
+ #namespace eval ::p::$new {namespace ensemble create}
+
+
+ #puts stderr "copy_interface $old $new"
+
+ #assume that the (usedby) data is now obsolete
+ #???why?
+ #set ${ns_new}::(usedby) [::list]
+
+ #leave ::(usedby) reference in place
+
+ return
+}
+
+
+
+
+#detect attempt to treat a reference to a method as a property
+proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} {
+#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args"
+ lassign [lrange $args end-2 end] vtraced vidx op
+ #NOTE! cannot rely on vtraced as it may have been upvared
+
+ switch -- $op {
+ write {
+ error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])"
+ }
+ unset {
+ #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace
+ #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args]
+
+ #!todo - don't use vtraced!
+ trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args]
+
+ #pointless raising an error as "Any errors in unset traces are ignored"
+ #error "cannot unset. $field is a method not a property"
+ }
+ read {
+ error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])"
+ }
+ array {
+ error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])"
+ #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args"
+ }
+ }
+
+ return
+}
+
+
+
+
+#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points.
+#
+# The 'dispatcher' is an object instance's underlying object command.
+#
+
+#proc ::p::make_dispatcher {obj ID IFID} {
+# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] {
+# ::p::@IID@ $methprop @oid@ {*}$args
+# }]
+# return
+#}
+
+
+
+
+################################################################################################################################################
+################################################################################################################################################
+################################################################################################################################################
+
+#aliased from ::p::${OID}::
+# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something
+proc ::p::internals::no_default_method {_ID_ args} {
+ puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'"
+ lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped
+ tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)"
+}
+
+#force 1 will extend an interface even if shared. (??? why is this necessary here?)
+#if IID empty string - create the interface.
+proc ::p::internals::expand_interface {IID {force 0}} {
+ #puts stdout ">>> expand_interface $IID [info level -1]<<<"
+ if {![string length $IID]} {
+ #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1)
+ set iid [expr {$::p::ID + 1}]
+ ::p::>interface .. Create ::p::ifaces::>$iid
+ return $iid
+ } else {
+ if {[set ::p::${IID}::_iface::o_open]} {
+ #interface open for extending - shared or not!
+ return $IID
+ }
+
+ if {[array size ::p::${IID}::_iface::o_usedby] > 1} {
+ #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby
+
+ #oops.. shared interface. Copy before specialising it.
+ set prev_IID $IID
+
+ #set IID [::p::internals::new_interface]
+ set IID [expr {$::p::ID + 1}]
+ ::p::>interface .. Create ::p::ifaces::>$IID
+
+ ::p::internals::linkcopy_interface $prev_IID $IID
+ #assert: prev_usedby contains at least one other element.
+ }
+
+ #whether copied or not - mark as open for extending.
+ set ::p::${IID}::_iface::o_open 1
+ return $IID
+ }
+}
+
+#params: old - old (shared) interface ID
+# new - new interface ID
+proc ::p::internals::linkcopy_interface {old new} {
+ #puts stderr " ** ** ** linkcopy_interface $old $new"
+ set ns_old ::p::${old}::_iface
+ set ns_new ::p::${new}::_iface
+
+
+
+ foreach nsmethod [info commands ${ns_old}::*.1] {
+ #puts ">>> adding $nsmethod to iface $new"
+ set tail [namespace tail $nsmethod]
+ set method [string range $tail 0 end-2] ;#strip .1
+
+ if {![llength [info commands ${ns_new}::$method]]} {
+
+ set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1
+
+ #link from new interface namespace to existing one.
+ #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...)
+ #!todo? verify?
+ #- actual link is chainslot to chainslot
+ interp alias {} ${ns_new}::$method.1 {} $oldhead
+
+ #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head?
+
+
+ #chainhead pointer within new interface
+ interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1
+
+ namespace eval $ns_new "namespace export $method"
+
+ #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} {
+ # lappend ${ns_new}::o_methods $method
+ #}
+ } else {
+ if {$method eq "(VIOLATE)"} {
+ #ignore for now
+ #!todo
+ continue
+ }
+
+ #!todo - handle how?
+ #error "command $cmd already exists in interface $new"
+
+ #warning - existing chainslot will be completely shadowed by linked method.
+ # - existing one becomes unreachable. #!todo review!?
+
+
+ error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)"
+
+ }
+ }
+
+
+ #foreach propinf [set ${ns_old}::o_properties] {
+ # lassign $propinf prop _default
+ # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop
+ # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop
+ # lappend ${ns_new}::o_properties $propinf
+ #}
+
+
+ set ${ns_new}::o_variables [set ${ns_old}::o_variables]
+ set ${ns_new}::o_properties [set ${ns_old}::o_properties]
+ set ${ns_new}::o_methods [set ${ns_old}::o_methods]
+ set ${ns_new}::o_constructor [set ${ns_old}::o_constructor]
+
+
+ set ::p::${old}::_iface::o_usedby(i$new) linkcopy
+
+
+ #obsolete.?
+ array set ::p::${new}:: [array get ::p::${old}:: ]
+
+
+
+ #!todo - is this done also when iface compiled?
+ #namespace eval ::p::${new}::_iface {namespace ensemble create}
+
+
+ #puts stderr "copy_interface $old $new"
+
+ #assume that the (usedby) data is now obsolete
+ #???why?
+ #set ${ns_new}::(usedby) [::list]
+
+ #leave ::(usedby) reference in place for caller to change as appropriate - 'copy'
+
+ return
+}
+################################################################################################################################################
+################################################################################################################################################
+################################################################################################################################################
+
+pattern::init
+
+return $::pattern::version
diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm
index 6bf529eb..4bc2c7ce 100644
--- a/src/bootsupport/modules/punk-0.1.tm
+++ b/src/bootsupport/modules/punk-0.1.tm
@@ -237,7 +237,7 @@ namespace eval punk {
- #winget is installed on all modern windows and is an example of the problem this addresses
+ #winget is installed on all modern windows (but not on windows sandbox!) and is an example of the problem this addresses
#we target apps with same location
#the main purpose of this override is to support windows app executables (installed as 'reparse points')
@@ -255,7 +255,7 @@ namespace eval punk {
#This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps
if {!([info exists ::env(LOCALAPPDATA)] &&
[file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} {
- #should be unlikely to get here - unless LOCALAPPDATA missing
+ #should be unlikely to get here - unless LOCALAPPDATA missing (or winget.exe missing e.g windows sandbox)
set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]]
catch {puts stderr "(resolved winget by search)"}
} else {
diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
index ad60b069..124c6cf2 100644
--- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
+++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
@@ -887,10 +887,23 @@ namespace eval punk::mix::cli {
if {$tmfile_versionsegment eq $magicversion} {
set tmfile $buildfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl
#we don't need to modify version or name of the loadscript
- #just do basic sanity check that the file exists
if {![file exists $tmfile]} {
set had_error 1
lappend notes "tarjar_loadscript_missing"
+ } else {
+ #the loadscript must end in a line starting with # and ending with backslash - with no linefeed
+ set fd [open $tmfile r]
+ chan configure $fd -translation binary
+ #last line must be less than 1k long
+ chan seek $fd -1024 end
+ set script_tail [read $fd]
+ set lastlf [string last \n $script_tail]
+ set lastline [string range $script_tail $lastlf+1 end]
+ set lastline [string trimleft $lastline] ;#lhs whitespace is ok
+ if {[string index $lastline 0] ne "#" || [string index $lastline end] ne "\\" } {
+ set had_error 1
+ lappend notes "tarjar_loadscript_badtail"
+ }
}
}
#delete and regenerate .tm
diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
index 723ce06e..30120a7e 100644
--- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
+++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
@@ -99,32 +99,23 @@ namespace eval punk::mix::commandset::module {
set names [dict keys $tdict]
set paths [list]
set pathtypes [list]
+ set providers [list]
dict for {nm tinfo} $tdict {
- lappend paths [dict get $tinfo path]
- lappend pathtypes [dict get $tinfo sourceinfo pathtype]
+ lappend paths [dict get $tinfo path]
+ lappend pathtypes [dict get $tinfo sourceinfo pathtype]
+ lappend providers [dict get $tinfo sourceinfo source] ;#name of provider module of punk.templates capability for this path
}
- set title(path) "Path"
- set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]]
- set col(path) [string repeat " " $widest(path)]
-
- set title(pathtype) "[a+ green]Path Type[a]"
- set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {string length $v}]]
- set col(pathtype) [string repeat " " $widest(pathtype)]
-
set title(name) "Template Name"
- set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {string length $v}]]
- set col(name) [string repeat " " $widest(name)]
-
- set tablewidth [expr {$widest(name) + 1 + $widest(pathtype) + 1 + $widest(name)}]
- set table ""
- append table [string repeat - $tablewidth] \n
- append table "[textblock::join -- [overtype::left $col(name) $title(name)] " " [overtype::left $col(pathtype) $title(pathtype)] " " [overtype::left $col(path) $title(path)]]" \n
- append table [string repeat - $tablewidth] \n
+ set title(pathtype) "[a+ italic]Provider[a]\n[a+ green]Path Type[a]"
+ set title(path) "Path"
- foreach n $names pt $pathtypes p $paths {
- append table "[overtype::left $col(name) $n] [overtype::left $col(pathtype) $pt] [overtype::left $col(path) $p]" \n
+ set data [list]
+ foreach n $names pt $pathtypes pv $providers p $paths {
+ #append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n
+ lappend data $n "[a+ italic]$pv[a]\n$pt" $p
}
+ set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data]
return $table
}
diff --git a/src/project_layouts/vendor/punk/project-0.1/src/vfs/sample.vfs/modules/shellfilter-0.1.8.tm b/src/bootsupport/modules/shellfilter-0.1.9.tm
similarity index 72%
rename from src/project_layouts/vendor/punk/project-0.1/src/vfs/sample.vfs/modules/shellfilter-0.1.8.tm
rename to src/bootsupport/modules/shellfilter-0.1.9.tm
index ac15da38..73ea752c 100644
--- a/src/project_layouts/vendor/punk/project-0.1/src/vfs/sample.vfs/modules/shellfilter-0.1.8.tm
+++ b/src/bootsupport/modules/shellfilter-0.1.9.tm
@@ -10,44 +10,67 @@
#
-namespace eval shellfilter::log {
- variable allow_adhoc_tags 0
- variable open_logs [dict create]
-
- #'tag' is an identifier for the log source.
- # each tag will use it's own thread to write to the configured log target
- proc open {tag {settingsdict {}}} {
- upvar ::shellfilter::sources sourcelist
- package require shellthread
- if {![dict exists $settingsdict -tag]} {
- dict set settingsdict -tag $tag
- } else {
- if {$tag ne [dict get $settingsdict -tag]} {
- error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[dict get $settingsdict -tag]' omit -tag, or supply same value"
+tcl::namespace::eval shellfilter::log {
+ variable allow_adhoc_tags 1
+ variable open_logs [tcl::dict::create]
+ variable is_enabled 0
+
+ proc disable {} {
+ variable is_enabled
+ set is_enabled 0
+ proc ::shellfilter::log::open {tag settingsdict} {}
+ proc ::shellfilter::log::write {tag msg} {}
+ proc ::shellfilter::log::write_sync {tag msg} {}
+ proc ::shellfilter::log::close {tag} {}
+ }
+
+ proc enable {} {
+ variable is_enabled
+ set is_enabled 1
+ #'tag' is an identifier for the log source.
+ # each tag will use it's own thread to write to the configured log target
+ proc ::shellfilter::log::open {tag {settingsdict {}}} {
+ upvar ::shellfilter::sources sourcelist
+ if {![dict exists $settingsdict -tag]} {
+ tcl::dict::set settingsdict -tag $tag
+ } else {
+ #review
+ if {$tag ne [tcl::dict::get $settingsdict -tag]} {
+ error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
+ }
+ }
+ if {$tag ni $sourcelist} {
+ lappend sourcelist $tag
}
+
+ #note new_worker
+ set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
+ #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
+ return $worker_tid
}
- if {$tag ni $sourcelist} {
- lappend sourcelist $tag
+ proc ::shellfilter::log::write {tag msg} {
+ upvar ::shellfilter::sources sourcelist
+ variable allow_adhoc_tags
+ if {!$allow_adhoc_tags} {
+ if {$tag ni $sourcelist} {
+ error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
+ }
+ }
+ shellthread::manager::write_log $tag $msg
+ }
+ #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
+ proc ::shellfilter::log::write_sync {tag msg} {
+ shellthread::manager::write_log $tag $msg -async 0
+ }
+ proc ::shellfilter::log::close {tag} {
+ #shellthread::manager::close_worker $tag
+ shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
}
- #note new_worker
- set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
- #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
- return $worker_tid
- }
- proc write {tag msg} {
- shellthread::manager::write_log $tag $msg
- }
- #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
- proc write_sync {tag msg} {
- shellthread::manager::write_log $tag $msg -async 0
- }
- proc close {tag} {
- #shellthread::manager::close_worker $tag
- shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
}
- #todo -implement
+ #review
+ #configure whether we can call shellfilter::log::write without having called open first
proc require_open {{is_open_required {}}} {
variable allow_adhoc_tags
if {![string length $is_open_required]} {
@@ -64,10 +87,18 @@ namespace eval shellfilter::log {
}
}
}
+ if {[catch {package require shellthread}]} {
+ shellfilter::log::disable
+ } else {
+ shellfilter::log::enable
+ }
+
}
namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere
- proc open_out {tag_pipename {settingsdict {}}} {
+ proc open_out {tag_pipename {pipesettingsdict {}}} {
+ set defaultsettings {-buffering full}
+ set settingsdict [dict merge $defaultsettings $pipesettingsdict]
package require shellthread
#we are only using the fifo in a single direction to pipe to another thread
# - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each
@@ -86,7 +117,7 @@ namespace eval shellfilter::pipe {
#chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably..
chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf
- set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict]
+ set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict]
#puts stderr "worker_tid: $worker_tid"
#set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer
@@ -119,183 +150,14 @@ namespace eval shellfilter::pipe {
}
}
-namespace eval shellfilter::ansi2 {
- #shellfilter::ansi procs only: adapted from ansicolor page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control except where otherwise marked
- variable test "blah\033\[1;33mETC\033\[0;mOK"
- namespace export + = ?
- #CSI m = SGR (Select Graphic Rendition)
- variable SGR_setting_map {
- bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22
- underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23
- reverse 7 noreverse 27 defaultfg 39 defaultbg 49
- overline 53 nooverline 55 frame 51 framecircle 52 noframe 54
- }
- variable SGR_colour_map {
- black 30 red 31 green 32 yellow 33 blue 4 purple 35 cyan 36 white 37
- Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47
- BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107
- }
- variable SGR_map
- set SGR_map [dict merge $SGR_colour_map $SGR_setting_map]
-
- proc colourmap1 {{bgname White}} {
- package require textblock
-
- set bg [textblock::block 3 33 "[a+ $bgname] [a=]"]
- set colormap ""
- for {set i 0} {$i <= 7} {incr i} {
- append colormap "_[a+ white bold 48\;5\;$i] $i [a=]"
- }
- set map1 [overtype::left -transparent _ $bg "\n$colormap"]
- return $map1
- }
- proc colourmap2 {{bgname White}} {
- package require textblock
- set bg [textblock::block 3 39 "[a+ $bgname] [a=]"]
- set colormap ""
- for {set i 8} {$i <= 15} {incr i} {
- append colormap "_[a+ black normal 48\;5\;$i] $i [a=]" ;#black normal is blacker than black bold - which often displays as a grey
- }
- set map2 [overtype::left -transparent _ $bg "\n$colormap"]
- return $map2
- }
- proc ? {args} {
- variable SGR_setting_map
- variable SGR_colour_map
-
- if {![llength $args]} {
- set out ""
- append out $SGR_setting_map \n
- append out $SGR_colour_map \n
-
- try {
- set bgname "White"
- set map1 [colourmap1 $bgname]
- set map1 [overtype::centre -transparent 1 $map1 "[a= black $bgname]Standard colours[a=]"]
- set map2 [colourmap2 $bgname]
- set map2 [overtype::centre -transparent 1 $map2 "[a= black $bgname]High-intensity colours[a=]"]
- append out [textblock::join $map1 " " $map2] \n
- #append out $map1[a=] \n
- #append out $map2[a=] \n
-
-
-
- } on error {result options} {
- puts stderr "Failed to draw colormap"
- puts stderr "$result"
- } finally {
- return $out
- }
- } else {
- set result [list]
- set rmap [lreverse $map]
- foreach i $args {
- if {[string is integer -strict $i]} {
- if {[dict exists $rmap $i]} {
- lappend result $i [dict get $rmap $i]
- }
- } else {
- if {[dict exists $map $i]} {
- lappend result $i [dict get $map $i]
- }
- }
- }
- return $result
- }
- }
- proc + {args} {
- #don't disable ansi here.
- #we want this to be available to call even if ansi is off
- variable SGR_map
- set t [list]
- foreach i $args {
- if {[string is integer -strict $i]} {
- lappend t $i
- } elseif {[string first ";" $i] >=0} {
- #literal with params
- lappend t $i
- } else {
- if {[dict exists $SGR_map $i]} {
- lappend t [dict get $SGR_map $i]
- } else {
- #accept examples for foreground
- # 256f-# or 256fg-# or 256f#
- # rgbf--- or rgbfg--- or rgbf--
- if {[string match -nocase "256f*" $i]} {
- set cc [string trim [string range $i 4 end] -gG]
- lappend t "38;5;$cc"
- } elseif {[string match -nocase 256b* $i]} {
- set cc [string trim [string range $i 4 end] -gG]
- lappend t "48;5;$cc"
- } elseif {[string match -nocase rgbf* $i]} {
- set rgb [string trim [string range $i 4 end] -gG]
- lassign [split $rgb -] r g b
- lappend t "38;2;$r;$g;$b"
- } elseif {[string match -nocase rgbb* $i]} {
- set rgb [string trim [string range $i 4 end] -gG]
- lassign [split $rgb -] r g b
- lappend t "48;2;$r;$g;$b"
- }
- }
- }
- }
- # \033 - octal. equivalently \x1b in hex which is more common in documentation
- if {![llength $t]} {
- return "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s))
- }
- return "\x1b\[[join $t {;}]m"
- }
- proc = {args} {
- #don't disable ansi here.
- #we want this to be available to call even if ansi is off
- variable SGR_map
- set t [list]
- foreach i $args {
- if {[string is integer -strict $i]} {
- lappend t $i
- } elseif {[string first ";" $i] >=0} {
- #literal with params
- lappend t $i
- } else {
- if {[dict exists $SGR_map $i]} {
- lappend t [dict get $SGR_map $i]
- } else {
- #accept examples for foreground
- # 256f-# or 256fg-# or 256f#
- # rgbf--- or rgbfg--- or rgbf--
- if {[string match -nocase "256f*" $i]} {
- set cc [string trim [string range $i 4 end] -gG]
- lappend t "38;5;$cc"
- } elseif {[string match -nocase 256b* $i]} {
- set cc [string trim [string range $i 4 end] -gG]
- lappend t "48;5;$cc"
- } elseif {[string match -nocase rgbf* $i]} {
- set rgb [string trim [string range $i 4 end] -gG]
- lassign [split $rgb -] r g b
- lappend t "38;2;$r;$g;$b"
- } elseif {[string match -nocase rgbb* $i]} {
- set rgb [string trim [string range $i 4 end] -gG]
- lassign [split $rgb -] r g b
- lappend t "48;2;$r;$g;$b"
- }
- }
- }
- }
- # \033 - octal. equivalently \x1b in hex which is more common in documentation
- # empty list [a=] should do reset - same for [a= nonexistant]
- # explicit reset at beginning of parameter list for a= (as opposed to a+)
- set t [linsert $t 0 0]
- return "\x1b\[[join $t {;}]m"
- }
-
-
-}
namespace eval shellfilter::ansi {
- #maint warning - from overtype package
+ #maint warning -
+ #ansistrip from punk::ansi is better/more comprehensive
proc stripcodes {text} {
+ #obsolete?
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"]
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic
@@ -409,18 +271,18 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
- set o_enc [dict get $tf -encoding]
+ set o_enc [tcl::dict::get $tf -encoding]
set o_lastxlines [list]
set o_postcountdown 0
- set defaults [dict create -pre 1 -post 1]
- set settingsdict [dict get $tf -settings]
- set settings [dict merge $defaults $settingsdict]
- set o_datavar [dict get $settings -varname]
- set o_grepfor [dict get $settings -grep]
- set o_prelines [dict get $settings -pre]
- set o_postlines [dict get $settings -post]
- if {[dict exists $tf -junction]} {
- set o_is_junction [dict get $tf -junction]
+ set defaults [tcl::dict::create -pre 1 -post 1]
+ set settingsdict [tcl::dict::get $tf -settings]
+ set settings [tcl::dict::merge $defaults $settingsdict]
+ set o_datavar [tcl::dict::get $settings -varname]
+ set o_grepfor [tcl::dict::get $settings -grep]
+ set o_prelines [tcl::dict::get $settings -pre]
+ set o_postlines [tcl::dict::get $settings -post]
+ if {[tcl::dict::exists $tf -junction]} {
+ set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@@ -437,7 +299,7 @@ namespace eval shellfilter::chan {
# return ?
#}
method write {transform_handle bytes} {
- set logdata [encoding convertfrom $o_enc $bytes]
+ set logdata [tcl::encoding::convertfrom $o_enc $bytes]
set lastx $o_lastxlines
lappend o_lastxlines $logdata
@@ -477,22 +339,25 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
- set o_enc [dict get $tf -encoding]
- set settingsdict [dict get $tf -settings]
- set varname [dict get $settingsdict -varname]
+ set o_enc [tcl::dict::get $tf -encoding]
+ set settingsdict [tcl::dict::get $tf -settings]
+ set varname [tcl::dict::get $settingsdict -varname]
set o_datavars $varname
- if {[dict exists $tf -junction]} {
- set o_is_junction [dict get $tf -junction]
+ if {[tcl::dict::exists $tf -junction]} {
+ set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
}
method initialize {ch mode} {
- return [list initialize finalize write]
+ return [list initialize finalize write flush clear]
}
method finalize {ch} {
my destroy
}
+ method clear {ch} {
+ return
+ }
method watch {ch events} {
# must be present but we ignore it because we do not
# post any events
@@ -500,8 +365,11 @@ namespace eval shellfilter::chan {
#method read {ch count} {
# return ?
#}
+ method flush {ch} {
+ return ""
+ }
method write {ch bytes} {
- set stringdata [encoding convertfrom $o_enc $bytes]
+ set stringdata [tcl::encoding::convertfrom $o_enc $bytes]
foreach v $o_datavars {
append $v $stringdata
}
@@ -519,21 +387,21 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
- set o_enc [dict get $tf -encoding]
- set settingsdict [dict get $tf -settings]
+ set o_enc [tcl::dict::get $tf -encoding]
+ set settingsdict [tcl::dict::get $tf -settings]
if {![dict exists $settingsdict -tag]} {
error "tee_to_pipe constructor settingsdict missing -tag"
}
- set o_localchan [dict get $settingsdict -pipechan]
- set o_logsource [dict get $settingsdict -tag]
- if {[dict exists $tf -junction]} {
- set o_is_junction [dict get $tf -junction]
+ set o_localchan [tcl::dict::get $settingsdict -pipechan]
+ set o_logsource [tcl::dict::get $settingsdict -tag]
+ if {[tcl::dict::exists $tf -junction]} {
+ set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
}
method initialize {transform_handle mode} {
- return [list initialize read write finalize]
+ return [list initialize read drain write flush clear finalize]
}
method finalize {transform_handle} {
::shellfilter::log::close $o_logsource
@@ -543,14 +411,23 @@ namespace eval shellfilter::chan {
# must be present but we ignore it because we do not
# post any events
}
+ method clear {transform_handle} {
+ return
+ }
+ method drain {transform_handle} {
+ return ""
+ }
method read {transform_handle bytes} {
- set logdata [encoding convertfrom $o_enc $bytes]
+ set logdata [tcl::encoding::convertfrom $o_enc $bytes]
#::shellfilter::log::write $o_logsource $logdata
puts -nonewline $o_localchan $logdata
return $bytes
}
+ method flush {transform_handle} {
+ return ""
+ }
method write {transform_handle bytes} {
- set logdata [encoding convertfrom $o_enc $bytes]
+ set logdata [tcl::encoding::convertfrom $o_enc $bytes]
#::shellfilter::log::write $o_logsource $logdata
puts -nonewline $o_localchan $logdata
return $bytes
@@ -569,15 +446,15 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
- set o_enc [dict get $tf -encoding]
- set settingsdict [dict get $tf -settings]
- if {![dict exists $settingsdict -tag]} {
+ set o_enc [tcl::dict::get $tf -encoding]
+ set settingsdict [tcl::dict::get $tf -settings]
+ if {![tcl::dict::exists $settingsdict -tag]} {
error "tee_to_log constructor settingsdict missing -tag"
}
- set o_logsource [dict get $settingsdict -tag]
+ set o_logsource [tcl::dict::get $settingsdict -tag]
set o_tid [::shellfilter::log::open $o_logsource $settingsdict]
- if {[dict exists $tf -junction]} {
- set o_is_junction [dict get $tf -junction]
+ if {[tcl::dict::exists $tf -junction]} {
+ set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@@ -594,12 +471,12 @@ namespace eval shellfilter::chan {
# post any events
}
method read {ch bytes} {
- set logdata [encoding convertfrom $o_enc $bytes]
+ set logdata [tcl::encoding::convertfrom $o_enc $bytes]
::shellfilter::log::write $o_logsource $logdata
return $bytes
}
method write {ch bytes} {
- set logdata [encoding convertfrom $o_enc $bytes]
+ set logdata [tcl::encoding::convertfrom $o_enc $bytes]
::shellfilter::log::write $o_logsource $logdata
return $bytes
}
@@ -666,8 +543,8 @@ namespace eval shellfilter::chan {
#review - we should probably provide a more narrow filter than only strips color - and one that strips most(?)
# - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?)
- #punk::ansi::stripansi converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion
- #assumes line-buffering. a more advanced filter required if ansicodes can arrive split accross separate read or write operations!
+ #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion
+ #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations!
oo::class create ansistrip {
variable o_trecord
variable o_enc
@@ -683,23 +560,31 @@ namespace eval shellfilter::chan {
}
}
method initialize {transform_handle mode} {
- return [list initialize read write finalize]
+ return [list initialize read write clear flush drain finalize]
}
method finalize {transform_handle} {
my destroy
}
+ method clear {transform_handle} {
+ return
+ }
method watch {transform_handle events} {
}
+ method drain {transform_handle} {
+ return ""
+ }
method read {transform_handle bytes} {
set instring [encoding convertfrom $o_enc $bytes]
- set outstring [punk::ansi::stripansi $instring]
+ set outstring [punk::ansi::ansistrip $instring]
return [encoding convertto $o_enc $outstring]
}
+ method flush {transform_handle} {
+ return ""
+ }
method write {transform_handle bytes} {
set instring [encoding convertfrom $o_enc $bytes]
- set outstring [punk::ansi::stripansi $instring]
+ set outstring [punk::ansi::ansistrip $instring]
return [encoding convertto $o_enc $outstring]
- #return [encoding convertto unicode $outstring]
}
method meta_is_redirection {} {
return $o_is_junction
@@ -743,6 +628,15 @@ namespace eval shellfilter::chan {
}
}
+
+ #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it.
+ #It can be useful for test/debugging
+ #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi
+ #
+ set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit
+ #todo kitty graphics \x1b_G...
+ #todo iterm graphics
+
oo::class create ansiwrap {
variable o_trecord
variable o_enc
@@ -750,13 +644,16 @@ namespace eval shellfilter::chan {
variable o_do_colour
variable o_do_normal
variable o_is_junction
+ variable o_codestack
+ variable o_gx_state ;#on/off alt graphics
+ variable o_buffered
constructor {tf} {
package require punk::ansi
set o_trecord $tf
- set o_enc [dict get $tf -encoding]
- set settingsdict [dict get $tf -settings]
- if {[dict exists $settingsdict -colour]} {
- set o_colour [dict get $settingsdict -colour]
+ set o_enc [tcl::dict::get $tf -encoding]
+ set settingsdict [tcl::dict::get $tf -settings]
+ if {[tcl::dict::exists $settingsdict -colour]} {
+ set o_colour [tcl::dict::get $settingsdict -colour]
set o_do_colour [punk::ansi::a+ {*}$o_colour]
set o_do_normal [punk::ansi::a]
} else {
@@ -764,25 +661,312 @@ namespace eval shellfilter::chan {
set o_do_colour ""
set o_do_normal ""
}
- if {[dict exists $tf -junction]} {
- set o_is_junction [dict get $tf -junction]
+ set o_codestack [list]
+ set o_gx_state [expr {off}]
+ set o_buffered "" ;#hold back data that potentially contains partial ansi codes
+ if {[tcl::dict::exists $tf -junction]} {
+ set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
}
+
+
+ #todo - track when in sixel,iterm,kitty graphics data - can be very large
+ method Trackcodes {chunk} {
+ #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter)
+ #e.g [a+ reset reset] (0;0m vs 0;m)
+
+ #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]"
+ set buf $o_buffered$chunk
+ set emit ""
+ if {[string last \x1b $buf] >= 0} {
+ #detect will detect ansi SGR and gron groff and other codes
+ if {[punk::ansi::ta::detect $buf]} {
+ #split_codes_single regex faster than split_codes - but more resulting parts
+ #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc)
+ set parts [punk::ansi::ta::split_codes_single $buf]
+ #process all pt/code pairs except for trailing pt
+ foreach {pt code} [lrange $parts 0 end-1] {
+ #puts "<==[ansistring VIEW -lf 1 $pt]==>"
+ switch -- [llength $o_codestack] {
+ 0 {
+ append emit $o_do_colour$pt$o_do_normal
+ }
+ 1 {
+ if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} {
+ append emit $o_do_colour$pt$o_do_normal
+ set o_codestack [list]
+ } else {
+ #append emit [lindex $o_codestack 0]$pt
+ append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt
+ }
+ }
+ default {
+ append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt
+ }
+ }
+ #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
+ # append emit $o_do_colour$pt$o_do_normal
+ # #append emit $pt
+ #} else {
+ # append emit $pt
+ #}
+
+ set c1c2 [tcl::string::range $code 0 1]
+ set leadernorm [tcl::string::range [tcl::string::map [list\
+ \x1b\[ 7CSI\
+ \x9b 8CSI\
+ \x1b\( 7GFX\
+ ] $c1c2] 0 3]
+ switch -- $leadernorm {
+ 7CSI - 8CSI {
+ if {[punk::ansi::codetype::is_sgr_reset $code]} {
+ set o_codestack [list "\x1b\[m"]
+ } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
+ set o_codestack [list $code]
+ } elseif {[punk::ansi::codetype::is_sgr $code]} {
+ #todo - make caching is_sgr method
+ set dup_posns [lsearch -all -exact $o_codestack $code]
+ set o_codestack [lremove $o_codestack {*}$dup_posns]
+ lappend o_codestack $code
+ } else {
+
+ }
+ }
+ 7GFX {
+ switch -- [tcl::string::index $code 2] {
+ "0" {
+ set o_gx_state on
+ }
+ "B" {
+ set o_gx_state off
+ }
+ }
+ }
+ default {
+ #other ansi codes
+ }
+ }
+ append emit $code
+ }
+
+
+ set trailing_pt [lindex $parts end]
+ if {[string first \x1b $trailing_pt] >= 0} {
+ #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'"
+ #may not be plaintext after all
+ set o_buffered $trailing_pt
+ #puts stdout "=-=[ansistring VIEWCODES $o_buffered]"
+ } else {
+ #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a]
+ switch -- [llength $o_codestack] {
+ 0 {
+ append emit $o_do_colour$trailing_pt$o_do_normal
+ }
+ 1 {
+ if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} {
+ append emit $o_do_colour$trailing_pt$o_do_normal
+ set o_codestack [list]
+ } else {
+ #append emit [lindex $o_codestack 0]$trailing_pt
+ append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt
+ }
+ }
+ default {
+ append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt
+ }
+ }
+ #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} {
+ # append emit $o_do_colour$trailing_pt$o_do_normal
+ #} else {
+ # append emit $trailing_pt
+ #}
+ #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext
+ set o_buffered ""
+ }
+
+
+ } else {
+ #REVIEW - this holding a buffer without emitting as we go is ugly.
+ # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence.
+ # - we'd then need to detect the appropriate close to restart splitting and codestacking
+ # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately.
+
+
+ #puts "-->esc but no detect"
+ #no complete ansi codes - but at least one esc is present
+ if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} {
+ #string index in first part of && clause to avoid some unneeded scans of whole string for this test
+ #we can't use 'string last' - as we need to know only esc is last char in buf
+ #puts ">>trailing-esc<<"
+ set o_buffered \x1b
+ set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal
+ #set emit [string range $buf 0 end-1]
+ set buf ""
+ } else {
+ set emit_anyway 0
+ #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer
+ if {[punk::ansi::ta::detect_st_open $buf]} {
+ #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms)
+ set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code
+ #todo - configurable ST max - use 1k for now
+ if {$st_partial_len < 1001} {
+ append o_buffered $chunk
+ set emit ""
+ set buf ""
+ } else {
+ set emit_anyway 1
+ set o_buffered ""
+ }
+ } else {
+ set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code
+ #most opening sequences are 1,2 or 3 chars - review?
+ set open_sequence_detected [punk::ansi::ta::detect_open $buf]
+ if {$possible_code_len > 10 && !$open_sequence_detected} {
+ set emit_anyway 1
+ set o_buffered ""
+ } else {
+ #could be composite sequence with params - allow some reasonable max sequence length
+ #todo - configurable max sequence length
+ #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies
+ # - allow some headroom for redundant codes when the caller didn't merge.
+ if {$possible_code_len < 101} {
+ append o_buffered $chunk
+ set buf ""
+ set emit ""
+ } else {
+ #allow a little more grace if we at least have an opening ansi sequence of any type..
+ if {$open_sequence_detected && $possible_code_len < 151} {
+ append o_buffered $chunk
+ set buf ""
+ set emit ""
+ } else {
+ set emit_anyway 1
+ set o_buffered ""
+ }
+ }
+ }
+ }
+ if {$emit_anyway} {
+ #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared.
+
+ #looked ansi-like - but we've given enough length without detecting close..
+ #treat as possible plain text with some esc or unrecognised ansi sequence
+ switch -- [llength $o_codestack] {
+ 0 {
+ set emit $o_do_colour$buf$o_do_normal
+ }
+ 1 {
+ if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} {
+ set emit $o_do_colour$buf$o_do_normal
+ set o_codestack [list]
+ } else {
+ #set emit [lindex $o_codestack 0]$buf
+ set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf
+ }
+ }
+ default {
+ #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf
+ set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf
+ }
+ }
+ #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} {
+ # set emit $o_do_colour$buf$o_do_normal
+ #} else {
+ # set emit $buf
+ #}
+ }
+ }
+ }
+ } else {
+ #no esc
+ #puts stdout [a+ yellow]...[a]
+ #test!
+ switch -- [llength $o_codestack] {
+ 0 {
+ set emit $o_do_colour$buf$o_do_normal
+ }
+ 1 {
+ if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} {
+ set emit $o_do_colour$buf$o_do_normal
+ set o_codestack [list]
+ } else {
+ #set emit [lindex $o_codestack 0]$buf
+ set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf
+ }
+ }
+ default {
+ #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf
+ set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf
+ }
+ }
+ set o_buffered ""
+ }
+ return [dict create emit $emit stacksize [llength $o_codestack]]
+ }
method initialize {transform_handle mode} {
- return [list initialize write finalize]
+ #clear undesirable in terminal output channels (review)
+ return [list initialize write flush read drain finalize]
}
method finalize {transform_handle} {
my destroy
}
method watch {transform_handle events} {
}
+ method clear {transform_handle} {
+ #In the context of stderr/stdout - we probably don't want clear to run.
+ #Terminals might call it in the middle of a split ansi code - resulting in broken output.
+ #Leave clear of it the init call
+ puts stdout ""
+ set emit [tcl::encoding::convertto $o_enc $o_buffered]
+ set o_buffered ""
+ return $emit
+ }
+ method flush {transform_handle} {
+ #puts stdout ""
+ set emit [tcl::encoding::convertto $o_enc $o_buffered]
+ set o_buffered ""
+ return $emit
+ return
+ }
method write {transform_handle bytes} {
- set instring [encoding convertfrom $o_enc $bytes]
+ set instring [tcl::encoding::convertfrom $o_enc $bytes]
+ set streaminfo [my Trackcodes $instring]
+ set emit [dict get $streaminfo emit]
+
+ #review - wrapping already done in Trackcodes
+ #if {[dict get $streaminfo stacksize] == 0} {
+ # #no ansi on the stack - we can wrap
+ # #review
+ # set outstring "$o_do_colour$emit$o_do_normal"
+ #} else {
+ #}
+ #if {[llength $o_codestack]} {
+ # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit
+ #} else {
+ # set outstring $emit
+ #}
+
+ set outstring $emit
+
+ #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<"
+ #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<"
+ return [tcl::encoding::convertto $o_enc $outstring]
+ }
+ method Write_naive {transform_handle bytes} {
+ set instring [tcl::encoding::convertfrom $o_enc $bytes]
set outstring "$o_do_colour$instring$o_do_normal"
#set outstring ">>>$instring"
- return [encoding convertto $o_enc $outstring]
+ return [tcl::encoding::convertto $o_enc $outstring]
+ }
+ method drain {transform_handle} {
+ return ""
+ }
+ method read {transform_handle bytes} {
+ set instring [tcl::encoding::convertfrom $o_enc $bytes]
+ set outstring "$o_do_colour$instring$o_do_normal"
+ return [tcl::encoding::convertto $o_enc $outstring]
}
method meta_is_redirection {} {
return $o_is_junction
@@ -868,7 +1052,7 @@ namespace eval shellfilter::chan {
set instring "\r$instring"
}
- set outstring [string map [list \r\n \n] $instring]
+ set outstring [string map {\r\n \n} $instring]
set lastchar [string range $outstring end end]
if {$lastchar eq "\r"} {
set o_last_char_was_cr 1
@@ -929,9 +1113,9 @@ namespace eval shellfilter::chan {
set instring "\r$instring"
}
- set outstring [string map [list \r\n \uFFFF] $instring]
- set outstring [string map [list \n \r\n] $outstring]
- set outstring [string map [list \uFFFF \r\n] $outstring]
+ set outstring [string map {\r\n \uFFFF} $instring]
+ set outstring [string map {\n \r\n} $outstring]
+ set outstring [string map {\uFFFF \r\n} $outstring]
set lastchar [string range $outstring end end]
if {$lastchar eq "\r"} {
@@ -995,7 +1179,9 @@ namespace eval shellfilter::chan {
## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept.
##
namespace eval shellfilter::stack {
- #todo - implement as oo
+ namespace export {[a-z]*}
+ namespace ensemble create
+ #todo - implement as oo ?
variable pipelines [list]
proc items {} {
@@ -1004,18 +1190,79 @@ namespace eval shellfilter::stack {
variable pipelines
return [dict keys $pipelines]
}
-
+ proc item {pipename} {
+ variable pipelines
+ return [dict get $pipelines $pipename]
+ }
+ proc item_tophandle {pipename} {
+ variable pipelines
+ set handle ""
+ if {[dict exists $pipelines $pipename stack]} {
+ set stack [dict get $pipelines $pipename stack]
+ set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans?
+ if {$topstack ne ""} {
+ if {[dict exists $topstack -handle]} {
+ set handle [dict get $topstack -handle]
+ }
+ }
+ }
+ return $handle
+ }
proc status {{pipename *} args} {
variable pipelines
+ set pipecount [dict size $pipelines]
+ set tabletitle "$pipecount pipelines active"
+ set t [textblock::class::table new $tabletitle]
+ $t add_column -headers [list channel-ident]
+ $t add_column -headers [list device-info localchan]
+ $t configure_column 1 -header_colspans {3}
+ $t add_column -headers [list "" remotechan]
+ $t add_column -headers [list "" tid]
+ $t add_column -headers [list stack-info]
+ foreach k [dict keys $pipelines $pipename] {
+ set lc [dict get $pipelines $k device localchan]
+ set rc [dict get $pipelines $k device remotechan]
+ if {[dict exists $k device workertid]} {
+ set tid [dict get $pipelines $k device workertid]
+ } else {
+ set tid "-"
+ }
+ set stack [dict get $pipelines $k stack]
+ if {![llength $stack]} {
+ set stackinfo ""
+ } else {
+ set tbl_inner [textblock::class::table new]
+ $tbl_inner configure -show_edge 0
+ foreach rec $stack {
+ set handle [punk::lib::dict_getdef $rec -handle ""]
+ set id [punk::lib::dict_getdef $rec -id ""]
+ set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]]
+ set settings [punk::lib::dict_getdef $rec -settings ""]
+ $tbl_inner add_row [list $id $transform $handle $settings]
+ }
+ set stackinfo [$tbl_inner print]
+ $tbl_inner destroy
+ }
+ $t add_row [list $k $lc $rc $tid $stackinfo]
+ }
+ set result [$t print]
+ $t destroy
+ return $result
+ }
+ proc status1 {{pipename *} args} {
+ variable pipelines
set pipecount [dict size $pipelines]
set tableprefix "$pipecount pipelines active\n"
+ foreach p [dict keys $pipelines] {
+ append tableprefix " " $p \n
+ }
package require overtype
#todo -verbose
set table ""
set ac1 [string repeat " " 15]
- set ac2 [string repeat " " 32]
- set ac3 [string repeat " " 80]
+ set ac2 [string repeat " " 42]
+ set ac3 [string repeat " " 70]
append table "[overtype::left $ac1 channel-ident] "
append table "[overtype::left $ac2 device-info] "
append table "[overtype::left $ac3 stack-info]"
@@ -1028,10 +1275,15 @@ namespace eval shellfilter::stack {
foreach k [dict keys $pipelines $pipename] {
set lc [dict get $pipelines $k device localchan]
+ if {[dict exists $k device workertid]} {
+ set tid [dict get $pipelines $k device workertid]
+ } else {
+ set tid ""
+ }
set col1 [overtype::left $ac1 $k]
- set col2 [overtype::left $ac2 "localchan: $lc"]
+ set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"]
set stack [dict get $pipelines $k stack]
if {![llength $stack]} {
@@ -1070,10 +1322,13 @@ namespace eval shellfilter::stack {
proc _get_stack_floaters {stack} {
set floaters [list]
foreach t [lreverse $stack] {
- if {[dict get $t -action] eq "float"} {
- lappend floaters $t
- } else {
- break
+ switch -- [dict get $t -action] {
+ float {
+ lappend floaters $t
+ }
+ default {
+ break
+ }
}
}
return [lreverse $floaters]
@@ -1148,15 +1403,25 @@ namespace eval shellfilter::stack {
dict set pipelines $pipename [list]
}
#todo
- proc delete {pipename} {
- set pipeinfo [dict get $pipename]
+ proc delete {pipename {wait 0}} {
+ variable pipelines
+ set pipeinfo [dict get $pipelines $pipename]
set deviceinfo [dict get $pipeinfo device]
set localchan [dict get $deviceinfo localchan]
unwind $pipename
+ #release associated thread
+ set tid [dict get $deviceinfo workertid]
+ if {$wait} {
+ thread::release -wait $tid
+ } else {
+ thread::release $tid
+ }
- chan close $localchan
+ #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why?
+ catch {chan close $localchan}
}
+ #review - proc name clarity is questionable. remove_stackitem?
proc remove {pipename remove_id} {
variable pipelines
if {![dict exists $pipelines $pipename]} {
@@ -1230,8 +1495,8 @@ namespace eval shellfilter::stack {
}
dict set pipelines $pipename stack $stack
}
- show_pipeline $pipename -note "after_remove $remove_id"
-
+ #JMNJMN 2025 review!
+ #show_pipeline $pipename -note "after_remove $remove_id"
return 1
}
@@ -1304,8 +1569,12 @@ namespace eval shellfilter::stack {
#we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack
proc add {pipename transformname args} {
variable pipelines
- if {($pipename ni [chan names]) && ($pipename ni [dict keys $pipelines])} {
- error "shellfilter::stack::add no existing chan or pipename matching '$pipename' use stdin/stderr/stdout or shellfilter::stack::new "
+ #chan names doesn't reflect available channels when transforms are in place
+ #e.g stdout may exist but show as something like file191f5b0dd80
+ if {($pipename ni [dict keys $pipelines])} {
+ if {[catch {eof $pipename} is_eof]} {
+ error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new "
+ }
}
set args [dict merge {-action "" -settings {}} $args]
set action [dict get $args -action]
@@ -1336,95 +1605,105 @@ namespace eval shellfilter::stack {
# but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?)
# jn
set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args]
-
- if {$action in [list "float" "float-locked"]} {
- set obj [$transformname new $transform_record]
- set h [chan push $localchan $obj]
- dict set transform_record -handle $h
- dict set transform_record -obj $obj
- lappend stack $transform_record
- } elseif {$action in [list "locked" ""]} {
- set floaters [_get_stack_floaters $stack]
- if {![llength $floaters]} {
+ switch -glob -- $action {
+ float - float-locked {
set obj [$transformname new $transform_record]
set h [chan push $localchan $obj]
dict set transform_record -handle $h
dict set transform_record -obj $obj
lappend stack $transform_record
- } else {
- set poplist $floaters
- set stack [insert_transform $pipename $stack $transform_record $poplist]
- }
- } elseif {[string match sink* $action]} {
- set redirinfo [_get_stack_top_redirection $stack]
- set idx_existing_redir [dict get $redirinfo index]
- if {$idx_existing_redir == -1} {
- #no existing redirection transform on the stack
- #pop everything.. add this record as the first redirection on the stack
- set poplist $stack
- set stack [insert_transform $pipename $stack $transform_record $poplist]
- } else {
- if {$action eq "sink-replace"} {
- #include that index in the poplist
- set poplist [lrange $stack $idx_existing_redir end]
- #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end'
- set stack [insert_transform $pipename $stack $transform_record $poplist 1]
- } elseif {[string match "sink-aside*" $action]} {
- set existing_redir_record [lindex $stack $idx_existing_redir]
- if {[string match "*locked*" [dict get $existing_redir_record -action]]} {
- set put_aside 0
- #we can't aside this one - sit above it instead.
- set poplist [lrange $stack $idx_existing_redir+1 end]
- set stack [lrange $stack 0 $idx_existing_redir]
- } else {
- set put_aside 1
- dict set transform_record -aside [lindex $stack $idx_existing_redir]
- set poplist [lrange $stack $idx_existing_redir end]
- set stack [lrange $stack 0 $idx_existing_redir-1]
- }
- foreach p $poplist {
- chan pop $localchan
- }
- set transformname [dict get $transform_record -transform]
- set transform_settings [dict get $transform_record -settings]
+ }
+ "" - locked {
+ set floaters [_get_stack_floaters $stack]
+ if {![llength $floaters]} {
set obj [$transformname new $transform_record]
- set h [chan push $localchan $obj]
+ set h [chan push $localchan $obj]
dict set transform_record -handle $h
dict set transform_record -obj $obj
- dict set transform_record -note "insert_transform-with-aside"
lappend stack $transform_record
- #add back poplist *except* the one we transferred into -aside (if we were able)
- foreach p [lrange $poplist $put_aside end] {
- set t [dict get $p -transform]
- set tsettings [dict get $p -settings]
- set obj [$t new $p]
- set h [chan push $localchan $obj]
- #retain previous -id - code that added it may have kept reference and not expecting it to change
- dict set p -handle $h
- dict set p -obj $obj
- dict set p -note "re-added-after-sink-aside"
- lappend stack $p
- }
} else {
- #plain "sink"
- #we only sink to the topmost redirecting filter - which makes sense for an output channel
- #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection.
- #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there.
- # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive.
- # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour
- set poplist [lrange $stack $idx_existing_redir+1 end]
+ set poplist $floaters
set stack [insert_transform $pipename $stack $transform_record $poplist]
}
}
- } else {
- error "shellfilter::stack::add unimplemented action '$action'"
+ "sink*" {
+ set redirinfo [_get_stack_top_redirection $stack]
+ set idx_existing_redir [dict get $redirinfo index]
+ if {$idx_existing_redir == -1} {
+ #no existing redirection transform on the stack
+ #pop everything.. add this record as the first redirection on the stack
+ set poplist $stack
+ set stack [insert_transform $pipename $stack $transform_record $poplist]
+ } else {
+ switch -glob -- $action {
+ "sink-replace" {
+ #include that index in the poplist
+ set poplist [lrange $stack $idx_existing_redir end]
+ #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end'
+ set stack [insert_transform $pipename $stack $transform_record $poplist 1]
+ }
+ "sink-aside*" {
+ set existing_redir_record [lindex $stack $idx_existing_redir]
+ if {[string match "*locked*" [dict get $existing_redir_record -action]]} {
+ set put_aside 0
+ #we can't aside this one - sit above it instead.
+ set poplist [lrange $stack $idx_existing_redir+1 end]
+ set stack [lrange $stack 0 $idx_existing_redir]
+ } else {
+ set put_aside 1
+ dict set transform_record -aside [lindex $stack $idx_existing_redir]
+ set poplist [lrange $stack $idx_existing_redir end]
+ set stack [lrange $stack 0 $idx_existing_redir-1]
+ }
+ foreach p $poplist {
+ chan pop $localchan
+ }
+ set transformname [dict get $transform_record -transform]
+ set transform_settings [dict get $transform_record -settings]
+ set obj [$transformname new $transform_record]
+ set h [chan push $localchan $obj]
+ dict set transform_record -handle $h
+ dict set transform_record -obj $obj
+ dict set transform_record -note "insert_transform-with-aside"
+ lappend stack $transform_record
+ #add back poplist *except* the one we transferred into -aside (if we were able)
+ foreach p [lrange $poplist $put_aside end] {
+ set t [dict get $p -transform]
+ set tsettings [dict get $p -settings]
+ set obj [$t new $p]
+ set h [chan push $localchan $obj]
+ #retain previous -id - code that added it may have kept reference and not expecting it to change
+ dict set p -handle $h
+ dict set p -obj $obj
+ dict set p -note "re-added-after-sink-aside"
+ lappend stack $p
+ }
+ }
+ default {
+ #plain "sink"
+ #we only sink to the topmost redirecting filter - which makes sense for an output channel
+ #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection.
+ #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there.
+ # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive.
+ # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour
+ set poplist [lrange $stack $idx_existing_redir+1 end]
+ set stack [insert_transform $pipename $stack $transform_record $poplist]
+ }
+ }
+ }
+ }
+ default {
+ error "shellfilter::stack::add unimplemented action '$action'"
+ }
}
dict set pipelines $pipename stack $stack
#puts stdout "=="
#puts stdout "==>stack: $stack"
#puts stdout "=="
- show_pipeline $pipename -note "after_add $transformname $args"
+
+ #JMNJMN
+ #show_pipeline $pipename -note "after_add $transformname $args"
return $id
}
proc show_pipeline {pipename args} {
@@ -1433,7 +1712,13 @@ namespace eval shellfilter::stack {
set tag "SHELLFILTER::STACK"
#JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514}
- ::shellfilter::log::open $tag {-syslog ""}
+ if {[catch {
+ ::shellfilter::log::open $tag {-syslog ""}
+ } err]} {
+ #e.g safebase interp can't load required modules such as shellthread (or Thread)
+ puts stderr "shellfilter::show_pipeline cannot open log"
+ return
+ }
::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack {
::shellfilter::log::write $tag " $tf"
@@ -1504,6 +1789,14 @@ namespace eval shellfilter {
return [list $idout $iderr]
}
+ #eg try: set v [list #a b c]
+ #vs set v {#a b c}
+ proc list_is_canonical l {
+ #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl
+ if {[catch {llength $l}]} {return 0}
+ string equal $l [list {*}$l]
+ }
+
#return a dict keyed on numerical list index showing info about each element
# - particularly
# 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list
@@ -1566,6 +1859,7 @@ namespace eval shellfilter {
if {$itemlen <= 1} {
dict set iteminfo apparentwrap "not"
} else {
+ #todo - switch on $char_a$char_z
if {($char_a eq {"}) && ($char_z eq {"})} {
dict set iteminfo apparentwrap "doublequotes"
} elseif {($char_a eq "'") && ($char_z eq "'")} {
@@ -1743,17 +2037,21 @@ namespace eval shellfilter {
}
} else {
#currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active.
- if {$char eq "("} {
- incr word_bdepth
- lappend word_bstack $char
- append word $char
- } elseif {$char eq ")"} {
- incr word_bdepth -1
- set word_bstack [lrange $word_bstack 0 end-1]
- append word $char
- } else {
- #spaces and chars added to word as it's still in a bracketed section
- append word $char
+ switch -- $char {
+ "(" {
+ incr word_bdepth
+ lappend word_bstack $char
+ append word $char
+ }
+ ")" {
+ incr word_bdepth -1
+ set word_bstack [lrange $word_bstack 0 end-1]
+ append word $char
+ }
+ default {
+ #spaces and chars added to word as it's still in a bracketed section
+ append word $char
+ }
}
}
}
@@ -1838,14 +2136,18 @@ namespace eval shellfilter {
}
}
} else {
- if {$char eq "("} {
- incr word_bdepth
- append word $char
- } elseif {$char eq ")"} {
- incr word_bdepth -1
- append word $char
- } else {
- append word $char
+ switch -- $char {
+ "(" {
+ incr word_bdepth
+ append word $char
+ }
+ ")" {
+ incr word_bdepth -1
+ append word $char
+ }
+ default {
+ append word $char
+ }
}
}
}
@@ -1886,13 +2188,15 @@ namespace eval shellfilter {
#only double quote if argument not quoted with single or double quotes
proc dquote_if_not_quoted {a} {
- if {([string range $a 0 0] eq {"}) && ([string range $a end end] eq {"})} {
- return $a
- } elseif {([string range $a 0 0] eq {'}) && ([string range $a end end] eq {'})} {
- return $a
- } else {
- set newinner [string map [list {"} "\\\""] $a]
- return "\"$newinner\""
+ set wrapchars [string cat [string range $a 0 0] [string range $a end end]]
+ switch -- $wrapchars {
+ {""} - {''} {
+ return $a
+ }
+ default {
+ set newinner [string map [list {"} "\\\""] $a]
+ return "\"$newinner\""
+ }
}
}
@@ -1900,12 +2204,16 @@ namespace eval shellfilter {
#wrap in double quotes if not double-quoted
proc dquote_if_not_dquoted {a} {
- if {([string range $a 0 0] eq {"}) && ([string range $a end end] eq {"})} {
- return $a
- } else {
- #escape any inner quotes..
- set newinner [string map [list {"} "\\\""] $a]
- return "\"$newinner\""
+ set wrapchars [string cat [string range $a 0 0] [string range $a end end]]
+ switch -- $wrapchars {
+ {""} {
+ return $a
+ }
+ default {
+ #escape any inner quotes..
+ set newinner [string map [list {"} "\\\""] $a]
+ return "\"$newinner\""
+ }
}
}
proc dquote {a} {
@@ -1966,7 +2274,10 @@ namespace eval shellfilter {
set runtag "shellfilter-run"
#set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]]
set tid [::shellfilter::log::open $runtag [list -syslog ""]]
- ::shellfilter::log::write $runtag " commandlist:'$commandlist' len:[llength $commandlist]"
+ if {[catch {llength $commandlist} listlen]} {
+ set listlen ""
+ }
+ ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]"
#flush stdout
#flush stderr
@@ -2036,7 +2347,7 @@ namespace eval shellfilter {
#
if {!$is_script} {
set experiment 0
- if $experiment {
+ if {$experiment} {
try {
set results [exec {*}$commandlist]
set exitinfo [list exitcode 0]
@@ -2087,8 +2398,14 @@ namespace eval shellfilter {
set worker_errorlist [list]
set tidied_sources [list]
set tidytag "logtidy"
- set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}]
- ::shellfilter::log::write $tidytag " logtidyuptags '$tags'"
+
+
+ # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea.
+ # we should ensure the thread already exists early on if we really need logging here.
+ #
+ #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}]
+ #::shellfilter::log::write $tidytag " logtidyuptags '$tags'"
+
foreach s $sources {
if {$s eq $tidytag} {
continue
@@ -2112,7 +2429,10 @@ namespace eval shellfilter {
lappend remaining_sources $s
}
}
- set sources [concat $remaining_sources $tidytag]
+
+ #set sources [concat $remaining_sources $tidytag]
+ set sources $remaining_sources
+
#shellfilter::stack::unwind stdout
#shellfilter::stack::unwind stderr
return [list tidied $tidied_sources errors $worker_errorlist]
@@ -2145,13 +2465,31 @@ namespace eval shellfilter {
#set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]]
set tid [::shellfilter::log::open $runtag [list -syslog ""]]
- if {([llength $args] % 2) != 0} {
+ if {[llength $args] % 2} {
error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'"
}
set invalid_flags [list]
- foreach k [dict keys $args] {
- if {$k ni $valid_flags} {
- lappend invalid_flags $k
+ foreach {k -} $args {
+ switch -- $k {
+ -timeout -
+ -outprefix -
+ -errprefix -
+ -debug -
+ -copytempfile -
+ -outbuffering -
+ -errbuffering -
+ -inbuffering -
+ -readprocesstranslation -
+ -outtranslation -
+ -stdinhandler -
+ -outchan -
+ -errchan -
+ -inchan -
+ -teehandle {
+ }
+ default {
+ lappend invalid_flags $k
+ }
}
}
if {[llength $invalid_flags]} {
@@ -2201,7 +2539,7 @@ namespace eval shellfilter {
#'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp.
# a simple counter would probably work too
#consider other options if an alternative to the single vwait in this function is used.
- set call_id [clock micros] ;
+ set call_id [tcl::clock::microseconds] ;
set ::shellfilter::shellcommandvars($call_id,exitcode) ""
set waitvar ::shellfilter::shellcommandvars($call_id,waitvar)
if {$debug} {
@@ -2210,36 +2548,39 @@ namespace eval shellfilter {
lassign [chan pipe] rderr wrerr
chan configure $wrerr -blocking 0
+ set custom_stderr ""
set lastitem [lindex $commandlist end]
#todo - ensure we can handle 2> file (space after >)
- if {[string trim [lindex $commandlist end]] eq "&"} {
- set name [lindex $commandlist 0]
- #background execution - stdout and stderr from child still comes here - but process is backgrounded
- #FIX! - this is broken for paths with backslashes for example
- #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]]
- set pidlist [exec {*}$commandlist]
- return [list pids $pidlist]
- }
-
#review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes!
#
#note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere
#(2>@stdout echoes to main stdout - not into pipeline)
#To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads)
- set custom_stderr ""
- if {[string trim $lastitem] in [list {2>&1} {2>@1}]} {
- set custom_stderr {2>@1} ;#use the tcl style
- set commandlist [lrange $commandlist 0 end-1]
- } else {
- # 2> filename
- # 2>> filename
- # 2>@ openfileid
- set redir2test [string range $lastitem 0 1]
- if {$redir2test eq "2>"} {
- set custom_stderr $lastitem
+
+ switch -- [string trim $lastitem] {
+ {&} {
+ set name [lindex $commandlist 0]
+ #background execution - stdout and stderr from child still comes here - but process is backgrounded
+ #FIX! - this is broken for paths with backslashes for example
+ #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]]
+ set pidlist [exec {*}$commandlist]
+ return [list pids $pidlist]
+ }
+ {2>&1} - {2>@1} {
+ set custom_stderr {2>@1} ;#use the tcl style
set commandlist [lrange $commandlist 0 end-1]
}
+ default {
+ # 2> filename
+ # 2>> filename
+ # 2>@ openfileid
+ set redir2test [string range $lastitem 0 1]
+ if {$redir2test eq "2>"} {
+ set custom_stderr $lastitem
+ set commandlist [lrange $commandlist 0 end-1]
+ }
+ }
}
set lastitem [lindex $commandlist end]
@@ -2252,12 +2593,14 @@ namespace eval shellfilter {
::shellfilter::log::write $runtag "checking for redirections in $commandlist"
#sometimes we see a redirection without a following space e.g >C:/somewhere
#normalize
- if {[regexp {^>[/[:alpha:]]+} $lastitem]} {
- set lastitem "> [string range $lastitem 1 end]"
- }
- if {[regexp {^>>[/[:alpha:]]+} $lastitem]} {
- set lastitem ">> [string range $lastitem 2 end]"
- }
+ switch -regexp -- $lastitem\
+ {^>[/[:alpha:]]+} {
+ set lastitem "> [string range $lastitem 1 end]"
+ }\
+ {^>>[/[:alpha:]]+} {
+ set lastitem ">> [string range $lastitem 2 end]"
+ }
+
#for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}}
#or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces}
@@ -2313,51 +2656,53 @@ namespace eval shellfilter {
}
set commandlist [lrange $commandlist 0 end-1]
- } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} {
- #unwrapped redirection
- #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list
- set redir [lindex $commandlist end-1]
- set redirtarget [lindex $commandlist end]
- set commandlist [lrange $commandlist 0 end-2]
- } else {
- #no redirection
- set redir ""
- set redirtarget ""
- #no change to command list
- }
+ } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} {
+ #unwrapped redirection
+ #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list
+ set redir [lindex $commandlist end-1]
+ set redirtarget [lindex $commandlist end]
+ set commandlist [lrange $commandlist 0 end-2]
+ } else {
+ #no redirection
+ set redir ""
+ set redirtarget ""
+ #no change to command list
+ }
+ switch -- $redir {
+ ">>" - ">" {
+ set redirtarget [string trim $redirtarget "\""]
+ ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'"
- if {$redir in [list ">>" ">"]} {
- set redirtarget [string trim $redirtarget "\""]
- ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'"
-
-
- set winfile $redirtarget ;#default assumption
- if {[string match "/c/*" $redirtarget]} {
- set winfile "c:/[string range $redirtarget 3 end]"
- }
- if {[string match "/mnt/c/*" $redirtarget]} {
- set winfile "c:/[string range $redirtarget 7 end]"
- }
+ set winfile $redirtarget ;#default assumption
+ switch -glob -- $redirtarget {
+ "/c/*" {
+ set winfile "c:/[string range $redirtarget 3 end]"
+ }
+ "/mnt/c/*" {
+ set winfile "c:/[string range $redirtarget 7 end]"
+ }
+ }
- if {[file exists [file dirname $winfile]]} {
- #containing folder for target exists
- if {$redir eq ">"} {
- set teefile "write"
- } else {
- set teefile "append"
+ if {[file exists [file dirname $winfile]]} {
+ #containing folder for target exists
+ if {$redir eq ">"} {
+ set teefile "write"
+ } else {
+ set teefile "append"
+ }
+ ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile"
+ } else {
+ #we should be writing to a file.. but can't
+ ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'"
+ }
}
- ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile"
-
- } else {
- #we should be writing to a file.. but can't
- ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'"
+ default {
+ ::shellfilter::log::write $runtag "No redir found!!"
+ }
+ }
- }
- } else {
- ::shellfilter::log::write $runtag "No redir found!!"
- }
#often first element of command list is wrapped and cannot be run directly
#e.g {{ls -l} {> {temp.tmp}}}
#we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped.
@@ -2484,11 +2829,11 @@ namespace eval shellfilter {
#} else {
# puts stderr "stderr reader: pid [lindex $pids 0] still running"
#}
- chan close $chan
- #catch {chan close $wrerr}
- if {$other ni [chan names]} {
- set $waitfor stderr
- }
+ chan close $chan
+ #catch {chan close $wrerr}
+ if {$other ni [chan names]} {
+ set $waitfor stderr
+ }
}
}} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids]
}
@@ -2505,7 +2850,7 @@ namespace eval shellfilter {
# - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read.
# Not known if that is significant
## with inchan configured -buffering line
- #c:\repo\jn\shellspy\test>printf "test\netc\n" | tclsh shellspy.vfs/main.tcl -r cat
+ #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat
#warning reading input with -buffering line. Cannot detect missing trailing-newline at eof
#instate b:0 eof:0 pend:-1 count:4
#test
@@ -2513,7 +2858,7 @@ namespace eval shellfilter {
#etc
#instate b:0 eof:1 pend:-1 count:-1
- #c:\repo\jn\shellspy\test>printf "test\netc" | tclsh shellspy.vfs/main.tcl -r cat
+ #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat
#warning reading input with -buffering line. Cannot detect missing trailing-newline at eof
#instate b:0 eof:0 pend:-1 count:4
#test
@@ -2562,7 +2907,7 @@ namespace eval shellfilter {
if {[string length $teefile]} {
- set logname "redir_[string map [list : _ ] $winfile]_[clock micros]"
+ set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]"
set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}]
if {$teefile eq "write"} {
::shellfilter::log::write $logname "opening '$winfile' for write"
@@ -2575,7 +2920,7 @@ namespace eval shellfilter {
chan configure $fd -translation $outtranslation
chan configure $fd -encoding utf-8
- set tempvar_bytetotal [namespace current]::totalbytes[clock micros]
+ set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds]
set $tempvar_bytetotal 0
chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} {
#review - if we write outprefix to normal stdout.. why not to redirected file?
@@ -2647,14 +2992,14 @@ namespace eval shellfilter {
##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none
## then we can detect the difference
# there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on.
- #c:\repo\jn\shellspy\test>printf "test\netc\n" | tclsh shellspy.vfs/main.tcl /c cat
+ #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat
#instate b:0 eof:0 pend:-1 count:4
#test
#instate b:0 eof:0 pend:-1 count:3
#etc
#instate b:0 eof:1 pend:-1 count:-1
- #c:\repo\jn\shellspy\test>printf "test\netc" | tclsh shellspy.vfs/main.tcl /u/c cat
+ #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat
#instate b:0 eof:0 pend:-1 count:4
#test
#instate b:1 eof:0 pend:-1 count:-1
@@ -2665,7 +3010,7 @@ namespace eval shellfilter {
#this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly..
###reading with gets from line buffered input with trailing newline
- #c:\repo\jn\shellspy\test>printf "test\netc\n" | tclsh shellspy.vfs/main.tcl /c cat
+ #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat
#instate b:0 eof:0 pend:-1 count:4
#test
#instate b:0 eof:0 pend:-1 count:3
@@ -2674,7 +3019,7 @@ namespace eval shellfilter {
###reading with gets from line buffered input with trailing newline
##No detectable difference!
- #c:\repo\jn\shellspy\test>printf "test\netc" | tclsh shellspy.vfs/main.tcl /c cat
+ #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat
#instate b:0 eof:0 pend:-1 count:4
#test
#instate b:0 eof:0 pend:-1 count:3
@@ -2705,7 +3050,7 @@ namespace eval shellfilter {
#} else {
# #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior
# #Not known if this occurs
- # #debugging output inline with data - don't leave enabled
+ # #debugging output inline with data - don't leave enabled
# puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk"
#}
}
@@ -2747,15 +3092,17 @@ namespace eval shellfilter {
}
} trap CHILDSTATUS {result options} {
set code [lindex [dict get $options -errorcode] 2]
+ set ::shellfilter::shellcommandvars($call_id,exitcode) $code
if {$debug} {
::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code"
}
- set ::shellfilter::shellcommandvars($call_id,exitcode) $code
} trap CHILDKILLED {result options} {
#set code [lindex [dict get $options -errorcode] 2]
#set ::shellfilter::shellcommandvars(%id%,exitcode) $code
set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled"
- ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'"
+ if {$debug} {
+ ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'"
+ }
} finally {
#puts stdout "HERE"
@@ -2774,7 +3121,7 @@ namespace eval shellfilter {
#todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data
#e.g x hrs with no data(?)
#reset timeout when data detected.
- after $timeout [string map [list %w $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] {
+ after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] {
if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} {
if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} {
catch { chan close %wrerr% }
@@ -2798,7 +3145,8 @@ namespace eval shellfilter {
set code [lindex [dict get $options -errorcode] 2]
#set code [dict get $options -code]
#set ::shellfilter::shellcommandvars(%id%,exitcode) $code
- set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout"
+ #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout"
+ set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout"
if {%debug%} {
::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code"
::shellfilter::log::write %debugname% "(timeout) result:$result options:$options"
@@ -2807,9 +3155,8 @@ namespace eval shellfilter {
}
catch { chan close %wrerr% }
catch { chan close %rderr%}
-
}
- set %w "timeout"
+ set %w% "timeout"
}
}]
@@ -2858,5 +3205,5 @@ namespace eval shellfilter {
package provide shellfilter [namespace eval shellfilter {
variable version
- set version 0.1.8
+ set version 0.1.9
}]
diff --git a/src/bootsupport/modules/test/tomlish-1.1.1.tm b/src/bootsupport/modules/test/tomlish-1.1.1.tm
new file mode 100644
index 00000000..d365bab1
Binary files /dev/null and b/src/bootsupport/modules/test/tomlish-1.1.1.tm differ
diff --git a/src/bootsupport/modules/test/tomlish-1.1.3.tm b/src/bootsupport/modules/test/tomlish-1.1.3.tm
new file mode 100644
index 00000000..8afb43d9
Binary files /dev/null and b/src/bootsupport/modules/test/tomlish-1.1.3.tm differ
diff --git a/src/bootsupport/modules/tomlish-1.1.6.tm b/src/bootsupport/modules/tomlish-1.1.6.tm
index d7d1f131..af632c36 100644
--- a/src/bootsupport/modules/tomlish-1.1.6.tm
+++ b/src/bootsupport/modules/tomlish-1.1.6.tm
@@ -8542,6 +8542,7 @@ namespace eval tomlish::path {
}
}
+
namespace eval tomlish::dict::path {
#access tomlish dict structure
@@ -8549,11 +8550,12 @@ namespace eval tomlish::dict::path {
#access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value }
#leaf elements returned as structured {type value }
- proc get {dictval {path {}}} {
+
+ proc get {dictval {path {} } } {
if {$path eq ""} {
return $dictval
}
- if {[string index $path 0] in [list . "\["]} {
+ if {[string index $path 0] in [list . "\[" ] } {
set path [tomlish::utils::jq_to_path $path]
}
@@ -8562,7 +8564,7 @@ namespace eval tomlish::dict::path {
::set i 0
foreach p $path {
::lappend pathsofar $p
- if {[string range $p 0 1] eq "@@"} {
+ if {[string range $p 0 1] eq "@@" } {
#dict key
::set data [dict get $data [string range $p 2 end]]
} else {
@@ -8592,9 +8594,10 @@ namespace eval tomlish::dict::path {
return $data
}
+
proc exists {dictval path} {
#completely empty path considered to exist - review
- if {[string index $path 0] in [list . {[}]} {
+ if {[string index $path 0] in [list . "\[" ] } {
set path [tomlish::utils::jq_to_path $path]
}
::set data $dictval
@@ -8668,7 +8671,7 @@ namespace eval tomlish::dict::path {
BOOL {
#toml only accepts lower case true and false
#review
- if {$rawval ni {true false}} {
+ if {$rawval ni {true false} } {
return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml boolean (true|false): '$rawval'"
}
}
@@ -8737,9 +8740,21 @@ namespace eval tomlish::dict::path {
# can replace an existing {type value value }
# with added restriction that if is ARRAY the new must also be ARRAY
+
+ # vscode tcl syntax highlighter is unable to handle (in some cases!) some simple constructs like left square bracket in curly braces,
+ # yet it is ok in comments. i.e {[} is prolematic for the highlighter, so we use "\[" instead :/
+ #e.g ------------------------------------------------
+ # if {[string index $path 0] in [list . {[}] } {
+ # # ...
+ # }
+ # ------------------------------------------------
+ #This may highlight ok - and even text immediately following can be ok - but
+ # the subsequent code block at global scope, perhaps *many* lines distant from where the syntax highlighting issue started, may then be completely miscoloured
+ # This is a big timewaster - a decent syntax highlighter is really needed for Tcl in vscode (2025-09)
+
package require struct::list
proc setleaf {dictvariable path value {validate 1}} {
- if {[string index $path 0] in [list . {[}]} {
+ if {[string index $path 0] in [list . "\[" ] } {
set path [tomlish::utils::jq_to_path $path]
}
@@ -8764,9 +8779,9 @@ namespace eval tomlish::dict::path {
if {[string range $p 0 1] eq "@@"} {
::set k [string range $p 2 end]
- #if {![dict exists $data $k]} {
- # error "tomlish::dict:path::set error bad path $path. Attempt to access nonexistent element at subpath $pathsofar."
- #}
+ # if {![dict exists $data $k]} {
+ # error "tomlish::dict:path::set error bad path $path. Attempt to access nonexistent element at subpath $pathsofar."
+ # }
::set varname v[incr v]
if {[struct::list equal $pathsofar $path]} {
@@ -8866,6 +8881,7 @@ namespace eval tomlish::dict::path {
# puts " '[::set $varname]'\n"
# puts ""
#}
+
::set i 0
::set reverse [lreverse $vdict]
foreach {varname path} $reverse {
@@ -8899,7 +8915,7 @@ namespace eval tomlish::dict::path {
#path must be to a {type ARRAY value }
#REVIEW - how to lappend to deep mixed dict/array structure without rewriting whole datastructure?
proc lappend {dictvariable path args} {
- if {[string index $path 0] in [list . {[}]} {
+ if {[string index $path 0] in [list . "\[" ]} {
set path [tomlish::utils::jq_to_path $path]
}
upvar $dictvariable dict_being_edited
@@ -8985,12 +9001,12 @@ namespace eval tomlish::dict::path {
}
}
}
- #todo tomlish::log::debug ?
- #dict for {path varname} $vdict {
- # puts "$path $varname\n"
- # puts " [::set $varname]\n"
- # puts ""
- #}
+ # todo tomlish::log::debug ?
+ # dict for {path varname} $vdict {
+ # puts "$path $varname\n"
+ # puts " [::set $varname]\n"
+ # puts ""
+ # }
::set i 0
::set reverse [lreverse $vdict]
foreach {varname path} $reverse {
@@ -9020,8 +9036,8 @@ namespace eval tomlish::dict::path {
return $dict_being_edited
}
}
-tcl::namespace::eval tomlish::to_dict {
+tcl::namespace::eval tomlish::to_dict {
proc @@path {dictkeys} {
lmap v $dictkeys {string cat @@ $v}
@@ -9029,7 +9045,6 @@ tcl::namespace::eval tomlish::to_dict {
}
-
tcl::namespace::eval tomlish::app {
#*** !doctools
#[subsection {Namespace tomlish::app}]
@@ -9047,14 +9062,15 @@ tcl::namespace::eval tomlish::app {
package require punk::args
punk::args::define {
- @id -id ::tomlish::app::decoder
- @cmd -name tomlish::app::decoder -help\
+ @id -id ::tomlish::app::decode_to_typedjson
+ @cmd -name tomlish::app::decode_to_typedjson -help\
"Read toml on stdin until EOF
on error - returns non-zero exit code and writes error to
the errorchannel.
- on success - returns zero exit code and writes JSON encoding
+ on success - returns zero exit code and writes typed JSON encoding
of the data to the outputchannel.
- This decoder is intended to be compatble with toml-test."
+ This decoder is intended to be compatble with toml-test.
+ toml-test defines the typed JSON format."
@leaders -min 0 -max 0
@opts
-help -type none -help\
@@ -9067,14 +9083,14 @@ tcl::namespace::eval tomlish::app {
-errorchannel -default stderr
@values -min 0 -max 0
}
- proc decoder {args} {
- set argd [punk::args::parse $args withid ::tomlish::app::decoder]
+ proc decode_to_typedjson {args} {
+ set argd [punk::args::parse $args withid ::tomlish::app::decode_to_typedjson]
set ch_input [dict get $argd opts -inputchannel]
set ch_input_enc [dict get $argd opts -inputencoding]
set ch_output [dict get $argd opts -outputchannel]
set ch_error [dict get $argd opts -errorchannel]
if {[dict exists $argd received -help]} {
- return [punk::args::usage -scheme info ::tomlish::app::decoder]
+ return [punk::args::usage -scheme info ::tomlish::app::decode_to_typedjson]
}
chan configure $ch_input -encoding $ch_input_enc
@@ -9108,14 +9124,15 @@ tcl::namespace::eval tomlish::app {
package require punk::args
punk::args::define {
- @id -id ::tomlish::app::encoder
- @cmd -name tomlish::app::encoder -help\
- "Read JSON on input until EOF
+ @id -id ::tomlish::app::encode_from_typedjson
+ @cmd -name tomlish::app::encode_from_typedjson -help\
+ "Read typed JSON on input until EOF
return non-zero exitcode if JSON data cannot be converted to
a valid TOML representation.
return zero exitcode and TOML data on output if JSON data can
be converted.
- This encoder is intended to be compatible with toml-test."
+ This encoder is intended to be compatible with toml-test.
+ toml-test defines the typed JSON format."
@leaders -min 0 -max 0
@opts
-help -type none -help \
@@ -9132,15 +9149,15 @@ tcl::namespace::eval tomlish::app {
-errorchannel -default stderr
@values -min 0 -max 0
}
- proc encoder {args} {
- set argd [punk::args::parse $args withid ::tomlish::app::encoder]
+ proc encode_from_typedjson {args} {
+ set argd [punk::args::parse $args withid ::tomlish::app::encode_from_typedjson]
set restrict_barekeys [dict get $argd opts -restrict_barekeys]
set ch_input [dict get $argd opts -inputchannel]
set ch_input_enc [dict get $argd opts -inputencoding]
set ch_output [dict get $argd opts -outputchannel]
set ch_error [dict get $argd opts -errorchannel]
if {[dict exists $argd received -help]} {
- return [punk::args::usage -scheme info ::tomlish::app::encoder]
+ return [punk::args::usage -scheme info ::tomlish::app::encode_from_typedjson]
}
#review
if {$ch_input_enc ne ""} {
@@ -9171,7 +9188,8 @@ tcl::namespace::eval tomlish::app {
punk::args::define {
@dynamic
@id -id ::tomlish::app::test
- @cmd -name tomlish::app::test
+ @cmd -name tomlish::app::test -help\
+ "Run the internal tests on the tomlish library."
@leaders
@opts -any 1
-help -type none -help\
diff --git a/src/bootsupport/modules/uuid-1.0.7.tm b/src/bootsupport/modules/uuid-1.0.7.tm
new file mode 100644
index 00000000..fbd43f3d
--- /dev/null
+++ b/src/bootsupport/modules/uuid-1.0.7.tm
@@ -0,0 +1,245 @@
+# uuid.tcl - Copyright (C) 2004 Pat Thoyts
+#
+# UUIDs are 128 bit values that attempt to be unique in time and space.
+#
+# Reference:
+# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
+#
+# uuid: scheme:
+# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
+#
+# Usage: uuid::uuid generate
+# uuid::uuid equal $idA $idB
+
+package require Tcl 8.5
+
+namespace eval uuid {
+ variable accel
+ array set accel {critcl 0}
+
+ namespace export uuid
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 1
+ }
+
+ proc K {a b} {set a}
+}
+
+###
+# Optimization
+# Caches machine info after the first pass
+###
+
+proc ::uuid::generate_tcl_machinfo {} {
+ variable machinfo
+ if {[info exists machinfo]} {
+ return $machinfo
+ }
+ lappend machinfo [clock seconds]; # timestamp
+ lappend machinfo [clock clicks]; # system incrementing counter
+ lappend machinfo [info hostname]; # spatial unique id (poor)
+ lappend machinfo [pid]; # additional entropy
+ lappend machinfo [array get ::tcl_platform]
+
+ ###
+ # If we have /dev/urandom just stream 128 bits from that
+ ###
+ if {[file exists /dev/urandom]} {
+ set fin [open /dev/urandom r]
+ binary scan [read $fin 128] H* machinfo
+ close $fin
+ } elseif {[catch {package require nettool}]} {
+ # More spatial information -- better than hostname.
+ # bug 1150714: opening a server socket may raise a warning messagebox
+ # with WinXP firewall, using ipconfig will return all IP addresses
+ # including ipv6 ones if available. ipconfig is OK on win98+
+ if {[string equal $::tcl_platform(platform) "windows"]} {
+ catch {exec ipconfig} config
+ lappend machinfo $config
+ } else {
+ catch {
+ set s [socket -server void -myaddr [info hostname] 0]
+ K [fconfigure $s -sockname] [close $s]
+ } r
+ lappend machinfo $r
+ }
+
+ if {[package provide Tk] != {}} {
+ lappend machinfo [winfo pointerxy .]
+ lappend machinfo [winfo id .]
+ }
+ } else {
+ ###
+ # If the nettool package works on this platform
+ # use the stream of hardware ids from it
+ ###
+ lappend machinfo {*}[::nettool::hwid_list]
+ }
+ return $machinfo
+}
+
+# Generates a binary UUID as per the draft spec. We generate a pseudo-random
+# type uuid (type 4). See section 3.4
+#
+proc ::uuid::generate_tcl {} {
+ package require md5 2
+ variable uid
+
+ set tok [md5::MD5Init]
+ md5::MD5Update $tok [incr uid]; # package incrementing counter
+ foreach string [generate_tcl_machinfo] {
+ md5::MD5Update $tok $string
+ }
+ set r [md5::MD5Final $tok]
+ binary scan $r c* r
+
+ # 3.4: set uuid versioning fields
+ lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
+ lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
+
+ return [binary format c* $r]
+}
+
+if {[string equal $tcl_platform(platform) "windows"]
+ && [package provide critcl] != {}} {
+ namespace eval uuid {
+ critcl::ccode {
+ #define WIN32_LEAN_AND_MEAN
+ #define STRICT
+ #include
+ #include
+ typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
+ typedef const unsigned char cu_char;
+ }
+ critcl::cproc generate_c {Tcl_Interp* interp} ok {
+ HRESULT hr = S_OK;
+ int r = TCL_OK;
+ UUID uuid = {0};
+ HMODULE hLib;
+ LPFNUUIDCREATE lpfnUuidCreate = NULL;
+ hLib = LoadLibraryA(("rpcrt4.dll"));
+ if (hLib)
+ lpfnUuidCreate = (LPFNUUIDCREATE)
+ GetProcAddress(hLib, "UuidCreate");
+ if (lpfnUuidCreate) {
+ Tcl_Obj *obj;
+ lpfnUuidCreate(&uuid);
+ obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
+ Tcl_SetObjResult(interp, obj);
+ } else {
+ Tcl_SetResult(interp, "error: failed to create a guid",
+ TCL_STATIC);
+ r = TCL_ERROR;
+ }
+ return r;
+ }
+ }
+}
+
+# Convert a binary uuid into its string representation.
+#
+proc ::uuid::tostring {uuid} {
+ binary scan $uuid H* s
+ foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
+ append r [string range $s $a $b] -
+ }
+ return [string tolower [string trimright $r -]]
+}
+
+# Convert a string representation of a uuid into its binary format.
+#
+proc ::uuid::fromstring {uuid} {
+ return [binary format H* [string map {- {}} $uuid]]
+}
+
+# Compare two uuids for equality.
+#
+proc ::uuid::equal {left right} {
+ set l [fromstring $left]
+ set r [fromstring $right]
+ return [string equal $l $r]
+}
+
+# Call our generate uuid implementation
+proc ::uuid::generate {} {
+ variable accel
+ if {$accel(critcl)} {
+ return [generate_c]
+ } else {
+ return [generate_tcl]
+ }
+}
+
+# uuid generate -> string rep of a new uuid
+# uuid equal uuid1 uuid2
+#
+proc uuid::uuid {cmd args} {
+ switch -exact -- $cmd {
+ generate {
+ if {[llength $args] != 0} {
+ return -code error "wrong # args:\
+ should be \"uuid generate\""
+ }
+ return [tostring [generate]]
+ }
+ equal {
+ if {[llength $args] != 2} {
+ return -code error "wrong \# args:\
+ should be \"uuid equal uuid1 uuid2\""
+ }
+ return [eval [linsert $args 0 equal]]
+ }
+ default {
+ return -code error "bad option \"$cmd\":\
+ must be generate or equal"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::uuid::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]} {
+ set r [expr {[info commands ::uuid::generate_c] != {}}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::uuid {
+ variable e {}
+ foreach e {critcl} {
+ if {[LoadAccelerator $e]} break
+ }
+ unset e
+}
+
+package provide uuid 1.0.7
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/src/bootsupport/modules/uuid-1.0.8.tm b/src/bootsupport/modules/uuid-1.0.8.tm
new file mode 100644
index 00000000..c5cffa67
--- /dev/null
+++ b/src/bootsupport/modules/uuid-1.0.8.tm
@@ -0,0 +1,246 @@
+# uuid.tcl - Copyright (C) 2004 Pat Thoyts
+#
+# UUIDs are 128 bit values that attempt to be unique in time and space.
+#
+# Reference:
+# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
+#
+# uuid: scheme:
+# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
+#
+# Usage: uuid::uuid generate
+# uuid::uuid equal $idA $idB
+
+package require Tcl 8.5 9
+
+namespace eval uuid {
+ variable accel
+ array set accel {critcl 0}
+
+ namespace export uuid
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 1
+ }
+
+ proc K {a b} {set a}
+}
+
+###
+# Optimization
+# Caches machine info after the first pass
+###
+
+proc ::uuid::generate_tcl_machinfo {} {
+ variable machinfo
+ if {[info exists machinfo]} {
+ return $machinfo
+ }
+ lappend machinfo [clock seconds]; # timestamp
+ lappend machinfo [clock clicks]; # system incrementing counter
+ lappend machinfo [info hostname]; # spatial unique id (poor)
+ lappend machinfo [pid]; # additional entropy
+ lappend machinfo [array get ::tcl_platform]
+
+ ###
+ # If we have /dev/urandom just stream 128 bits from that
+ ###
+ if {[file exists /dev/urandom]} {
+ set fin [open /dev/urandom r]
+ fconfigure $fin -encoding binary
+ binary scan [read $fin 128] H* machinfo
+ close $fin
+ } elseif {[catch {package require nettool}]} {
+ # More spatial information -- better than hostname.
+ # bug 1150714: opening a server socket may raise a warning messagebox
+ # with WinXP firewall, using ipconfig will return all IP addresses
+ # including ipv6 ones if available. ipconfig is OK on win98+
+ if {[string equal $::tcl_platform(platform) "windows"]} {
+ catch {exec ipconfig} config
+ lappend machinfo $config
+ } else {
+ catch {
+ set s [socket -server void -myaddr [info hostname] 0]
+ K [fconfigure $s -sockname] [close $s]
+ } r
+ lappend machinfo $r
+ }
+
+ if {[package provide Tk] != {}} {
+ lappend machinfo [winfo pointerxy .]
+ lappend machinfo [winfo id .]
+ }
+ } else {
+ ###
+ # If the nettool package works on this platform
+ # use the stream of hardware ids from it
+ ###
+ lappend machinfo {*}[::nettool::hwid_list]
+ }
+ return $machinfo
+}
+
+# Generates a binary UUID as per the draft spec. We generate a pseudo-random
+# type uuid (type 4). See section 3.4
+#
+proc ::uuid::generate_tcl {} {
+ package require md5 2
+ variable uid
+
+ set tok [md5::MD5Init]
+ md5::MD5Update $tok [incr uid]; # package incrementing counter
+ foreach string [generate_tcl_machinfo] {
+ md5::MD5Update $tok $string
+ }
+ set r [md5::MD5Final $tok]
+ binary scan $r c* r
+
+ # 3.4: set uuid versioning fields
+ lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
+ lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
+
+ return [binary format c* $r]
+}
+
+if {[string equal $tcl_platform(platform) "windows"]
+ && [package provide critcl] != {}} {
+ namespace eval uuid {
+ critcl::ccode {
+ #define WIN32_LEAN_AND_MEAN
+ #define STRICT
+ #include
+ #include
+ typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
+ typedef const unsigned char cu_char;
+ }
+ critcl::cproc generate_c {Tcl_Interp* interp} ok {
+ HRESULT hr = S_OK;
+ int r = TCL_OK;
+ UUID uuid = {0};
+ HMODULE hLib;
+ LPFNUUIDCREATE lpfnUuidCreate = NULL;
+ hLib = LoadLibraryA(("rpcrt4.dll"));
+ if (hLib)
+ lpfnUuidCreate = (LPFNUUIDCREATE)
+ GetProcAddress(hLib, "UuidCreate");
+ if (lpfnUuidCreate) {
+ Tcl_Obj *obj;
+ lpfnUuidCreate(&uuid);
+ obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
+ Tcl_SetObjResult(interp, obj);
+ } else {
+ Tcl_SetResult(interp, "error: failed to create a guid",
+ TCL_STATIC);
+ r = TCL_ERROR;
+ }
+ return r;
+ }
+ }
+}
+
+# Convert a binary uuid into its string representation.
+#
+proc ::uuid::tostring {uuid} {
+ binary scan $uuid H* s
+ foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
+ append r [string range $s $a $b] -
+ }
+ return [string tolower [string trimright $r -]]
+}
+
+# Convert a string representation of a uuid into its binary format.
+#
+proc ::uuid::fromstring {uuid} {
+ return [binary format H* [string map {- {}} $uuid]]
+}
+
+# Compare two uuids for equality.
+#
+proc ::uuid::equal {left right} {
+ set l [fromstring $left]
+ set r [fromstring $right]
+ return [string equal $l $r]
+}
+
+# Call our generate uuid implementation
+proc ::uuid::generate {} {
+ variable accel
+ if {$accel(critcl)} {
+ return [generate_c]
+ } else {
+ return [generate_tcl]
+ }
+}
+
+# uuid generate -> string rep of a new uuid
+# uuid equal uuid1 uuid2
+#
+proc uuid::uuid {cmd args} {
+ switch -exact -- $cmd {
+ generate {
+ if {[llength $args] != 0} {
+ return -code error "wrong # args:\
+ should be \"uuid generate\""
+ }
+ return [tostring [generate]]
+ }
+ equal {
+ if {[llength $args] != 2} {
+ return -code error "wrong \# args:\
+ should be \"uuid equal uuid1 uuid2\""
+ }
+ return [eval [linsert $args 0 equal]]
+ }
+ default {
+ return -code error "bad option \"$cmd\":\
+ must be generate or equal"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::uuid::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]} {
+ set r [expr {[info commands ::uuid::generate_c] != {}}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::uuid {
+ variable e {}
+ foreach e {critcl} {
+ if {[LoadAccelerator $e]} break
+ }
+ unset e
+}
+
+package provide uuid 1.0.8
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/src/bootsupport/modules_tcl8/argp-0.2.tm b/src/bootsupport/modules_tcl8/argp-0.2.tm
new file mode 100644
index 00000000..1b1f4b78
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/argp-0.2.tm
@@ -0,0 +1,259 @@
+
+# Tcl parser for optional arguments in function calls and
+# commandline arguments
+#
+# (c) 2001 Bastien Chevreux
+
+# Index of exported commands
+# - argp::registerArgs
+# - argp::setArgDefaults
+# - argp::setArgsNeeded
+# - argp::parseArgs
+
+# Internal commands
+# - argp::CheckValues
+
+# See end of file for an example on how to use
+
+package provide argp 0.2
+
+namespace eval argp {
+ variable Optstore
+ variable Opttypes {
+ boolean integer double string
+ }
+
+ namespace export {[a-z]*}
+}
+
+
+proc argp::registerArgs { func arglist } {
+ variable Opttypes
+ variable Optstore
+
+ set parentns [string range [uplevel 1 [list namespace current]] 2 end]
+ if { $parentns != "" } {
+ append caller $parentns :: $func
+ } else {
+ set caller $func
+ }
+ set cmangled [string map {:: _} $caller]
+
+ #puts $parentns
+ #puts $caller
+ #puts $cmangled
+
+ set Optstore(keys,$cmangled) {}
+ set Optstore(deflist,$cmangled) {}
+ set Optstore(argneeded,$cmangled) {}
+
+ foreach arg $arglist {
+ foreach {opt type default allowed} $arg {
+ set optindex [lsearch -glob $Opttypes $type*]
+ if { $optindex < 0} {
+ return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]"
+ }
+ set type [lindex $Opttypes $optindex]
+
+ lappend Optstore(keys,$cmangled) $opt
+ set Optstore(type,$opt,$cmangled) $type
+ set Optstore(default,$opt,$cmangled) $default
+ set Optstore(allowed,$opt,$cmangled) $allowed
+ lappend Optstore(deflist,$cmangled) $opt $default
+ }
+ }
+
+ if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} {
+ return -code error "Error in declaration of optional arguments.\n$res"
+ }
+}
+
+proc argp::setArgDefaults { func arglist } {
+ variable Optstore
+
+ set parentns [string range [uplevel 1 [list namespace current]] 2 end]
+ if { $parentns != "" } {
+ append caller $parentns :: $func
+ } else {
+ set caller $func
+ }
+ set cmangled [string map {:: _} $caller]
+
+ if {![info exists Optstore(deflist,$cmangled)]} {
+ return -code error "Arguments for $caller not registered yet."
+ }
+ set Optstore(deflist,$cmangled) {}
+ foreach {opt default} $arglist {
+ if {![info exists Optstore(default,$opt,$cmangled)]} {
+ return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
+ }
+ set Optstore(default,$opt,$cmangled) $default
+ }
+
+ # set the new defaultlist
+ foreach opt $Optstore(keys,$cmangled) {
+ lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled)
+ }
+}
+
+proc argp::setArgsNeeded { func arglist } {
+ variable Optstore
+
+ set parentns [string range [uplevel 1 [list namespace current]] 2 end]
+ if { $parentns != "" } {
+ append caller $parentns :: $func
+ } else {
+ set caller $func
+ }
+ set cmangled [string map {:: _} $caller]
+
+ #append caller $parentns :: $func
+ #set cmangled ${parentns}_$func
+
+ if {![info exists Optstore(deflist,$cmangled)]} {
+ return -code error "Arguments for $caller not registered yet."
+ }
+
+ set Optstore(argneeded,$cmangled) {}
+ foreach opt $arglist {
+ if {![info exists Optstore(default,$opt,$cmangled)]} {
+ return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
+ }
+ lappend Optstore(argneeded,$cmangled) $opt
+ }
+}
+
+
+proc argp::parseArgs { args } {
+ variable Optstore
+
+ if {[llength $args] == 0} {
+ upvar args a opts o
+ } else {
+ upvar args a [lindex $args 0] o
+ }
+
+ if { [ catch { set caller [lindex [info level -1] 0]}]} {
+ set caller "main program"
+ set cmangled ""
+ } else {
+ set cmangled [string map {:: _} $caller]
+ }
+
+ if {![info exists Optstore(deflist,$cmangled)]} {
+ return -code error "Arguments for $caller not registered yet."
+ }
+
+ # set the defaults
+ array set o $Optstore(deflist,$cmangled)
+
+ # but unset the needed arguments
+ foreach key $Optstore(argneeded,$cmangled) {
+ catch { unset o($key) }
+ }
+
+ foreach {key val} $a {
+ if {![info exists Optstore(type,$key,$cmangled)]} {
+ return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)"
+ }
+ switch -exact -- $Optstore(type,$key,$cmangled) {
+ boolean -
+ integer {
+ if { $val == "" } {
+ return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value."
+ }
+ if { ![string is $Optstore(type,$key,$cmangled) $val]} {
+ return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value."
+ }
+ }
+ double {
+ if { $val == "" } {
+ return -code error "$caller, $key empty string is not double value."
+ }
+ if { ![string is double $val]} {
+ return -code error "$caller, $key $val is not double value."
+ }
+ if { [string is integer $val]} {
+ set val [expr {$val + .0}]
+ }
+ }
+ default {
+ }
+ }
+ set o($key) $val
+ }
+
+ foreach key $Optstore(argneeded,$cmangled) {
+ if {![info exists o($key)]} {
+ return -code error "$caller, needed argument $key was not given."
+ }
+ }
+
+ if { [catch { CheckValues $caller $cmangled [array get o]} err]} {
+ return -code error $err
+ }
+
+ return
+}
+
+
+proc argp::CheckValues { caller cmangled checklist } {
+ variable Optstore
+
+ #puts "Checking $checklist"
+
+ foreach {key val} $checklist {
+ if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } {
+ switch -exact -- $Optstore(type,$key,$cmangled) {
+ string {
+ if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} {
+ return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)"
+ }
+ }
+ double -
+ integer {
+ set found 0
+ foreach range $Optstore(allowed,$key,$cmangled) {
+ if {[llength $range] == 1} {
+ if { $val == [lindex $range 0] } {
+ set found 1
+ break
+ }
+ } elseif {[llength $range] == 2} {
+ set low [lindex $range 0]
+ set high [lindex $range 1]
+
+ if { ![string is integer $low] \
+ && [string compare "-" $low] != 0} {
+ return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range"
+ }
+ if { ![string is integer $high] \
+ && [string compare "+" $high] != 0} {
+ return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range"
+ }
+ if {[string compare "-" $low] == 0} {
+ if { [string compare "+" $high] == 0 \
+ || $val <= $high } {
+ set found 1
+ break
+ }
+ }
+ if { $val >= $low } {
+ if {[string compare "+" $high] == 0 \
+ || $val <= $high } {
+ set found 1
+ break
+ }
+ }
+ } else {
+ return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range"
+ }
+ }
+ if { $found == 0 } {
+ return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)"
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/src/bootsupport/modules_tcl8/cksum-1.1.4.tm b/src/bootsupport/modules_tcl8/cksum-1.1.4.tm
new file mode 100644
index 00000000..0fb17981
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/cksum-1.1.4.tm
@@ -0,0 +1,200 @@
+# cksum.tcl - Copyright (C) 2002 Pat Thoyts
+#
+# Provides a Tcl only implementation of the unix cksum(1) command. This is
+# similar to the sum(1) command but the algorithm is better defined and
+# standardized across multiple platforms by POSIX 1003.2/D11.2
+#
+# This command has been verified against the cksum command from the GNU
+# textutils package version 2.0
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.5-; # tcl minimum version
+
+namespace eval ::crc {
+ namespace export cksum
+
+ variable cksum_tbl [list 0x0 \
+ 0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \
+ 0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \
+ 0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \
+ 0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \
+ 0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \
+ 0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \
+ 0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \
+ 0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \
+ 0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \
+ 0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \
+ 0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \
+ 0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \
+ 0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \
+ 0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \
+ 0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \
+ 0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \
+ 0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \
+ 0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \
+ 0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \
+ 0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \
+ 0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \
+ 0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \
+ 0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \
+ 0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \
+ 0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \
+ 0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \
+ 0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \
+ 0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \
+ 0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \
+ 0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \
+ 0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \
+ 0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \
+ 0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \
+ 0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \
+ 0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \
+ 0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \
+ 0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \
+ 0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \
+ 0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \
+ 0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \
+ 0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \
+ 0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \
+ 0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \
+ 0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \
+ 0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \
+ 0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \
+ 0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \
+ 0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \
+ 0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \
+ 0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \
+ 0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ]
+
+ variable uid
+ if {![info exists uid]} {set uid 0}
+}
+
+# crc::CksumInit --
+#
+# Create and initialize a cksum context. This is cleaned up when we
+# call CksumFinal to obtain the result.
+#
+proc ::crc::CksumInit {} {
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+ array set state {t 0 l 0}
+ return $token
+}
+
+proc ::crc::CksumUpdate {token data} {
+ variable cksum_tbl
+ upvar #0 $token state
+ set t $state(t)
+ binary scan $data c* r
+ foreach {n} $r {
+ set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }]
+ # Since the introduction of built-in bigInt support with Tcl
+ # 8.5, bit-shifting $t to the left no longer overflows,
+ # keeping it 32 bits long. The value grows bigger and bigger
+ # instead - a severe hit on performance. For this reason we
+ # do a bitwise AND against 0xFFFFFFFF at each step to keep the
+ # value within limits.
+ set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}]
+ incr state(l)
+ }
+ set state(t) $t
+ return
+}
+
+proc ::crc::CksumFinal {token} {
+ variable cksum_tbl
+ upvar #0 $token state
+ set t $state(t)
+ for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} {
+ set index [expr {(($t >> 24) ^ $i) & 0xFF}]
+ set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}]
+ }
+ unset state
+ return [expr {~$t & 0xFFFFFFFF}]
+}
+
+# crc::Pop --
+#
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::crc::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# Description:
+# Provide a Tcl equivalent of the unix cksum(1) command.
+# Options:
+# -filename name - return a checksum for the specified file.
+# -format string - return the checksum using this format string.
+# -chunksize size - set the chunking read size
+#
+proc ::crc::cksum {args} {
+ array set opts [list -filename {} -channel {} -chunksize 4096 \
+ -format %u -command {}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -file* { set opts(-filename) [Pop args 1] }
+ -chan* { set opts(-channel) [Pop args 1] }
+ -chunk* { set opts(-chunksize) [Pop args 1] }
+ -for* { set opts(-format) [Pop args 1] }
+ -command { set opts(-command) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args ; break }
+ set err [join [lsort [array names opts -*]] ", "]
+ return -code error "bad option \"option\": must be $err"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be\
+ cksum ?-format string?\
+ -channel chan | -filename file | string"
+ }
+ set tok [CksumInit]
+ CksumUpdate $tok [lindex $args 0]
+ set r [CksumFinal $tok]
+
+ } else {
+
+ set tok [CksumInit]
+ while {![eof $opts(-channel)]} {
+ CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)]
+ }
+ set r [CksumFinal $tok]
+
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ return [format $opts(-format) $r]
+}
+
+# -------------------------------------------------------------------------
+
+package provide cksum 1.1.4
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/src/bootsupport/modules_tcl8/commandstack-0.3.tm b/src/bootsupport/modules_tcl8/commandstack-0.3.tm
new file mode 100644
index 00000000..b2561a20
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/commandstack-0.3.tm
@@ -0,0 +1,518 @@
+
+
+#JMN 2021 - Public Domain
+#cooperative command renaming
+#
+# REVIEW 2024 - code was originally for specific use in packageTrace
+# - code should be reviewed for more generic utility.
+# - API is obscure and undocumented.
+# - unclear if intention was only for builtins
+# - consider use of newer 'info cmdtype' - (but need also support for safe interps)
+# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
+# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename
+#changes:
+#2024
+# - mungecommand to support namespaced commands
+# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_
+#2021-09-18
+# - initial version
+# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
+# - They need to be able to load and unload in any order.
+#
+
+#strive for no other package dependencies here.
+
+
+namespace eval commandstack {
+ variable all_stacks
+ variable debug
+ set debug 0
+ variable known_renamers [list ::packagetrace ::packageSuppress]
+ if {![info exists all_stacks]} {
+ #don't wipe it
+ set all_stacks [dict create]
+ }
+}
+
+namespace eval commandstack::util {
+ #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
+ #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
+ #A magic comment was chosen as the identifying method.
+ #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
+
+ #return unspecified if the command is a proc with a body but no magic comment ID
+ #return unknown if the command doesn't have a proc body to analyze
+ #otherwise return the package name identified in the magic comment
+ proc get_IMPLEMENTOR {command} {
+ #assert - command has already been resolved to a namespace ie fully qualified
+ if {[llength [info procs $command]]} {
+ #look for *IMPLEMENTOR_*!
+ set prefix IMPLEMENTOR_
+ set suffix "!"
+ set body [uplevel 1 [list info body $command]]
+ if {[string match "*$prefix*$suffix*" $body]} {
+ set prefixposn [string first "$prefix" $body]
+ set pkgposn [expr {$prefixposn + [string length $prefix]}]
+ #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
+ set suffixposn [string first $suffix $body $pkgposn]
+ return [string range $body $pkgposn $suffixposn-1]
+ } else {
+ return unspecified
+ }
+ } else {
+ if {[info commands tcl::info::cmdtype] ne ""} {
+ #tcl9 and maybe some tcl 8.7s ?
+ switch -- [tcl::info::cmdtype $command] {
+ native {
+ return builtin
+ }
+ default {
+ return undetermined
+ }
+ }
+ } else {
+ return undetermined
+ }
+ }
+ }
+}
+namespace eval commandstack::renamed_commands {}
+namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place
+
+namespace eval commandstack {
+ namespace export {[a-z]*}
+ proc help {} {
+ return {
+
+ }
+ }
+
+ proc debug {{on_off {}}} {
+ variable debug
+ if {$on_off eq ""} {
+ return $debug
+ } else {
+ if {[string is boolean -strict $debug]} {
+ set debug [expr {$on_off && 1}]
+ return $debug
+ }
+ }
+ }
+
+ proc get_stack {{command ""}} {
+ variable all_stacks
+ if {$command eq ""} {
+ return $all_stacks
+ }
+ set command [uplevel 1 [list namespace which $command]]
+ if {[dict exists $all_stacks $command]} {
+ return [dict get $all_stacks $command]
+ } else {
+ return [list]
+ }
+ }
+
+ #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to.
+ #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
+ #e.g if renaming builtin 'package' - this command is generally called 'a lot'
+ proc get_next_command {command renamer tokenid} {
+ variable all_stacks
+ if {[dict exists $all_stacks $command]} {
+ set stack [dict get $all_stacks $command]
+ #stack is a list of dicts, 1st entry is token { }
+ set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
+ if {$posn > -1} {
+ set record [lindex $stack $posn]
+ return [dict get $record implementation]
+ } else {
+ error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid"
+ }
+ } else {
+ return $command
+ }
+ }
+ proc basecall {command args} {
+ variable all_stacks
+ set command [uplevel 1 [list namespace which $command]]
+ if {[dict exists $all_stacks $command]} {
+ set stack [dict get $all_stacks $command]
+ if {[llength $stack]} {
+ set rec1 [lindex $stack 0]
+ tailcall [dict get $rec1 implementation] {*}$args
+ } else {
+ tailcall $command {*}$args
+ }
+ } else {
+ tailcall $command {*}$args
+ }
+ }
+
+
+ #review.
+ # defaults to calling namespace - but can be arbitrary string
+ proc rename_command {args} {
+ #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames
+ # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack
+ #
+ if {[lindex $args 0] eq "-renamer"} {
+ set renamer [lindex $args 1]
+ set arglist [lrange $args 2 end]
+ } else {
+ set renamer ""
+ set arglist $args
+ }
+ if {[llength $arglist] != 3} {
+ error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody"
+ }
+ lassign $arglist command procargs procbody
+
+ set command [uplevel 1 [list namespace which $command]]
+ set mungedcommand [string map {:: _ns_} $command]
+ set mungedrenamer [string map {:: _ns_} $renamer]
+ variable all_stacks
+ variable known_renamers
+ variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done.
+ if {$renamer eq ""} {
+ set renamer [uplevel 1 [list namespace current]]
+ }
+ if {$renamer ni $known_renamers} {
+ lappend known_renamers $renamer
+ dict set renamer_command_tokens [list $renamer $command] 0
+ }
+
+ #TODO - reduce emissions to stderr - flag for debug?
+
+ #e.g packageTrace and packageSuppress packages use this convention.
+ set nextinfo [uplevel 1 [list\
+ apply {{command renamer procbody} {
+ #todo - munge dash so we can make names in renamed_commands separable
+ # {- _dash_} ?
+ set mungedcommand [string map {:: _ns_} $command]
+ set mungedrenamer [string map {:: _ns_} $renamer]
+ set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1]
+ set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
+ set do_rename 0
+ if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
+ #$command is not the standard builtin - something has replaced it, could be ourself.
+ set next_implementor [::commandstack::util::get_IMPLEMENTOR $command]
+ set munged_next_implementor [string map {:: _ns_} $next_implementor]
+ #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it.
+ if {[dict exists $::commandstack::all_stacks $command]} {
+ set comstacks [dict get $::commandstack::all_stacks $command]
+ } else {
+ set comstacks [list]
+ }
+ set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer')
+ if {[llength $this_renamer_previous_entries]} {
+ if {$next_implementor eq $renamer} {
+ #previous renamer was us. Rather than assume our job is done.. compare the implementations
+ #don't rename if immediate predecessor is same code.
+ #set topstack [lindex $comstacks end]
+ #set next_impl [dict get $topstack implementation]
+ set current_body [info body $command]
+ lassign [commandstack::lib::split_body $current_body] _ current_code
+ set current_code [string trim $current_code]
+ set new_code [string trim $procbody]
+ if {$current_code eq $new_code} {
+ puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename."
+ puts stderr [::commandstack::show_stack $command]
+ } else {
+ puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding."
+ puts stdout "----------"
+ puts stdout "$current_code"
+ puts stdout "----------"
+ puts stdout "$new_code"
+ puts stdout "----------"
+ set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
+ set do_rename 1
+ }
+ } else {
+ puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)"
+ puts stderr
+ set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
+ set do_rename 1
+ }
+ } elseif {$next_implementor in $::commandstack::known_renamers} {
+ set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
+ set do_rename 1
+ } elseif {$next_implementor in {builtin}} {
+ #native/builtin could still have been renamed
+ set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
+ set do_rename 1
+ } elseif {$next_implementor in {unspecified undetermined}} {
+ #could be a standard tcl proc, or from application or package
+ set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
+ set do_rename 1
+ } else {
+ puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)"
+ set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
+ set do_rename 1
+ }
+ } else {
+ #_originalcommand_
+ #assume builtin/original
+ set next_implementor original
+ #rename $command $next_target
+ set do_rename 1
+ }
+ #There are of course other ways in which $command may have been renamed - but we can't detect.
+ set token [list $command $renamer $tokenid]
+ return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename]
+ } } $command $renamer $procbody]
+ ]
+
+
+ variable debug
+ if {$debug} {
+ if {[dict exists $all_stacks $command]} {
+ set stack [dict get $all_stacks $command]
+ puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]"
+ } else {
+ #assume this is the original
+ puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]"
+ }
+ }
+
+ #token is always first dict entry. (Value needs to be searched with lsearch -index 1 )
+ #renamer is always second dict entry (Value needs to be searched with lsearch -index 3)
+ set new_record [dict create\
+ token [dict get $nextinfo token]\
+ renamer $renamer\
+ next_implementor [dict get $nextinfo next_implementor]\
+ next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\
+ implementation [dict get $nextinfo next_target]\
+ ]
+ if {![dict get $nextinfo do_rename]} {
+ #review
+ puts stderr "no rename performed"
+ return [dict create implementation ""]
+ }
+ catch {rename ::commandstack::temp::testproc ""}
+ set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] {
+ #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% )
+ set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc.
+ set COMMANDSTACKNEXT [%next_getter%]
+ ##
+ }]
+ set final_procbody "$nextinit$procbody"
+ #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command
+ #(e.g due to invalid argument specifiers)
+ proc ::commandstack::temp::testproc $procargs $final_procbody
+ uplevel 1 [list rename $command [dict get $nextinfo next_target]]
+ uplevel 1 [list rename ::commandstack::temp::testproc $command]
+ dict lappend all_stacks $command $new_record
+
+
+ return $new_record
+ }
+
+ #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer
+ #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost
+ #todo - removal of all entries pertaining to a particular renamer
+ #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack?
+
+ #remove by token, or by commandname if called from same context as original rename_command
+ #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed.
+ #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything.
+ #similarly a nonexistant token or renamer will not remove anything and will just return the current stack
+ proc remove_rename {token_or_command} {
+ if {[llength $token_or_command] == 3} {
+ #is token
+ lassign $token_or_command command renamer tokenid
+ } elseif {[llength $token_or_command] == 2} {
+ #command and renamer only supplied
+ lassign $token_or_command command renamer
+ set tokenid ""
+ } elseif {[llength $token_or_command] == 1} {
+ #is command name only
+ set command $token_or_command
+ set renamer [uplevel 1 [list namespace current]]
+ set tokenid ""
+ }
+ set command [uplevel 1 [list namespace which $command]]
+ variable all_stacks
+ variable known_renamers
+ if {$renamer ni $known_renamers} {
+ error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }"
+ }
+ if {[dict exists $all_stacks $command]} {
+ set stack [dict get $all_stacks $command]
+ if {$tokenid ne ""} {
+ #token_or_command is a token as returned within the rename_command result dictionary
+ #search first dict value
+ set doomed_posn [lsearch -index 1 $stack $token_or_command]
+ } else {
+ #search second dict value
+ set matches [lsearch -all -index 3 $stack $renamer]
+ set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer
+ }
+ if {$doomed_posn ne "" && $doomed_posn > -1} {
+ set doomed_record [lindex $stack $doomed_posn]
+ if {[llength $stack] == ($doomed_posn + 1)} {
+ #last on stack - put the implemenation from the doomed_record back as the actual command
+ uplevel #0 [list rename $command ""]
+ uplevel #0 [list rename [dict get $doomed_record implementation] $command]
+ } elseif {[llength $stack] > ($doomed_posn + 1)} {
+ #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
+ set rewrite_posn [expr {$doomed_posn + 1}]
+ set rewrite_record [lindex $stack $rewrite_posn]
+
+ if {[dict get $rewrite_record next_implementor] ne $renamer} {
+ puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]"
+ } else {
+ uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
+ }
+ dict set rewrite_record next_implementor [dict get $doomed_record next_implementor]
+ #don't update next_getter - it always refers to self
+ dict set rewrite_record implementation [dict get $doomed_record implementation]
+ lset stack $rewrite_posn $rewrite_record
+ dict set all_stacks $command $stack
+ }
+ set stack [lreplace $stack $doomed_posn $doomed_posn]
+ dict set all_stacks $command $stack
+
+ }
+ return $stack
+ }
+ return [list]
+ }
+
+ proc show_stack {{commandname_glob *}} {
+ variable all_stacks
+ if {![regexp {[?*]} $commandname_glob]} {
+ #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace
+ set commandname_glob [uplevel 1 [list namespace which $commandname_glob]]
+ }
+ if {[package provide punk::lib] ne "" && [package provide punk] ne ""} {
+ #punk pipeline also needed for patterns
+ return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*]
+ } else {
+ set result ""
+ set matchedkeys [dict keys $all_stacks $commandname_glob]
+ #don't try to calculate widest on empty list
+ if {[llength $matchedkeys]} {
+ set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
+ set indent [string repeat " " [expr {$widest + 3}]]
+ set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide
+ set padkey [string repeat " " 20]
+ foreach k $matchedkeys {
+ append result "$k = "
+ set i 0
+ foreach stackmember [dict get $all_stacks $k] {
+ if {$i > 0} {
+ append result "\n$indent"
+ }
+ append result [string range "$i " 0 4] " = "
+ set j 0
+ dict for {k v} $stackmember {
+ if {$j > 0} {
+ append result "\n$indent2"
+ }
+ set displaykey [string range "$k$padkey" 0 20]
+ append result "$displaykey = $v"
+ incr j
+ }
+ incr i
+ }
+ append result \n
+ }
+ }
+ return $result
+ }
+ }
+
+ #review
+ #document when this is to be called. Wiping stacks without undoing renames seems odd.
+ proc Delete_stack {command} {
+ variable all_stacks
+ if {[dict exists $all_stacks $command]} {
+ dict unset all_stacks $command
+ return 1
+ } else {
+ return 1
+ }
+ }
+
+ #can be used to temporarily put a stack aside - should manually rename back when done.
+ #review - document how/when to use. example? intention?
+ proc Rename_stack {oldname newname} {
+ variable all_stacks
+ if {[dict exists $all_stacks $oldname]} {
+ if {[dict exists $all_stacks $newname]} {
+ error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
+ } else {
+ #set stackval [dict get $all_stacks $oldname]
+ #dict unset all_stacks $oldname
+ #dict set all_stacks $newname $stackval
+ dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
+ }
+ }
+ }
+}
+
+
+
+
+
+
+
+
+namespace eval commandstack::lib {
+ proc splitx {str {regexp {[\t \r\n]+}}} {
+ #snarfed from tcllib textutil::splitx to avoid the dependency
+ # Bugfix 476988
+ if {[string length $str] == 0} {
+ return {}
+ }
+ if {[string length $regexp] == 0} {
+ return [::split $str ""]
+ }
+ if {[regexp $regexp {}]} {
+ return -code error "splitting on regexp \"$regexp\" would cause infinite loop"
+ }
+
+ set list {}
+ set start 0
+ while {[regexp -start $start -indices -- $regexp $str match submatch]} {
+ foreach {subStart subEnd} $submatch break
+ foreach {matchStart matchEnd} $match break
+ incr matchStart -1
+ incr matchEnd
+ lappend list [string range $str $start $matchStart]
+ if {$subStart >= $start} {
+ lappend list [string range $str $subStart $subEnd]
+ }
+ set start $matchEnd
+ }
+ lappend list [string range $str $start end]
+ return $list
+ }
+ proc split_body {procbody} {
+ set marker "##"
+ set header ""
+ set code ""
+ set found_marker 0
+ foreach ln [split $procbody \n] {
+ if {!$found_marker} {
+ if {[string trim $ln] eq $marker} {
+ set found_marker 1
+ } else {
+ append header $ln \n
+ }
+ } else {
+ append code $ln \n
+ }
+ }
+ if {$found_marker} {
+ return [list $header $code]
+ } else {
+ return [list "" $procbody]
+ }
+ }
+}
+
+package provide commandstack [namespace eval commandstack {
+ set version 0.3
+}]
+
+
diff --git a/src/bootsupport/modules_tcl8/debug-1.0.6.tm b/src/bootsupport/modules_tcl8/debug-1.0.6.tm
new file mode 100644
index 00000000..c2ee57be
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/debug-1.0.6.tm
@@ -0,0 +1,306 @@
+# Debug - a debug narrative logger.
+# -- Colin McCormack / originally Wub server utilities
+#
+# Debugging areas of interest are represented by 'tokens' which have
+# independantly settable levels of interest (an integer, higher is more detailed)
+#
+# Debug narrative is provided as a tcl script whose value is [subst]ed in the
+# caller's scope if and only if the current level of interest matches or exceeds
+# the Debug call's level of detail. This is useful, as one can place arbitrarily
+# complex narrative in code without unnecessarily evaluating it.
+#
+# TODO: potentially different streams for different areas of interest.
+# (currently only stderr is used. there is some complexity in efficient
+# cross-threaded streams.)
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5-
+
+namespace eval ::debug {
+ namespace export -clear \
+ define on off prefix suffix header trailer \
+ names 2array level setting parray pdict \
+ nl tab hexl
+ namespace ensemble create -subcommands {}
+}
+
+# # ## ### ##### ######## ############# #####################
+## API & Implementation
+
+proc ::debug::noop {args} {}
+
+proc ::debug::debug {tag message {level 1}} {
+ variable detail
+ if {$detail($tag) < $level} {
+ #puts stderr "$tag @@@ $detail($tag) >= $level"
+ return
+ }
+
+ variable prefix
+ variable suffix
+ variable header
+ variable trailer
+ variable fds
+
+ if {[info exists fds($tag)]} {
+ set fd $fds($tag)
+ } else {
+ set fd stderr
+ }
+
+ # Assemble the shown text from the user message and the various
+ # prefixes and suffices (global + per-tag).
+
+ set themessage ""
+ if {[info exists prefix(::)]} { append themessage $prefix(::) }
+ if {[info exists prefix($tag)]} { append themessage $prefix($tag) }
+ append themessage $message
+ if {[info exists suffix($tag)]} { append themessage $suffix($tag) }
+ if {[info exists suffix(::)]} { append themessage $suffix(::) }
+
+ # Resolve variables references and command invokations embedded
+ # into the message with plain text.
+ set code [catch {
+ set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]]
+ set sheader [uplevel 1 [list ::subst -nobackslashes $header]]
+ set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]]
+ } __ eo]
+
+ # And dump an internal error if that resolution failed.
+ if {$code} {
+ if {[catch {
+ set caller [info level -1]
+ }]} { set caller GLOBAL }
+ if {[string length $caller] >= 1000} {
+ set caller "[string range $caller 0 200]...[string range $caller end-200 end]"
+ }
+ foreach line [split $caller \n] {
+ puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)"
+ }
+ return
+ }
+
+ # From here we have a good message to show. We only shorten it a
+ # bit if its a bit excessive in size.
+
+ if {[string length $smessage] > 4096} {
+ set head [string range $smessage 0 2048]
+ set tail [string range $smessage end-2048 end]
+ set smessage "${head}...(truncated)...$tail"
+ }
+
+ foreach line [split $smessage \n] {
+ puts $fd "$sheader$tag | $line$strailer"
+ }
+ return
+}
+
+# names - return names of debug tags
+proc ::debug::names {} {
+ variable detail
+ return [lsort [array names detail]]
+}
+
+proc ::debug::2array {} {
+ variable detail
+ set result {}
+ foreach n [lsort [array names detail]] {
+ if {[interp alias {} debug.$n] ne "::debug::noop"} {
+ lappend result $n $detail($n)
+ } else {
+ lappend result $n -$detail($n)
+ }
+ }
+ return $result
+}
+
+# level - set level and fd for tag
+proc ::debug::level {tag {level ""} {fd {}}} {
+ variable detail
+ # TODO: Force level >=0.
+ if {$level ne ""} {
+ set detail($tag) $level
+ }
+
+ if {![info exists detail($tag)]} {
+ set detail($tag) 1
+ }
+
+ variable fds
+ if {$fd ne {}} {
+ set fds($tag) $fd
+ }
+
+ return $detail($tag)
+}
+
+proc ::debug::header {text} { variable header $text }
+proc ::debug::trailer {text} { variable trailer $text }
+
+proc ::debug::define {tag} {
+ if {[interp alias {} debug.$tag] ne {}} return
+ off $tag
+ return
+}
+
+# Set a prefix/suffix to use for tag.
+# The global (tag-independent) prefix/suffix is adressed through tag '::'.
+# This works because colon (:) is an illegal character for user-specified tags.
+
+proc ::debug::prefix {tag {theprefix {}}} {
+ variable prefix
+ set prefix($tag) $theprefix
+
+ if {[interp alias {} debug.$tag] ne {}} return
+ off $tag
+ return
+}
+
+proc ::debug::suffix {tag {theprefix {}}} {
+ variable suffix
+ set suffix($tag) $theprefix
+
+ if {[interp alias {} debug.$tag] ne {}} return
+ off $tag
+ return
+}
+
+# turn on debugging for tag
+proc ::debug::on {tag {level ""} {fd {}}} {
+ variable active
+ set active($tag) 1
+ level $tag $level $fd
+ interp alias {} debug.$tag {} ::debug::debug $tag
+ return
+}
+
+# turn off debugging for tag
+proc ::debug::off {tag {level ""} {fd {}}} {
+ variable active
+ set active($tag) 1
+ level $tag $level $fd
+ interp alias {} debug.$tag {} ::debug::noop
+ return
+}
+
+proc ::debug::setting {args} {
+ if {[llength $args] == 1} {
+ set args [lindex $args 0]
+ }
+ set fd stderr
+ if {[llength $args] % 2} {
+ set fd [lindex $args end]
+ set args [lrange $args 0 end-1]
+ }
+ foreach {tag level} $args {
+ if {$level > 0} {
+ level $tag $level $fd
+ interp alias {} debug.$tag {} ::debug::debug $tag
+ } else {
+ level $tag [expr {-$level}] $fd
+ interp alias {} debug.$tag {} ::debug::noop
+ }
+ }
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+## Convenience commands.
+# Format arrays and dicts as multi-line message.
+# Insert newlines and tabs.
+
+proc ::debug::nl {} { return \n }
+proc ::debug::tab {} { return \t }
+
+proc ::debug::parray {a {pattern *}} {
+ upvar 1 $a array
+ if {![array exists array]} {
+ error "\"$a\" isn't an array"
+ }
+ pdict [array get array] $pattern
+}
+
+proc ::debug::pdict {dict {pattern *}} {
+ set maxl 0
+ set names [lsort -dict [dict keys $dict $pattern]]
+ foreach name $names {
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ set maxl [expr {$maxl + 2}]
+ set lines {}
+ foreach name $names {
+ set nameString [format (%s) $name]
+ lappend lines [format "%-*s = %s" \
+ $maxl $nameString \
+ [dict get $dict $name]]
+ }
+ return [join $lines \n]
+}
+
+proc ::debug::hexl {data {prefix {}}} {
+ set r {}
+
+ # Convert the data to hex and to characters.
+ binary scan $data H*@0a* hexa asciia
+
+ # Replace non-printing characters in the data with dots.
+ regsub -all -- {[^[:graph:] ]} $asciia {.} asciia
+
+ # Pad with spaces to a full multiple of 32/16.
+ set n [expr {[string length $hexa] % 32}]
+ if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] }
+ #puts "pad H [expr {32-$n}]"
+
+ set n [expr {[string length $asciia] % 32}]
+ if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] }
+ #puts "pad A [expr {32-$n}]"
+
+ # Reassemble formatted, in groups of 16 bytes/characters.
+ # The hex part is handled in groups of 32 nibbles.
+ set addr 0
+ while {[string length $hexa]} {
+ # Get front group of 16 bytes each.
+ set hex [string range $hexa 0 31]
+ set ascii [string range $asciia 0 15]
+ # Prep for next iteration
+ set hexa [string range $hexa 32 end]
+ set asciia [string range $asciia 16 end]
+
+ # Convert the hex to pairs of hex digits
+ regsub -all -- {..} $hex {& } hex
+
+ # Add the hex and latin-1 data to the result buffer
+ append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n
+ incr addr 16
+ }
+
+ # And done
+ return $r
+}
+
+# # ## ### ##### ######## ############# #####################
+
+namespace eval debug {
+ variable detail ; # map: TAG -> level of interest
+ variable prefix ; # map: TAG -> message prefix to use
+ variable suffix ; # map: TAG -> message suffix to use
+ variable fds ; # map: TAG -> handle of open channel to log to.
+ variable header {} ; # per-line heading, subst'ed
+ variable trailer {} ; # per-line ending, subst'ed
+
+ # Notes:
+ # - The tag '::' is reserved. "prefix" and "suffix" use it to store
+ # the global message prefix / suffix.
+ # - prefix and suffix are applied per message.
+ # - header and trailer are per line. And should not generate multiple lines!
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide debug 1.0.6
+return
diff --git a/src/bootsupport/modules_tcl8/dictn-0.1.2.tm b/src/bootsupport/modules_tcl8/dictn-0.1.2.tm
new file mode 100644
index 00000000..2ed2b1ef
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/dictn-0.1.2.tm
@@ -0,0 +1,366 @@
+# -*- tcl -*-
+# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt
+#
+# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
+# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+# (C) 2023
+#
+# @@ Meta Begin
+# Application dictn 0.1.2
+# Meta platform tcl
+# Meta license
+# @@ Meta End
+
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+## Requirements
+##e.g package require frobz
+
+
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+namespace eval dictn {
+ namespace export {[a-z]*}
+ namespace ensemble create
+}
+
+
+## ::dictn::append
+#This can of course 'ruin' a nested dict if applied to the wrong element
+# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl:
+# %set list {a b {c d}}
+# %append list x
+# a b {c d}x
+# IOW - don't do that unless you really know that's what you want.
+#
+proc ::dictn::append {dictvar path {value {}}} {
+ if {[llength $path] == 1} {
+ uplevel 1 [list dict append $dictvar $path $value]
+ } else {
+ upvar 1 $dictvar dvar
+
+ ::set str [dict get $dvar {*}$path]
+ append str $val
+ dict set dvar {*}$path $str
+ }
+}
+
+proc ::dictn::create {args} {
+ ::set data {}
+ foreach {path val} $args {
+ dict set data {*}$path $val
+ }
+ return $data
+}
+
+proc ::dictn::exists {dictval path} {
+ return [dict exists $dictval {*}$path]
+}
+
+proc ::dictn::filter {dictval path filterType args} {
+ ::set sub [dict get $dictval {*}$path]
+ dict filter $sub $filterType {*}$args
+}
+
+proc ::dictn::for {keyvalvars dictval path body} {
+ ::set sub [dict get $dictval {*}$path]
+ dict for $keyvalvars $sub $body
+}
+
+proc ::dictn::get {dictval {path {}}} {
+ return [dict get $dictval {*}$path]
+}
+
+
+if {[info commands ::tcl::dict::getdef] ne ""} {
+ #tcl 9+
+ proc ::dictn::getdef {dictval path default} {
+ return [dict getdef $dictval {*}$path $default]
+ }
+
+ proc ::dictn::getwithdefault {dictval path default} {
+ return [dict getdef $dictval {*}$path $default]
+ }
+
+ proc ::dictn::incr {dictvar path {increment {}} } {
+ if {$increment eq ""} {
+ ::set increment 1
+ }
+ if {[llength $path] == 1} {
+ uplevel 1 [list dict incr $dictvar $path $increment]
+ } else {
+ upvar 1 $dictvar dvar
+ if {![::info exists dvar]} {
+ dict set dvar {*}$path $increment
+ } else {
+ ::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}]
+ dict set dvar {*}$path $newval
+ }
+ return $dvar
+ }
+ }
+} else {
+ #tcl < 9
+ proc ::dictn::getdef {dictval path default} {
+ if {[tcl::dict::exists $dictval {*}$path]} {
+ return [tcl::dict::get $dictval {*}$path]
+ } else {
+ return $default
+ }
+ }
+ proc ::dictn::getwithdefault {dictval path default} {
+ if {[tcl::dict::exists $dictval {*}$path]} {
+ return [tcl::dict::get $dictval {*}$path]
+ } else {
+ return $default
+ }
+ }
+ proc ::dictn::incr {dictvar path {increment {}} } {
+ if {$increment eq ""} {
+ ::set increment 1
+ }
+ if {[llength $path] == 1} {
+ uplevel 1 [list dict incr $dictvar $path $increment]
+ } else {
+ upvar 1 $dictvar dvar
+ if {![::info exists dvar]} {
+ dict set dvar {*}$path $increment
+ } else {
+ if {![dict exists $dvar {*}$path]} {
+ ::set val 0
+ } else {
+ ::set val [dict get $dvar {*}$path]
+ }
+ ::set newval [expr {$val + $increment}]
+ dict set dvar {*}$path $newval
+ }
+ return $dvar
+ }
+ }
+}
+
+proc ::dictn::info {dictval {path {}}} {
+ if {![string length $path]} {
+ return [dict info $dictval]
+ } else {
+ ::set sub [dict get $dictval {*}$path]
+ return [dict info $sub]
+ }
+}
+
+proc ::dictn::keys {dictval {path {}} {glob {}}} {
+ ::set sub [dict get $dictval {*}$path]
+ if {[string length $glob]} {
+ return [dict keys $sub $glob]
+ } else {
+ return [dict keys $sub]
+ }
+}
+
+proc ::dictn::lappend {dictvar path args} {
+ if {[llength $path] == 1} {
+ uplevel 1 [list dict lappend $dictvar $path {*}$args]
+ } else {
+ upvar 1 $dictvar dvar
+
+ ::set list [dict get $dvar {*}$path]
+ ::lappend list {*}$args
+ dict set dvar {*}$path $list
+ }
+}
+
+proc ::dictn::merge {args} {
+ error "nested merge not yet supported"
+}
+
+#dictn remove dictionaryValue ?path ...?
+proc ::dictn::remove {dictval args} {
+ ::set basic [list] ;#buffer basic (1element path) removals to do in a single call.
+
+ foreach path $args {
+ if {[llength $path] == 1} {
+ ::lappend basic $path
+ } else {
+ #extract,modify,replace
+ ::set subpath [lrange $path 0 end-1]
+
+ ::set sub [dict get $dictval {*}$subpath]
+ ::set sub [dict remove $sub [lindex $path end]]
+
+ dict set dictval {*}$subpath $sub
+ }
+ }
+
+ if {[llength $basic]} {
+ return [dict remove $dictval {*}$basic]
+ } else {
+ return $dictval
+ }
+}
+
+
+proc ::dictn::replace {dictval args} {
+ ::set basic [list] ;#buffer basic (1element path) replacements to do in a single call.
+
+ foreach {path val} $args {
+ if {[llength $path] == 1} {
+ ::lappend basic $path $val
+ } else {
+ #extract,modify,replace
+ ::set subpath [lrange $path 0 end-1]
+
+ ::set sub [dict get $dictval {*}$subpath]
+ ::set sub [dict replace $sub [lindex $path end] $val]
+
+ dict set dictval {*}$subpath $sub
+ }
+ }
+
+
+ if {[llength $basic]} {
+ return [dict replace $dictval {*}$basic]
+ } else {
+ return $dictval
+ }
+}
+
+
+proc ::dictn::set {dictvar path newval} {
+ upvar 1 $dictvar dvar
+ return [dict set dvar {*}$path $newval]
+}
+
+proc ::dictn::size {dictval {path {}}} {
+ return [dict size [dict get $dictval {*}$path]]
+}
+
+proc ::dictn::unset {dictvar path} {
+ upvar 1 $dictvar dvar
+ return [dict unset dvar {*}$path
+}
+
+proc ::dictn::update {dictvar args} {
+ ::set body [lindex $args end]
+ ::set maplist [lrange $args 0 end-1]
+
+ upvar 1 $dictvar dvar
+ foreach {path var} $maplist {
+ if {[dict exists $dvar {*}$path]} {
+ uplevel 1 [list set $var [dict get $dvar $path]]
+ }
+ }
+
+ catch {uplevel 1 $body} result
+
+ foreach {path var} $maplist {
+ if {[dict exists $dvar {*}$path]} {
+ upvar 1 $var $var
+ if {![::info exists $var]} {
+ uplevel 1 [list dict unset $dictvar {*}$path]
+ } else {
+ uplevel 1 [list dict set $dictvar {*}$path [::set $var]]
+ }
+ }
+ }
+ return $result
+}
+
+#an experiment.
+proc ::dictn::Applyupdate {dictvar args} {
+ ::set body [lindex $args end]
+ ::set maplist [lrange $args 0 end-1]
+
+ upvar 1 $dictvar dvar
+
+ ::set headscript ""
+ ::set i 0
+ foreach {path var} $maplist {
+ if {[dict exists $dvar {*}$path]} {
+ #uplevel 1 [list set $var [dict get $dvar $path]]
+ ::lappend arglist $var
+ ::lappend vallist [dict get $dvar {*}$path]
+ ::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ]
+ ::append headscript \n
+ ::incr i
+ }
+ }
+
+ ::set body $headscript\r\n$body
+
+ puts stderr "BODY: $body"
+
+ #set result [apply [list args $body] {*}$vallist]
+ catch {apply [list args $body] {*}$vallist} result
+
+ foreach {path var} $maplist {
+ if {[dict exists $dvar {*}$path] && [::info exists $var]} {
+ dict set dvar {*}$path [::set $var]
+ }
+ }
+ return $result
+}
+
+proc ::dictn::values {dictval {path {}} {glob {}}} {
+ ::set sub [dict get $dictval {*}$path]
+ if {[string length $glob]} {
+ return [dict values $sub $glob]
+ } else {
+ return [dict values $sub]
+ }
+}
+
+# Standard form:
+#'dictn with dictVariable path body'
+#
+# Extended form:
+#'dictn with dictVariable path arrayVariable body'
+#
+proc ::dictn::with {dictvar path args} {
+ if {[llength $args] == 1} {
+ ::set body [lindex $args 0]
+ return [uplevel 1 [list dict with $dictvar {*}$path $body]]
+ } else {
+ upvar 1 $dictvar dvar
+ ::lassign $args arrayname body
+
+ upvar 1 $arrayname arr
+ array set arr [dict get $dvar {*}$path]
+ ::set prevkeys [array names arr]
+
+ catch {uplevel 1 $body} result
+
+
+ foreach k $prevkeys {
+ if {![::info exists arr($k)]} {
+ dict unset $dvar {*}$path $k
+ }
+ }
+ foreach k [array names arr] {
+ dict set $dvar {*}$path $k $arr($k)
+ }
+
+ return $result
+ }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+## Ready
+package provide dictn [namespace eval dictn {
+ variable version
+ ::set version 0.1.2
+}]
+return
\ No newline at end of file
diff --git a/src/bootsupport/modules_tcl8/dictutils-0.2.1.tm b/src/bootsupport/modules_tcl8/dictutils-0.2.1.tm
new file mode 100644
index 00000000..12ca495b
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/dictutils-0.2.1.tm
@@ -0,0 +1,145 @@
+# dictutils.tcl --
+ #
+ # Various dictionary utilities.
+ #
+ # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk).
+ #
+ # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style).
+ #
+
+ #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-"
+
+ package require Tcl 8.6-
+ package provide dictutils 0.2.1
+
+ namespace eval dictutils {
+ namespace export equal apply capture witharray nlappend
+ namespace ensemble create
+
+ # dictutils witharray dictVar arrayVar script --
+ #
+ # Unpacks the elements of the dictionary in dictVar into the array
+ # variable arrayVar and then evaluates the script. If the script
+ # completes with an ok, return or continue status, then the result is copied
+ # back into the dictionary variable, otherwise it is discarded. A
+ # [break] can be used to explicitly abort the transaction.
+ #
+ proc witharray {dictVar arrayVar script} {
+ upvar 1 $dictVar dict $arrayVar array
+ array set array $dict
+ try { uplevel 1 $script
+ } on break {} { # Discard the result
+ } on continue result - on ok result {
+ set dict [array get array] ;# commit changes
+ return $result
+ } on return {result opts} {
+ set dict [array get array] ;# commit changes
+ dict incr opts -level ;# remove this proc from level
+ return -options $opts $result
+ }
+ # All other cases will discard the changes and propagage
+ }
+
+ # dictutils equal equalp d1 d2 --
+ #
+ # Compare two dictionaries for equality. Two dictionaries are equal
+ # if they (a) have the same keys, (b) the corresponding values for
+ # each key in the two dictionaries are equal when compared using the
+ # equality predicate, equalp (passed as an argument). The equality
+ # predicate is invoked with the key and the two values from each
+ # dictionary as arguments.
+ #
+ proc equal {equalp d1 d2} {
+ if {[dict size $d1] != [dict size $d2]} { return 0 }
+ dict for {k v} $d1 {
+ if {![dict exists $d2 $k]} { return 0 }
+ if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 }
+ }
+ return 1
+ }
+
+ # apply dictVar lambdaExpr ?arg1 arg2 ...? --
+ #
+ # A combination of *dict with* and *apply*, this procedure creates a
+ # new procedure scope populated with the values in the dictionary
+ # variable. It then applies the lambdaTerm (anonymous procedure) in
+ # this new scope. If the procedure completes normally, then any
+ # changes made to variables in the dictionary are reflected back to
+ # the dictionary variable, otherwise they are ignored. This provides
+ # a transaction-style semantics whereby atomic updates to a
+ # dictionary can be performed. This procedure can also be useful for
+ # implementing a variety of control constructs, such as mutable
+ # closures.
+ #
+ proc apply {dictVar lambdaExpr args} {
+ upvar 1 $dictVar dict
+ set env $dict ;# copy
+ lassign $lambdaExpr params body ns
+ if {$ns eq ""} { set ns "::" }
+ set body [format {
+ upvar 1 env __env__
+ dict with __env__ %s
+ } [list $body]]
+ set lambdaExpr [list $params $body $ns]
+ set rc [catch { ::apply $lambdaExpr {*}$args } ret opts]
+ if {$rc == 0} {
+ # Copy back any updates
+ set dict $env
+ }
+ return -options $opts $ret
+ }
+
+ # capture ?level? ?exclude? ?include? --
+ #
+ # Captures a snapshot of the current (scalar) variable bindings at
+ # $level on the stack into a dictionary environment. This dictionary
+ # can later be used with *dictutils apply* to partially restore the
+ # scope, creating a first approximation of closures. The *level*
+ # argument should be of the forms accepted by *uplevel* and
+ # designates which level to capture. It defaults to 1 as in uplevel.
+ # The *exclude* argument specifies an optional list of literal
+ # variable names to avoid when performing the capture. No variables
+ # matching any item in this list will be captured. The *include*
+ # argument can be used to specify a list of glob patterns of
+ # variables to capture. Only variables matching one of these
+ # patterns are captured. The default is a single pattern "*", for
+ # capturing all visible variables (as determined by *info vars*).
+ #
+ proc capture {{level 1} {exclude {}} {include {*}}} {
+ if {[string is integer $level]} { incr level }
+ set env [dict create]
+ foreach pattern $include {
+ foreach name [uplevel $level [list info vars $pattern]] {
+ if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue }
+ upvar $level $name value
+ catch { dict set env $name $value } ;# no arrays
+ }
+ }
+ return $env
+ }
+
+ # nlappend dictVar keyList ?value ...?
+ #
+ # Append zero or more elements to the list value stored in the given
+ # dictionary at the path of keys specified in $keyList. If $keyList
+ # specifies a non-existent path of keys, nlappend will behave as if
+ # the path mapped to an empty list.
+ #
+ proc nlappend {dictvar keylist args} {
+ upvar 1 $dictvar dict
+ if {[info exists dict] && [dict exists $dict {*}$keylist]} {
+ set list [dict get $dict {*}$keylist]
+ }
+ lappend list {*}$args
+ dict set dict {*}$keylist $list
+ }
+
+ # invoke cmd args... --
+ #
+ # Helper procedure to invoke a callback command with arguments at
+ # the global scope. The helper ensures that proper quotation is
+ # used. The command is expected to be a list, e.g. {string equal}.
+ #
+ proc invoke {cmd args} { uplevel #0 $cmd $args }
+
+ }
diff --git a/src/bootsupport/modules_tcl8/fauxlink-0.1.1.tm b/src/bootsupport/modules_tcl8/fauxlink-0.1.1.tm
new file mode 100644
index 00000000..970e47da
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/fauxlink-0.1.1.tm
@@ -0,0 +1,568 @@
+# -*- tcl -*-
+# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt
+#
+# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
+# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+# (C) 2024
+#
+# @@ Meta Begin
+# Application fauxlink 0.1.1
+# Meta platform tcl
+# Meta license MIT
+# @@ Meta End
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+# doctools header
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+#*** !doctools
+#[manpage_begin fauxlink_module_fauxlink 0 0.1.1]
+#[copyright "2024"]
+#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}]
+#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}]
+#[require fauxlink]
+#[keywords symlink faux fake shortcut toml]
+#[description]
+#[para] A cross platform shortcut/symlink alternative.
+#[para] Unapologetically ugly - but practical in certain circumstances.
+#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as
+#[para] archiving and packaging systems.
+#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable.
+#[para] format of name #.fauxlink
+#[para] where can be empty - then the effective nominal name is the tail of the
+#[para] The file extension must be .fauxlink or .fxlnk
+#[para] The + symbol substitutes for forward-slashes.
+#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !)
+#[para] We deliberately treat higher % sequences literally.
+#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls.
+#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23
+#[para] e.g a link to a file file#A.txt in parent dir could be:
+#[para] file%23A.txt#..+file%23A.txt.fauxlink
+#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink
+#[para] The can be unrelated to the actual target
+#[para] e.g datafile.dat#..+file%23A.txt.fauxlink
+#[para] This system has no filesystem support - and must be completely application driven.
+#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform.
+#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined
+#[para] Extensions to behaviour should be added in the file as text data in Toml format,
+#[para] with custom data being under a single application-chosen table name
+#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system.
+#[para] Aside from the 2 used for delimiting (+ #)
+#[para] certain characters which might normally be allowed in filesystems are required to be encoded
+#[para] e.g space and tab are required to be %20 %09
+#[para] Others that require encoding are: * ? \ / | : ; " < >
+#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it.
+#[para] Control characters and other punctuation is optional to encode.
+#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems.
+#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX
+#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character.
+#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest
+#
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+
+#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded
+# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it.
+#Using fauxlink - a link would be:
+# "my-program-files#++server+c+Program%20Files.fauxlink"
+#If we needed the old-style literal %20 it would become
+# "my-program-files#++server+c+Program%2520Files.fauxlink"
+#
+# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser)
+# e.g
+# pfiles#file%3a++++localhost+c+Program%2520files
+# The browser will work with literal spaces too though - so it could just as well be:
+# pfiles#file%3a++++localhost+c+Program%20files
+#windows may default to using explorer.exe instead of a browser for file:// urls though
+#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to?
+#in a .url shortcut either literal space or %20 will work ie %xx values are decoded
+
+
+
+#*** !doctools
+#[section Overview]
+#[para] overview of fauxlink
+#[subsection Concepts]
+#[para] -
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+## Requirements
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+
+#*** !doctools
+#[subsection dependencies]
+#[para] packages used by fauxlink
+#[list_begin itemized]
+
+package require Tcl 8.6-
+#*** !doctools
+#[item] [package {Tcl 8.6-}]
+
+# #package require frobz
+# #*** !doctools
+# #[item] [package {frobz}]
+
+#*** !doctools
+#[list_end]
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+
+#*** !doctools
+#[section API]
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+# oo::class namespace
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+namespace eval fauxlink::class {
+ #*** !doctools
+ #[subsection {Namespace fauxlink::class}]
+ #[para] class definitions
+ if {[info commands [namespace current]::interface_sample1] eq ""} {
+ #*** !doctools
+ #[list_begin enumerated]
+
+ # oo::class create interface_sample1 {
+ # #*** !doctools
+ # #[enum] CLASS [class interface_sample1]
+ # #[list_begin definitions]
+
+ # method test {arg1} {
+ # #*** !doctools
+ # #[call class::interface_sample1 [method test] [arg arg1]]
+ # #[para] test method
+ # puts "test: $arg1"
+ # }
+
+ # #*** !doctools
+ # #[list_end] [comment {-- end definitions interface_sample1}]
+ # }
+
+ #*** !doctools
+ #[list_end] [comment {--- end class enumeration ---}]
+ }
+}
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+# Base namespace
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+namespace eval fauxlink {
+ namespace export {[a-z]*}; # Convention: export all lowercase
+
+ #todo - enforce utf-8
+
+ #literal unicode chars supported by modern filesystems - leave as is - REVIEW
+
+
+ variable encode_map
+ variable decode_map
+ #most filesystems don't allow NULL - map to empty string
+
+ #Make sure % is not in encode_map
+ set encode_map [dict create\
+ \x00 ""\
+ { } %20\
+ \t %09\
+ + %2B\
+ # %23\
+ * %2A\
+ ? %3F\
+ \\ %5C\
+ / %2F\
+ | %7C\
+ : %3A\
+ {;} %3B\
+ {"} %22\
+ < %3C\
+ > %3E\
+ ]
+ #above have some overlap with ctrl codes below.
+ #no big deal as it's a dict
+
+ #must_encode
+ # + # * ? \ / | : ; " < > \t
+ # also NUL to empty string
+
+ # also ctrl chars 01 to 1F (1..31)
+ for {set i 1} {$i < 32} {incr i} {
+ set ch [format %c $i]
+ set enc "%[format %02X $i]"
+ set enc_lower [string tolower $enc]
+ dict set encode_map $ch $enc
+ dict set decode_map $enc $ch
+ dict set decode_map $enc_lower $ch
+ }
+
+ variable must_encode
+ set must_encode [dict keys $encode_map]
+
+
+ #if they are in
+
+ #decode map doesn't include
+ # %00 (nul)
+ # %2F "/"
+ # %2f "/"
+ # %7f (del)
+ #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention.
+ #
+ set decode_map [dict merge $decode_map [dict create\
+ %09 \t\
+ %20 { }\
+ %21 "!"\
+ %22 {"}\
+ %23 "#"\
+ %24 "$"\
+ %25 "%"\
+ %26 "&"\
+ %27 "'"\
+ %28 "("\
+ %29 ")"\
+ %2A "*"\
+ %2a "*"\
+ %2B "+"\
+ %2b "+"\
+ %2C ","\
+ %2c ","\
+ %2D "-"\
+ %2d "-"\
+ %2E "."\
+ %2e "."\
+ %3A ":"\
+ %3a ":"\
+ %3B {;}\
+ %3b {;}\
+ %3D "="\
+ %3C "<"\
+ %3c "<"\
+ %3d "="\
+ %3E ">"\
+ %3e ">"\
+ %3F "?"\
+ %3f "?"\
+ %40 "@"\
+ %5B "\["\
+ %5b "\["\
+ %5C "\\"\
+ %5c "\\"\
+ %5D "\]"\
+ %5d "\]"\
+ %5E "^"\
+ %5e "^"\
+ %60 "`"\
+ %7B "{"\
+ %7b "{"\
+ %7C "|"\
+ %7c "|"\
+ %7D "}"\
+ %7d "}"\
+ %7E "~"\
+ %7e "~"\
+ ]]
+ #Don't go above 7f
+ #if we want to specify p
+
+
+ #*** !doctools
+ #[subsection {Namespace fauxlink}]
+ #[para] Core API functions for fauxlink
+ #[list_begin definitions]
+ proc Segment_mustencode_check {str} {
+ variable decode_map
+ variable encode_map ;#must_encode
+ set idx 0
+ set err ""
+ foreach ch [split $str ""] {
+ if {[dict exists $encode_map $ch]} {
+ set enc [dict get $encode_map $ch]
+ if {[dict exists $decode_map $enc]} {
+ append err " char $idx should be encoded as $enc" \n
+ } else {
+ append err " no %xx encoding available. Use %UXX if really required" \n
+ }
+ }
+ incr idx
+ }
+ return $err ;#empty string if ok
+ }
+
+ proc resolve {link} {
+ variable decode_map
+ variable encode_map
+ variable must_encode
+ set ftail [file tail $link]
+ set extension_name [string range [file extension $ftail] 1 end]
+ if {$extension_name ni [list fxlnk fauxlink]} {
+ set is_fauxlink 0
+ #we'll process anyway - but return the result wrapped
+ #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent
+ #(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens
+ # to have # characters in it)
+ #It also means if someone really wants to use the fauxlink semantics on a different file type
+ # - they can - but just have to access the results differently and take that (minor) risk.
+ #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink"
+ set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate"
+ } else {
+ set is_fauxlink 1
+ set err_extra ""
+ }
+ set linkspec [file rootname $ftail]
+ # - any # or + within the target path or name should have been uri encoded as %23 and %2b
+ if {[tcl::string::first # $linkspec] < 0} {
+ set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)"
+ append err $err_extra
+ error $err
+ }
+ #The 1st 2 parts of split on # are name and target file/dir
+ #If there are only 3 parts the 3rd part is a comment and there are no 'tags'
+ #if there are 4 parts - the 3rd part is a tagset where each tag begins with @
+ #and each subsequent part is a comment. Empty comments are stripped from the comments list
+ #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @
+ #e.g name.txt#path#@tag1@tag2#test###.fauxlink
+ #has a name, a target, 2 tags and one comment
+
+ #check namespec already has required chars encoded
+ set segments [split $linkspec #]
+ lassign $segments namespec targetspec
+ #puts stderr "-->namespec $namespec"
+ set nametest [tcl::string::map $encode_map $namespec]
+ #puts stderr "-->nametest $nametest"
+ #nothing should be changed - if there are unencoded chars that must be encoded it is an error
+ if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} {
+ set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)"
+ append err [Segment_mustencode_check $namespec]
+ append err $err_extra
+ error $err
+ }
+ #see comments below regarding 2 rounds and ordering.
+ set name [decode_unicode_escapes $namespec]
+ set name [tcl::string::map $decode_map $name]
+ #puts stderr "-->name: $name"
+
+ set targetsegment [split $targetspec +]
+ #check each + delimited part of targetspec already has required chars encoded
+ set pp 0 ;#pathpart index
+ set targetpath_parts [list]
+ foreach pathpart $targetsegment {
+ set targettest [tcl::string::map $encode_map $pathpart]
+ if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} {
+ set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)"
+ append err [Segment_mustencode_check $pathpart]
+ append err $err_extra
+ error $err
+ }
+ #2 rounds of substitution is possibly asking for trouble..
+ #We allow anything in the resultant segments anyway (as %UXXXX... allows all)
+ #so it's not so much about what can be encoded,
+ # - but it makes it harder to reason about for users
+ # In particular - if we map %XX first it makes %25 -> % substitution tricky
+ # if the user requires a literal %UXXX - they can't do %25UXXX
+ # the double sub would make it %UXXX -> somechar anyway.
+ #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere.
+ #There is still the opportunity to use things like %U00000025 followed by hex-chars
+ # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW
+ set pathpart [decode_unicode_escapes $pathpart]
+ set pathpart [tcl::string::map $decode_map $pathpart]
+ lappend targetpath_parts $pathpart
+
+ incr pp
+ }
+ set targetpath [join $targetpath_parts /]
+ if {$name eq ""} {
+ set name [lindex $targetpath_parts end]
+ }
+ #we do the same encoding checks on tags and comments to increase chances of portability
+ set tags [list]
+ set comments [list]
+ switch -- [llength $segments] {
+ 2 {
+ #no tags or comments
+ }
+ 3 {
+ #only 3 sections - last is comment - even if looks like tags
+ #to make the 3rd part a tagset, an extra # would be needed
+ set comments [list [lindex $segments 2]]
+ }
+ default {
+ set tagset [lindex $segments 2]
+ if {$tagset eq ""} {
+ #ok - no tags
+ } else {
+ if {[string first @ $tagset] != 0} {
+ set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment"
+ append err \n " - must begin with @"
+ append err $err_extra
+ error $err
+ } else {
+ set tagset [string range $tagset 1 end]
+ set rawtags [split $tagset @]
+ set tags [list]
+ foreach t $rawtags {
+ if {$t eq ""} {
+ lappend tags ""
+ } else {
+ set tagtest [tcl::string::map $encode_map $t]
+ if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} {
+ set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]"
+ append err [Segment_mustencode_check $t]
+ append err $err_extra
+ error $err
+ }
+ lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]]
+ }
+ }
+ }
+ }
+ set rawcomments [lrange $segments 3 end]
+ #set comments [lsearch -all -inline -not $comments ""]
+ set comments [list]
+ foreach c $rawcomments {
+ if {$c eq ""} {continue}
+ set commenttest [tcl::string::map $encode_map $c]
+ if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} {
+ set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]"
+ append err [Segment_mustencode_check $c]
+ append err $err_extra
+ error $err
+ }
+ lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]]
+ }
+ }
+ }
+
+ set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name]
+ if {$is_fauxlink} {
+ #standard .fxlnk or .fauxlink
+ return $data
+ } else {
+ #custom extension - or called in error on wrong type of file but happened to parse.
+ #see comments at top regarding is_fauxlink
+ #make sure no keys in common at top level.
+ return [dict create\
+ linktype $extension_name\
+ note "nonstandard extension returning nonstandard dict with result in data key"\
+ data $data\
+ ]
+ }
+ }
+ variable map
+
+ #default exclusion of / (%U2f and equivs)
+ #this would allow obfuscation of intention - when we have + for that anyway
+ proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} {
+ variable map
+ set ucstart [string first %U $str 0]
+ if {$ucstart < 0} {
+ return $str
+ }
+ set max 8
+ set map [list]
+ set strend [expr {[string length $str]-1}]
+ while {$ucstart >= 0} {
+ set s $ucstart
+ set i [expr {$s +2}] ;#skip the %U
+ set hex ""
+ while {[tcl::string::length $hex] < 8 && $i <= $strend} {
+ set in [string index $str $i]
+ if {[tcl::string::is xdigit -strict $in]} {
+ append hex $in
+ } else {
+ break
+ }
+ incr i
+ }
+ if {$hex ne ""} {
+ incr i -1
+ lappend map $s $i $hex
+ }
+ set ucstart [tcl::string::first %U $str $i]
+ }
+ set out ""
+ set lastidx -1
+ set e 0
+ foreach {s e hex} $map {
+ append out [string range $str $lastidx+1 $s-1]
+ set sub [format %c 0x$hex]
+ if {$sub in $exclusions} {
+ append out %U$hex ;#put it back
+ } else {
+ append out $sub
+ }
+ set lastidx $e
+ }
+ if {$e < [tcl::string::length $str]-1} {
+ append out [string range $str $e+1 end]
+ }
+ return $out
+ }
+ proc link_as {name target} {
+
+ }
+
+ #proc sample1 {p1 args} {
+ # #*** !doctools
+ # #[call [fun sample1] [arg p1] [opt {?option value...?}]]
+ # #[para]Description of sample1
+ # return "ok"
+ #}
+
+
+
+
+ #*** !doctools
+ #[list_end] [comment {--- end definitions namespace fauxlink ---}]
+}
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+# Secondary API namespace
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+namespace eval fauxlink::lib {
+ namespace export {[a-z]*}; # Convention: export all lowercase
+ namespace path [namespace parent]
+ #*** !doctools
+ #[subsection {Namespace fauxlink::lib}]
+ #[para] Secondary functions that are part of the API
+ #[list_begin definitions]
+
+ #proc utility1 {p1 args} {
+ # #*** !doctools
+ # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
+ # #[para]Description of utility1
+ # return 1
+ #}
+
+
+
+ #*** !doctools
+ #[list_end] [comment {--- end definitions namespace fauxlink::lib ---}]
+}
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+
+
+
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+#*** !doctools
+#[section Internal]
+namespace eval fauxlink::system {
+ #*** !doctools
+ #[subsection {Namespace fauxlink::system}]
+ #[para] Internal functions that are not part of the API
+
+
+
+}
+# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
+## Ready
+package provide fauxlink [namespace eval fauxlink {
+ variable pkg fauxlink
+ variable version
+ set version 0.1.1
+}]
+return
+
+#*** !doctools
+#[manpage_end]
+
diff --git a/src/bootsupport/modules/flagfilter-0.3.tm b/src/bootsupport/modules_tcl8/flagfilter-0.3.1.tm
similarity index 99%
rename from src/bootsupport/modules/flagfilter-0.3.tm
rename to src/bootsupport/modules_tcl8/flagfilter-0.3.1.tm
index 00f58e82..474ae8d3 100644
--- a/src/bootsupport/modules/flagfilter-0.3.tm
+++ b/src/bootsupport/modules_tcl8/flagfilter-0.3.1.tm
@@ -1,8 +1,3 @@
-#package provide flagfilter [namespace eval flagfilter {list [variable version 0.2.3]$version}]
-#package provide [set ::pkg flagfilter-0.2.3] [namespace eval [lindex [split $pkg -] 0] {list [variable version [lindex [split $pkg -] 1][set ::pkg {}]]$version}]
-#
-#package provide [lindex [set pkg {flagfilter 0.2.3}] 0] [namespace eval [lindex $pkg 0] {list [variable version [lindex $pkg 1][set pkg {}]]$version}]
-package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}]
#Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough.
# - we can't know if a flag -x --x etc is expecting a parameter or not.
@@ -2185,6 +2180,7 @@ namespace eval flagfilter {
set raise_dispatch_error_instead_of_return ""
set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"]
#todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global')
+
if {[llength $dispatch]} {
set dispatchstatuslist [list]
set dispatchresultlist [list]
@@ -2334,7 +2330,10 @@ namespace eval flagfilter {
set commandline [concat $command $matched_in_order $extraflags]
}
}
-
+
+
+
+
dict set dispatchrecord asdispatched $commandline
set dispatchresult ""
set dispatcherror ""
@@ -2711,6 +2710,8 @@ namespace eval flagfilter {
}
+package provide [lassign {flagfilter 0.3.1} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}]
+
diff --git a/src/bootsupport/modules_tcl8/funcl-0.1.tm b/src/bootsupport/modules_tcl8/funcl-0.1.tm
new file mode 100644
index 00000000..e8430fb0
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/funcl-0.1.tm
@@ -0,0 +1,325 @@
+package provide funcl [namespace eval funcl {
+ variable version
+ set version 0.1
+}]
+#funcl = function list (nested call structure)
+#
+#a basic functional composition o combinator
+#o(f,g)(x) == f(g(x))
+
+namespace eval funcl {
+
+ #from punk::pipe
+ proc arg_is_script_shaped {arg} {
+ if {[string first " " $arg] >= 0} {
+ return 1
+ } elseif {[string first \n $arg] >= 0} {
+ return 1
+ } elseif {[string first ";" $arg] >= 0} {
+ return 1
+ } elseif {[string first \t $arg] >= 0} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+
+
+ proc o args {
+ set closing [string repeat {]} [expr [llength $args]-1]]
+ set body "[join $args { [}] \$data $closing"
+ return $body
+ }
+
+ proc o_ args {
+ set body ""
+ set tails [lrepeat [llength $args] ""]
+ puts stdout "tails: $tails"
+
+ set end [lindex $args end]
+ if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
+ set endfunc [string map " $end" {uplevel 1 [list if 1 ]}]
+ } else {
+ set endfunc $end
+ }
+ if {[llength $args] == 1} {
+ return $endfunc
+ }
+
+ set wrap { [}
+ append wrap $endfunc
+ append wrap { ]}
+
+ set i 0
+ foreach cmdlist [lrange $args 0 end-1] {
+ set is_script 0
+ if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
+ set is_script 1
+ set script [lindex $cmdlist 0]
+ }
+ set t ""
+ if {$i > 0} {
+ append body { [}
+ }
+ set posn [lsearch $cmdlist _]
+ if {$posn <= 0} {
+ append body $cmdlist
+ if {$i == ([llength $args]-2)} {
+ append body " $wrap"
+ }
+ #if {$i == [expr {[llength $args] -2}]} {
+ # #append body " \$data"
+ # append body " $wrap"
+ #}
+ if {$i > 0} {
+ set t {]}
+ }
+ } else {
+ append body [lrange $cmdlist 0 $posn-1]
+ if {$i == ([llength $args] -2)} {
+ #append body " \$data"
+ append body " $wrap"
+ }
+ set t [lrange $cmdlist $posn+1 end]
+ if {$i > 0} {
+ append t { ]}
+ }
+ }
+ lset tails $i $t
+ incr i
+ }
+ append body [join [lreverse $tails] " "]
+ puts stdout "tails: $tails"
+
+ return $body
+ }
+
+ #review - consider _call -- if count > 1 then they must all be callable cmdlists(?)
+ # what does it mean to have additional _fn wrapper with no other elements? (no actual function)
+ #e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}}
+ # what type indicates running subtrees in parallel vs sequentially?
+ # any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc.
+ #
+ #
+ # accept or return a funcl (or funcltree if multiple funcls in one commandlist)
+ # also accept/return a call - return empty list if passed a call
+ proc next_funcl {funcl_or_tree} {
+ if {[lindex $funcl_or_tree 0] eq "_call"} {
+ return [list]
+ }
+ if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} {
+ set funcl $funcl_or_tree
+ } else {
+ error "funcltree not implemented"
+ }
+
+
+ set count [lindex $funcl 1]
+ if {$count == 0} {
+ #null funcl.. what is it? metadata/placeholder?
+ return $funcl
+ }
+ set indices [lrange $funcl 2 [expr {1 + $count}]]
+ set i 0
+ foreach idx $indices {
+ if {$i > 0} {
+ #todo - return a funcltree
+ error "multi funcl not implemented"
+ }
+ set next [lindex $funcl $idx]
+ incr i
+ }
+
+ return $next
+
+ }
+
+ #convert a funcl to a tcl script
+ proc funcl_script {funcl} {
+ if {![llength $funcl]} {
+ return ""
+ }
+ set body ""
+ set tails [list]
+
+ set type [lindex $funcl 0]
+ if {$type ni [list "_fn" "_call"]} {
+ #todo - handle funcltree
+ error "type $type not implemented"
+ }
+
+
+ #only count of 1 with index 3 supported(?)
+ if {$type eq "_call"} {
+ #leaf
+ set cmdlist [lindex $funcl 3]
+ return $cmdlist
+ }
+
+ #we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times.
+ #by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?)
+ # we would still need to maintain state to stitch it back together once returned from a subtree..
+ # ie multiple tail parts
+ set count [lindex $funcl 1]
+
+ if {$count == 1} {
+ set idx [lindex $funcl 2]
+ if {$idx == 3} {
+ set cmdlist_pre [list]
+ } else {
+ set cmdlist_pre [lrange $funcl 3 $idx-1]
+ }
+ append body $cmdlist_pre
+ set t [lrange $funcl $idx+1 end]
+ lappend tails $t
+ } else {
+ #??
+ error "funcl_script branching not yet supported"
+ }
+
+
+ set get_next 1
+ set i 1
+ while {$get_next} {
+ set funcl [next_funcl $funcl]
+ if {![llength $funcl]} {
+ set get_next 0
+ }
+ lassign $funcl type count idx ;#todo support count > 1
+ if {$type eq "_call"} {
+ set get_next 0
+ }
+ set t ""
+ if {$type eq "_call"} {
+ append body { [}
+ append body [lindex $funcl $idx]
+ append body { ]}
+ } else {
+ append body { [}
+ if {$idx == 3} {
+ set cmdlist_pre [list]
+ } else {
+ set cmdlist_pre [lrange $funcl 3 $idx-1]
+ }
+ append body $cmdlist_pre
+ set t [lrange $funcl $idx+1 end]
+ lappend tails $t
+ lappend tails { ]}
+ }
+ incr i
+ }
+ append body [join [lreverse $tails] " "]
+ #puts stdout "tails: $tails"
+
+ return $body
+ }
+
+
+ interp alias "" o_of "" funcl::o_of_n 1
+
+ #o_of_n
+ #tcl list rep o combinator
+ #
+ # can take lists of ordinary commandlists, scripts and funcls
+ # _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg)
+ # _fn 0 indicates next item is an unwrapped commandlist (terminal command)
+ #
+ #o_of is equivalent to o_of_n 1 (1 argument o combinator)
+ #last n args are passed to the prior function
+ #e.g for n=1 f a b = f(a(b))
+ #e.g for n=2, e f a b = e(f(a b))
+ proc o_of_n {n args} {
+ puts stdout "o_of_n '$args'"
+ if {$n != 1} {
+ error "o_of_n only implemented for 1 sub-funcl"
+ }
+ set comp [list] ;#composition list
+ set end [lindex $args end]
+ if {[lindex $end 0] in {_fn _call}]} {
+ #is_funcl
+ set endfunc [lindex $args end]
+ } else {
+ if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
+ #set endfunc [string map [list $end] {uplevel 1 [list if 1 ]}]
+ set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]]
+ } else {
+ set endfunc [list _call 1 3 [list {*}$end]]
+ }
+ }
+
+ if {[llength $args] == 1} {
+ return $endfunc
+ }
+ set comp $endfunc
+ set revlist [lreverse [lrange $args 0 end-1]]
+ foreach cmdlist $revlist {
+ puts stderr "o_of_n >>-- $cmdlist"
+ if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} {
+ set is_script 1
+ set script [lindex $cmdlist 0]
+ set arglist [list data]
+
+ set comp [list _fn 1 6 call_script $script $arglist $comp]
+ } else {
+ set posn1 [expr {[llength $cmdlist] + 2 + $n}]
+ set comp [list _fn $n $posn1 {*}$cmdlist $comp]
+ }
+ }
+ return $comp
+ }
+ proc call_script {script argnames args} {
+ uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]]
+ }
+ proc funcl_script_test {scr} {
+ do_funcl_script_test $scr
+ }
+ proc do_funcl_script_test {scr} {
+ #set j "in do_funcl_script_test"
+ #set data "xxx"
+ #puts '$scr'
+ if 1 $scr
+ }
+
+ #standard o_ with no script-handling
+ proc o_plain args {
+ set body ""
+ set i 0
+ set tails [lrepeat [llength $args] ""]
+ #puts stdout "tails: $tails"
+ foreach cmdlist $args {
+ set t ""
+ if {$i > 0} {
+ append body { [}
+ }
+ set posn [lsearch $cmdlist _]
+ if {$posn <= 0} {
+ append body $cmdlist
+ if {$i == ([llength $args] -1)} {
+ append body " \$data"
+ }
+ if {$i > 0} {
+ set t {]}
+ }
+ } else {
+ append body [lrange $cmdlist 0 $posn-1]
+ if {$i == ([llength $args] -1)} {
+ append body " \$data"
+ }
+ set t [lrange $cmdlist $posn+1 end]
+ if {$i > 0} {
+ append t { ]}
+ }
+ }
+ lset tails $i $t
+ incr i
+ }
+ append body [join [lreverse $tails] " "]
+ #puts stdout "tails: $tails"
+
+ return $body
+ }
+ #timings suggest no faster to split out the first item from the cmdlist loop
+}
+
+
+
diff --git a/src/bootsupport/modules_tcl8/http-2.10b1.tm b/src/bootsupport/modules_tcl8/http-2.10b1.tm
new file mode 100644
index 00000000..6c3c068c
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/http-2.10b1.tm
@@ -0,0 +1,5457 @@
+# http.tcl --
+#
+# Client-side HTTP for GET, POST, and HEAD commands. These routines can
+# be used in untrusted code that uses the Safesock security policy.
+# These procedures use a callback interface to avoid using vwait, which
+# is not defined in the safe base.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.6-
+# Keep this in sync with pkgIndex.tcl and with the install directories in
+# Makefiles
+package provide http 2.10b1
+
+namespace eval http {
+ # Allow resourcing to not clobber existing data
+
+ variable http
+ if {![info exists http]} {
+ array set http {
+ -accept */*
+ -cookiejar {}
+ -pipeline 1
+ -postfresh 0
+ -proxyhost {}
+ -proxyport {}
+ -proxyfilter http::ProxyRequired
+ -proxynot {}
+ -proxyauth {}
+ -repost 0
+ -threadlevel 0
+ -urlencoding utf-8
+ -zip 1
+ }
+ # We need a useragent string of this style or various servers will
+ # refuse to send us compressed content even when we ask for it. This
+ # follows the de-facto layout of user-agent strings in current browsers.
+ # Safe interpreters do not have ::tcl_platform(os) or
+ # ::tcl_platform(osVersion).
+ if {[interp issafe]} {
+ set http(-useragent) "Mozilla/5.0\
+ (Windows; U;\
+ Windows NT 10.0)\
+ http/[package provide http] Tcl/[package provide Tcl]"
+ } else {
+ set http(-useragent) "Mozilla/5.0\
+ ([string totitle $::tcl_platform(platform)]; U;\
+ $::tcl_platform(os) $::tcl_platform(osVersion))\
+ http/[package provide http] Tcl/[package provide Tcl]"
+ }
+ }
+
+ proc init {} {
+ # Set up the map for quoting chars. RFC3986 Section 2.3 say percent
+ # encode all except: "... percent-encoded octets in the ranges of
+ # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period
+ # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI
+ # producers ..."
+ for {set i 0} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match {[-._~a-zA-Z0-9]} $c]} {
+ set map($c) %[format %.2X $i]
+ }
+ }
+ # These are handled specially
+ set map(\n) %0D%0A
+ variable formMap [array get map]
+
+ # Create a map for HTTP/1.1 open sockets
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+ if {[info exists socketMapping]} {
+ # Close open sockets on re-init. Do not permit retries.
+ foreach {url sock} [array get socketMapping] {
+ unset -nocomplain socketClosing($url)
+ unset -nocomplain socketPlayCmd($url)
+ CloseSocket $sock
+ }
+ }
+
+ # CloseSocket should have unset the socket* arrays, one element at
+ # a time. Now unset anything that was overlooked.
+ # Traces on "unset socketRdState(*)" will call CancelReadPipeline and
+ # cancel any queued responses.
+ # Traces on "unset socketWrState(*)" will call CancelWritePipeline and
+ # cancel any queued requests.
+ array unset socketMapping
+ array unset socketRdState
+ array unset socketWrState
+ array unset socketRdQueue
+ array unset socketWrQueue
+ array unset socketPhQueue
+ array unset socketClosing
+ array unset socketPlayCmd
+ array unset socketCoEvent
+ array unset socketProxyId
+ array set socketMapping {}
+ array set socketRdState {}
+ array set socketWrState {}
+ array set socketRdQueue {}
+ array set socketWrQueue {}
+ array set socketPhQueue {}
+ array set socketClosing {}
+ array set socketPlayCmd {}
+ array set socketCoEvent {}
+ array set socketProxyId {}
+ return
+ }
+ init
+
+ variable urlTypes
+ if {![info exists urlTypes]} {
+ set urlTypes(http) [list 80 ::http::socket]
+ }
+
+ variable encodings [string tolower [encoding names]]
+ # This can be changed, but iso8859-1 is the RFC standard.
+ variable defaultCharset
+ if {![info exists defaultCharset]} {
+ set defaultCharset "iso8859-1"
+ }
+
+ # Force RFC 3986 strictness in geturl url verification?
+ variable strict
+ if {![info exists strict]} {
+ set strict 1
+ }
+
+ # Let user control default keepalive for compatibility
+ variable defaultKeepalive
+ if {![info exists defaultKeepalive]} {
+ set defaultKeepalive 0
+ }
+
+ # Regular expression used to parse cookies
+ variable CookieRE {(?x) # EXPANDED SYNTAX
+ \s* # Ignore leading spaces
+ ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name
+ = # LITERAL: Equal sign
+ ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value
+ (?:
+ \s* ; \s* # LITERAL: semicolon
+ ([^\u0000]+) # Match the options
+ )?
+ }
+
+ variable TmpSockCounter 0
+ variable ThreadCounter 0
+
+ variable reasonDict [dict create {*}{
+ 100 Continue
+ 101 {Switching Protocols}
+ 102 Processing
+ 103 {Early Hints}
+ 200 OK
+ 201 Created
+ 202 Accepted
+ 203 {Non-Authoritative Information}
+ 204 {No Content}
+ 205 {Reset Content}
+ 206 {Partial Content}
+ 207 Multi-Status
+ 208 {Already Reported}
+ 226 {IM Used}
+ 300 {Multiple Choices}
+ 301 {Moved Permanently}
+ 302 Found
+ 303 {See Other}
+ 304 {Not Modified}
+ 305 {Use Proxy}
+ 306 (Unused)
+ 307 {Temporary Redirect}
+ 308 {Permanent Redirect}
+ 400 {Bad Request}
+ 401 Unauthorized
+ 402 {Payment Required}
+ 403 Forbidden
+ 404 {Not Found}
+ 405 {Method Not Allowed}
+ 406 {Not Acceptable}
+ 407 {Proxy Authentication Required}
+ 408 {Request Timeout}
+ 409 Conflict
+ 410 Gone
+ 411 {Length Required}
+ 412 {Precondition Failed}
+ 413 {Content Too Large}
+ 414 {URI Too Long}
+ 415 {Unsupported Media Type}
+ 416 {Range Not Satisfiable}
+ 417 {Expectation Failed}
+ 418 (Unused)
+ 421 {Misdirected Request}
+ 422 {Unprocessable Content}
+ 423 Locked
+ 424 {Failed Dependency}
+ 425 {Too Early}
+ 426 {Upgrade Required}
+ 428 {Precondition Required}
+ 429 {Too Many Requests}
+ 431 {Request Header Fields Too Large}
+ 451 {Unavailable For Legal Reasons}
+ 500 {Internal Server Error}
+ 501 {Not Implemented}
+ 502 {Bad Gateway}
+ 503 {Service Unavailable}
+ 504 {Gateway Timeout}
+ 505 {HTTP Version Not Supported}
+ 506 {Variant Also Negotiates}
+ 507 {Insufficient Storage}
+ 508 {Loop Detected}
+ 510 {Not Extended (OBSOLETED)}
+ 511 {Network Authentication Required}
+ }]
+
+ variable failedProxyValues {
+ binary
+ body
+ charset
+ coding
+ connection
+ connectionRespFlag
+ currentsize
+ host
+ http
+ httpResponse
+ meta
+ method
+ querylength
+ queryoffset
+ reasonPhrase
+ requestHeaders
+ requestLine
+ responseCode
+ state
+ status
+ tid
+ totalsize
+ transfer
+ type
+ }
+
+ namespace export geturl config reset wait formatQuery postError quoteString
+ namespace export register unregister registerError
+ namespace export requestLine requestHeaders requestHeaderValue
+ namespace export responseLine responseHeaders responseHeaderValue
+ namespace export responseCode responseBody responseInfo reasonPhrase
+ # - Legacy aliases, were never exported:
+ # data, code, mapReply, meta, ncode
+ # - Callable from outside (e.g. from TLS) by fully-qualified name, but
+ # not exported:
+ # socket
+ # - Useful, but never exported (and likely to have naming collisions):
+ # size, status, cleanup, error, init
+ # Comments suggest that "init" can be used for re-initialisation,
+ # although the command is undocumented.
+ # - Never exported, renamed from lower-case names:
+ # GetTextLine, MakeTransformationChunked.
+}
+
+# http::Log --
+#
+# Debugging output -- define this to observe HTTP/1.1 socket usage.
+# Should echo any args received.
+#
+# Arguments:
+# msg Message to output
+#
+if {[info command http::Log] eq {}} {proc http::Log {args} {}}
+
+# http::register --
+#
+# See documentation for details.
+#
+# Arguments:
+# proto URL protocol prefix, e.g. https
+# port Default port for protocol
+# command Command to use to create socket
+# Results:
+# list of port and command that was registered.
+
+proc http::register {proto port command} {
+ variable urlTypes
+ set urlTypes([string tolower $proto]) [list $port $command]
+}
+
+# http::unregister --
+#
+# Unregisters URL protocol handler
+#
+# Arguments:
+# proto URL protocol prefix, e.g. https
+# Results:
+# list of port and command that was unregistered.
+
+proc http::unregister {proto} {
+ variable urlTypes
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
+ return -code error "unsupported url type \"$proto\""
+ }
+ set old $urlTypes($lower)
+ unset urlTypes($lower)
+ return $old
+}
+
+# http::config --
+#
+# See documentation for details.
+#
+# Arguments:
+# args Options parsed by the procedure.
+# Results:
+# TODO
+
+proc http::config {args} {
+ variable http
+ set options [lsort [array names http -*]]
+ set usage [join $options ", "]
+ if {[llength $args] == 0} {
+ set result {}
+ foreach name $options {
+ lappend result $name $http($name)
+ }
+ return $result
+ }
+ set options [string map {- ""} $options]
+ set pat ^-(?:[join $options |])$
+ if {[llength $args] == 1} {
+ set flag [lindex $args 0]
+ if {![regexp -- $pat $flag]} {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ return $http($flag)
+ } elseif {[llength $args] % 2} {
+ return -code error "If more than one argument is supplied, the\
+ number of arguments must be even"
+ } else {
+ foreach {flag value} $args {
+ if {![regexp -- $pat $flag]} {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} {
+ return -code error {Option -threadlevel must be 0, 1 or 2}
+ }
+ set http($flag) $value
+ }
+ return
+ }
+}
+
+# ------------------------------------------------------------------------------
+# Proc http::reasonPhrase
+# ------------------------------------------------------------------------------
+# Command to return the IANA-recommended "reason phrase" for a HTTP Status Code.
+# Information obtained from:
+# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml
+#
+# Arguments:
+# code - A valid HTTP Status Code (integer from 100 to 599)
+#
+# Return Value: the reason phrase
+# ------------------------------------------------------------------------------
+
+proc http::reasonPhrase {code} {
+ variable reasonDict
+ if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
+ set msg {argument must be a three-digit integer from 100 to 599}
+ return -code error $msg
+ }
+ if {[dict exists $reasonDict $code]} {
+ set reason [dict get $reasonDict $code]
+ } else {
+ set reason Unassigned
+ }
+ return $reason
+}
+
+# http::Finish --
+#
+# Clean up the socket and eval close time callbacks
+#
+# Arguments:
+# token Connection token.
+# errormsg (optional) If set, forces status to error.
+# skipCB (optional) If set, don't call the -command callback. This
+# is useful when geturl wants to throw an exception instead
+# of calling the callback. That way, the same error isn't
+# reported to two places.
+#
+# Side Effects:
+# May close the socket.
+
+proc http::Finish {token {errormsg ""} {skipCB 0}} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+ set closeQueue 0
+ if {$errormsg ne ""} {
+ set state(error) [list $errormsg $errorInfo $errorCode]
+ set state(status) "error"
+ }
+ if {[info commands ${token}--EventCoroutine] ne {}} {
+ rename ${token}--EventCoroutine {}
+ }
+ if {[info commands ${token}--SocketCoroutine] ne {}} {
+ rename ${token}--SocketCoroutine {}
+ }
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (Finish)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
+ }
+
+ # Is this an upgrade request/response?
+ set upgradeResponse \
+ [expr { [info exists state(upgradeRequest)]
+ && $state(upgradeRequest)
+ && [info exists state(http)]
+ && ([ncode $token] eq {101})
+ && [info exists state(connection)]
+ && ("upgrade" in $state(connection))
+ && [info exists state(upgrade)]
+ && ("" ne $state(upgrade))
+ }]
+
+ if { ($state(status) eq "timeout")
+ || ($state(status) eq "error")
+ || ($state(status) eq "eof")
+ } {
+ set closeQueue 1
+ set connId $state(socketinfo)
+ if {[info exists state(sock)]} {
+ set sock $state(sock)
+ CloseSocket $state(sock) $token
+ } else {
+ # When opening the socket and calling http::reset
+ # immediately, the socket may not yet exist.
+ # Test http-4.11 may come here.
+ }
+ if {$state(tid) ne {}} {
+ # When opening the socket in a thread, and calling http::reset
+ # immediately, the thread may still exist.
+ # Test http-4.11 may come here.
+ thread::release $state(tid)
+ set state(tid) {}
+ } else {
+ }
+ } elseif {$upgradeResponse} {
+ # Special handling for an upgrade request/response.
+ # - geturl ensures that this is not a "persistent" socket used for
+ # multiple HTTP requests, so a call to KeepSocket is not needed.
+ # - Leave socket open, so a call to CloseSocket is not needed either.
+ # - Remove fileevent bindings. The caller will set its own bindings.
+ # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND
+ # PASSED TO http::geturl AS -command callback.
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ } elseif {
+ ([info exists state(-keepalive)] && !$state(-keepalive))
+ || ([info exists state(connection)] && ("close" in $state(connection)))
+ } {
+ set closeQueue 1
+ set connId $state(socketinfo)
+ if {[info exists state(sock)]} {
+ set sock $state(sock)
+ CloseSocket $state(sock) $token
+ } else {
+ # When opening the socket and calling http::reset
+ # immediately, the socket may not yet exist.
+ # Test http-4.11 may come here.
+ }
+ } elseif {
+ ([info exists state(-keepalive)] && $state(-keepalive))
+ && ([info exists state(connection)] && ("close" ni $state(connection)))
+ } {
+ KeepSocket $token
+ }
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+ if {[info exists state(-command)] && (!$skipCB)
+ && (![info exists state(done-command-cb)])} {
+ set state(done-command-cb) yes
+ if { [catch {namespace eval :: $state(-command) $token} err]
+ && ($errormsg eq "")
+ } {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+
+ if { $closeQueue
+ && [info exists socketMapping($connId)]
+ && ($socketMapping($connId) eq $sock)
+ } {
+ http::CloseQueuedQueries $connId $token
+ # This calls Unset. Other cases do not need the call.
+ }
+ return
+}
+
+# http::KeepSocket -
+#
+# Keep a socket in the persistent sockets table and connect it to its next
+# queued task if possible. Otherwise leave it idle and ready for its next
+# use.
+#
+# If $socketClosing(*), then ("close" in $state(connection)) and therefore
+# this command will not be called by Finish.
+#
+# Arguments:
+# token Connection token.
+
+proc http::KeepSocket {token} {
+ variable http
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ # Keep this socket open for another request ("Keep-Alive").
+ # React if the server half-closes the socket.
+ # Discussion is in http::geturl.
+ catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]}
+
+ # The line below should not be changed in production code.
+ # It is edited by the test suite.
+ set TEST_EOF 0
+ if {$TEST_EOF} {
+ # ONLY for testing reaction to server eof.
+ # No server timeouts will be caught.
+ catch {fileevent $state(sock) readable {}}
+ }
+
+ if { [info exists state(socketinfo)]
+ && [info exists socketMapping($state(socketinfo))]
+ } {
+ set connId $state(socketinfo)
+ # The value "Rready" is set only here.
+ set socketRdState($connId) Rready
+
+ if { $state(-pipeline)
+ && [info exists socketRdQueue($connId)]
+ && [llength $socketRdQueue($connId)]
+ } {
+ # The usual case for pipelined responses - if another response is
+ # queued, arrange to read it.
+ set token3 [lindex $socketRdQueue($connId) 0]
+ set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
+
+ #Log pipelined, GRANT read access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ ReceiveResponse $token3
+
+ # Other pipelined cases.
+ # - The test above ensures that, for the pipelined cases in the two
+ # tests below, the read queue is empty.
+ # - In those two tests, check whether the next write will be
+ # nonpipeline.
+ } elseif {
+ $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "peNding")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && (![set token3 [lindex $socketWrQueue($connId) 0]
+ set ${token3}(-pipeline)
+ ]
+ )
+ } {
+ # This case:
+ # - Now it the time to run the "pending" request.
+ # - The next token in the write queue is nonpipeline, and
+ # socketWrState has been marked "pending" (in
+ # http::NextPipelinedWrite or http::geturl) so a new pipelined
+ # request cannot jump the queue.
+ #
+ # Tests:
+ # - In this case the read queue (tested above) is empty and this
+ # "pending" write token is in front of the rest of the write
+ # queue.
+ # - The write state is not Wready and therefore appears to be busy,
+ # but because it is "pending" we know that it is reserved for the
+ # first item in the write queue, a non-pipelined request that is
+ # waiting for the read queue to empty. That has now happened: so
+ # give that request read and write access.
+ set conn [set ${token3}(connArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+ } elseif {
+ $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "peNding")
+
+ } {
+ # Should not come here. The second block in the previous "elseif"
+ # test should be tautologous (but was needed in an earlier
+ # implementation) and will be removed after testing.
+ # If we get here, the value "pending" was assigned in error.
+ # This error would block the queue for ever.
+ Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token
+
+ } elseif {
+ $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "Wready")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && (![set token3 [lindex $socketWrQueue($connId) 0]
+ set ${token3}(-pipeline)
+ ]
+ )
+ } {
+ # This case:
+ # - The next token in the write queue is nonpipeline, and
+ # socketWrState is Wready. Get the next event from socketWrQueue.
+ # Tests:
+ # - In this case the read state (tested above) is Rready and the
+ # write state (tested here) is Wready - there is no "pending"
+ # request.
+ # Code:
+ # - The code is the same as the code below for the nonpipelined
+ # case with a queued request.
+ set conn [set ${token3}(connArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+ } elseif {
+ (!$state(-pipeline))
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && ("close" ni $state(connection))
+ } {
+ # If not pipelined, (socketRdState eq Rready) tells us that we are
+ # ready for the next write - there is no need to check
+ # socketWrState. Write the next request, if one is waiting.
+ # If the next request is pipelined, it receives premature read
+ # access to the socket. This is not a problem.
+ set token3 [lindex $socketWrQueue($connId) 0]
+ set conn [set ${token3}(connArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
+
+ } elseif {(!$state(-pipeline))} {
+ set socketWrState($connId) Wready
+ # Rready and Wready and idle: nothing to do.
+ }
+
+ } else {
+ CloseSocket $state(sock) $token
+ # There is no socketMapping($state(socketinfo)), so it does not matter
+ # that CloseQueuedQueries is not called.
+ }
+ return
+}
+
+# http::CheckEof -
+#
+# Read from a socket and close it if eof.
+# The command is bound to "fileevent readable" on an idle socket, and
+# "eof" is the only event that should trigger the binding, occurring when
+# the server times out and half-closes the socket.
+#
+# A read is necessary so that [eof] gives a meaningful result.
+# Any bytes sent are junk (or a bug).
+
+proc http::CheckEof {sock} {
+ set junk [read $sock]
+ set n [string length $junk]
+ if {$n} {
+ Log "WARNING: $n bytes received but no HTTP request sent"
+ }
+
+ if {[catch {eof $sock} res] || $res} {
+ # The server has half-closed the socket.
+ # If a new write has started, its transaction will fail and
+ # will then be error-handled.
+ CloseSocket $sock
+ }
+ return
+}
+
+# http::CloseSocket -
+#
+# Close a socket and remove it from the persistent sockets table. If
+# possible an http token is included here but when we are called from a
+# fileevent on remote closure we need to find the correct entry - hence
+# the "else" block of the first "if" command.
+
+proc http::CloseSocket {s {token {}}} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ set tk [namespace tail $token]
+
+ catch {fileevent $s readable {}}
+ set connId {}
+ if {$token ne ""} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(socketinfo)]} {
+ set connId $state(socketinfo)
+ }
+ } else {
+ set map [array get socketMapping]
+ set ndx [lsearch -exact $map $s]
+ if {$ndx >= 0} {
+ incr ndx -1
+ set connId [lindex $map $ndx]
+ }
+ }
+ if { ($connId ne {})
+ && [info exists socketMapping($connId)]
+ && ($socketMapping($connId) eq $s)
+ } {
+ Log "Closing connection $connId (sock $socketMapping($connId))"
+ if {[catch {close $socketMapping($connId)} err]} {
+ Log "Error closing connection: $err"
+ } else {
+ }
+ if {$token eq {}} {
+ # Cases with a non-empty token are handled by Finish, so the tokens
+ # are finished in connection order.
+ http::CloseQueuedQueries $connId
+ } else {
+ }
+ } else {
+ Log "Closing socket $s (no connection info)"
+ if {[catch {close $s} err]} {
+ Log "Error closing socket: $err"
+ } else {
+ }
+ }
+ return
+}
+
+# http::CloseQueuedQueries
+#
+# connId - identifier "domain:port" for the connection
+# token - (optional) used only for logging
+#
+# Called from http::CloseSocket and http::Finish, after a connection is closed,
+# to clear the read and write queues if this has not already been done.
+
+proc http::CloseQueuedQueries {connId {token {}}} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ ##Log CloseQueuedQueries $connId $token
+ if {![info exists socketMapping($connId)]} {
+ # Command has already been called.
+ # Don't come here again - especially recursively.
+ return
+ }
+
+ # Used only for logging.
+ if {$token eq {}} {
+ set tk {}
+ } else {
+ set tk [namespace tail $token]
+ }
+
+ if { [info exists socketPlayCmd($connId)]
+ && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}})
+ } {
+ # Before unsetting, there is some unfinished business.
+ # - If the server sent "Connection: close", we have stored the command
+ # for retrying any queued requests in socketPlayCmd, so copy that
+ # value for execution below. socketClosing(*) was also set.
+ # - Also clear the queues to prevent calls to Finish that would set the
+ # state for the requests that will be retried to "finished with error
+ # status".
+ # - At this stage socketPhQueue is empty.
+ set unfinished $socketPlayCmd($connId)
+ set socketRdQueue($connId) {}
+ set socketWrQueue($connId) {}
+ } else {
+ set unfinished {}
+ }
+
+ Unset $connId
+
+ if {$unfinished ne {}} {
+ Log ^R$tk Any unfinished transactions (excluding $token) failed \
+ - token $token - unfinished $unfinished
+ {*}$unfinished
+ # Calls ReplayIfClose.
+ }
+ return
+}
+
+# http::Unset
+#
+# The trace on "unset socketRdState(*)" will call CancelReadPipeline
+# and cancel any queued responses.
+# The trace on "unset socketWrState(*)" will call CancelWritePipeline
+# and cancel any queued requests.
+
+proc http::Unset {connId} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ unset socketMapping($connId)
+ unset socketRdState($connId)
+ unset socketWrState($connId)
+ unset -nocomplain socketRdQueue($connId)
+ unset -nocomplain socketWrQueue($connId)
+ unset -nocomplain socketClosing($connId)
+ unset -nocomplain socketPlayCmd($connId)
+ unset -nocomplain socketProxyId($connId)
+ return
+}
+
+# http::reset --
+#
+# See documentation for details.
+#
+# Arguments:
+# token Connection token.
+# why Status info.
+#
+# Side Effects:
+# See Finish
+
+proc http::reset {token {why reset}} {
+ variable $token
+ upvar 0 $token state
+ set state(status) $why
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ Finish $token
+ if {[info exists state(error)]} {
+ set errorlist $state(error)
+ unset state
+ eval ::error $errorlist
+ # i.e. error msg errorInfo errorCode
+ }
+ return
+}
+
+# http::geturl --
+#
+# Establishes a connection to a remote url via http.
+#
+# Arguments:
+# url The http URL to goget.
+# args Option value pairs. Valid options include:
+# -blocksize, -validate, -headers, -timeout
+# Results:
+# Returns a token for this connection. This token is the name of an
+# array that the caller should unset to garbage collect the state.
+
+proc http::geturl {url args} {
+ variable urlTypes
+
+ # - If ::tls::socketCmd has its default value "::socket", change it to the
+ # new value ::http::socketForTls.
+ # - If the old value is different, then it has been modified either by the
+ # script or by the Tcl installation, and replaced by a new command. The
+ # script or installation that modified ::tls::socketCmd is also
+ # responsible for integrating ::http::socketForTls into its own "new"
+ # command, if it wishes to do so.
+ # - Commands that open a socket:
+ # - ::socket - basic
+ # - ::http::socket - can use a thread to avoid blockage by slow DNS
+ # lookup. See http::config option -threadlevel.
+ # - ::http::socketForTls - as ::http::socket, but can also open a socket
+ # for HTTPS/TLS through a proxy.
+
+ if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
+ set ::tls::socketCmd ::http::socketForTls
+ }
+
+ set token [CreateToken $url {*}$args]
+ variable $token
+ upvar 0 $token state
+
+ AsyncTransaction $token
+
+ # --------------------------------------------------------------------------
+ # Synchronous Call to http::geturl
+ # --------------------------------------------------------------------------
+ # - If the call to http::geturl is asynchronous, it is now complete (apart
+ # from delivering the return value).
+ # - If the call to http::geturl is synchronous, the command must now wait
+ # for the HTTP transaction to be completed. The call to http::wait uses
+ # vwait, which may be inappropriate if the caller makes other HTTP
+ # requests in the background.
+ # --------------------------------------------------------------------------
+
+ if {![info exists state(-command)]} {
+ # geturl does EVERYTHING asynchronously, so if the user
+ # calls it synchronously, we just do a wait here.
+ http::wait $token
+
+ if {![info exists state]} {
+ # If we timed out then Finish has been called and the users
+ # command callback may have cleaned up the token. If so we end up
+ # here with nothing left to do.
+ return $token
+ } elseif {$state(status) eq "error"} {
+ # Something went wrong while trying to establish the connection.
+ # Clean up after events and such, but DON'T call the command
+ # callback (if available) because we're going to throw an
+ # exception from here instead.
+ set err [lindex $state(error) 0]
+ cleanup $token
+ return -code error $err
+ }
+ }
+
+ return $token
+}
+
+# ------------------------------------------------------------------------------
+# Proc http::CreateToken
+# ------------------------------------------------------------------------------
+# Command to convert arguments into an initialised request token.
+# The return value is the variable name of the token.
+#
+# Other effects:
+# - Sets ::http::http(usingThread) if not already done
+# - Sets ::http::http(uid) if not already done
+# - Increments ::http::http(uid)
+# - May increment ::http::TmpSockCounter
+# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1
+# request is appended to the queue of a persistent socket that is already
+# scheduled to close.
+# This also sets state(alreadyQueued) to 1.
+# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the
+# queue of a persistent socket that has not yet been created (and is therefore
+# represented by a placeholder).
+# This also sets state(ReusingPlaceholder) to 1.
+# ------------------------------------------------------------------------------
+
+proc http::CreateToken {url args} {
+ variable http
+ variable urlTypes
+ variable defaultCharset
+ variable defaultKeepalive
+ variable strict
+ variable TmpSockCounter
+
+ # Initialize the state variable, an array. We'll return the name of this
+ # array as the token for the transaction.
+
+ if {![info exists http(usingThread)]} {
+ set http(usingThread) 0
+ }
+ if {![info exists http(uid)]} {
+ set http(uid) 0
+ }
+ set token [namespace current]::[incr http(uid)]
+ ##Log Starting http::geturl - token $token
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ reset $token
+ Log ^A$tk URL $url - token $token
+
+ # Process command options.
+
+ array set state {
+ -binary false
+ -blocksize 8192
+ -queryblocksize 8192
+ -validate 0
+ -headers {}
+ -timeout 0
+ -type application/x-www-form-urlencoded
+ -queryprogress {}
+ -protocol 1.1
+ -guesstype 0
+ binary 0
+ state created
+ meta {}
+ method {}
+ coding {}
+ currentsize 0
+ totalsize 0
+ querylength 0
+ queryoffset 0
+ type application/octet-stream
+ body {}
+ status ""
+ http ""
+ httpResponse {}
+ responseCode {}
+ reasonPhrase {}
+ connection keep-alive
+ tid {}
+ requestHeaders {}
+ requestLine {}
+ transfer {}
+ proxyUsed none
+ }
+ set state(-keepalive) $defaultKeepalive
+ set state(-strict) $strict
+ # These flags have their types verified [Bug 811170]
+ array set type {
+ -binary boolean
+ -blocksize integer
+ -guesstype boolean
+ -queryblocksize integer
+ -strict boolean
+ -timeout integer
+ -validate boolean
+ -headers list
+ }
+ set state(charset) $defaultCharset
+ set options {
+ -binary -blocksize -channel -command -guesstype -handler -headers -keepalive
+ -method -myaddr -progress -protocol -query -queryblocksize
+ -querychannel -queryprogress -strict -timeout -type -validate
+ }
+ set usage [join [lsort $options] ", "]
+ set options [string map {- ""} $options]
+ set pat ^-(?:[join $options |])$
+ foreach {flag value} $args {
+ if {[regexp -- $pat $flag]} {
+ # Validate numbers
+ if { [info exists type($flag)]
+ && (![string is $type($flag) -strict $value])
+ } {
+ unset $token
+ return -code error \
+ "Bad value for $flag ($value), must be $type($flag)"
+ }
+ if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
+ unset $token
+ return -code error "Bad value for $flag ($value), number\
+ of list elements must be even"
+ }
+ set state($flag) $value
+ } else {
+ unset $token
+ return -code error "Unknown option $flag, can be: $usage"
+ }
+ }
+
+ # Make sure -query and -querychannel aren't both specified
+
+ set isQueryChannel [info exists state(-querychannel)]
+ set isQuery [info exists state(-query)]
+ if {$isQuery && $isQueryChannel} {
+ unset $token
+ return -code error "Can't combine -query and -querychannel options!"
+ }
+
+ # Validate URL, determine the server host and port, and check proxy case
+ # Recognize user:pass@host URLs also, although we do not do anything with
+ # that info yet.
+
+ # URLs have basically four parts.
+ # First, before the colon, is the protocol scheme (e.g. http)
+ # Second, for HTTP-like protocols, is the authority
+ # The authority is preceded by // and lasts up to (but not including)
+ # the following / or ? and it identifies up to four parts, of which
+ # only one, the host, is required (if an authority is present at all).
+ # All other parts of the authority (user name, password, port number)
+ # are optional.
+ # Third is the resource name, which is split into two parts at a ?
+ # The first part (from the single "/" up to "?") is the path, and the
+ # second part (from that "?" up to "#") is the query. *HOWEVER*, we do
+ # not need to separate them; we send the whole lot to the server.
+ # Both, path and query are allowed to be missing, including their
+ # delimiting character.
+ # Fourth is the fragment identifier, which is everything after the first
+ # "#" in the URL. The fragment identifier MUST NOT be sent to the server
+ # and indeed, we don't bother to validate it (it could be an error to
+ # pass it in here, but it's cheap to strip).
+ #
+ # An example of a URL that has all the parts:
+ #
+ # http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes
+ #
+ # The "http" is the protocol, the user is "jschmoe", the password is
+ # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
+ # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
+ #
+ # Note that the RE actually combines the user and password parts, as
+ # recommended in RFC 3986. Indeed, that RFC states that putting passwords
+ # in URLs is a Really Bad Idea, something with which I would agree utterly.
+ # RFC 9110 Sec 4.2.4 goes further than this, and deprecates the format
+ # "user:password@". It is retained here for backward compatibility,
+ # but its use is not recommended.
+ #
+ # From a validation perspective, we need to ensure that the parts of the
+ # URL that are going to the server are correctly encoded. This is only
+ # done if $state(-strict) is true (inherited from $::http::strict).
+
+ set URLmatcher {(?x) # this is _expanded_ syntax
+ ^
+ (?: (\w+) : ) ? #
+ (?: //
+ (?:
+ (
+ [^@/\#?]+ #
+ ) @
+ )?
+ ( #
+ [^/:\#?]+ | # host name or IPv4 address
+ \[ [^/\#?]+ \] # IPv6 address in square brackets
+ )
+ (?: : (\d+) )? #
+ )?
+ ( [/\?] [^\#]*)? # (including query)
+ (?: \# (.*) )? #
+ $
+ }
+
+ # Phase one: parse
+ if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
+ unset $token
+ return -code error "Unsupported URL: $url"
+ }
+ # Phase two: validate
+ set host [string trim $host {[]}]; # strip square brackets from IPv6 address
+ if {$host eq ""} {
+ # Caller has to provide a host name; we do not have a "default host"
+ # that would enable us to handle relative URLs.
+ unset $token
+ return -code error "Missing host part: $url"
+ # Note that we don't check the hostname for validity here; if it's
+ # invalid, we'll simply fail to resolve it later on.
+ }
+ if {$port ne "" && $port > 65535} {
+ unset $token
+ return -code error "Invalid port number: $port"
+ }
+ # The user identification and resource identification parts of the URL can
+ # have encoded characters in them; take care!
+ if {$user ne ""} {
+ # Check for validity according to RFC 3986, Appendix A
+ set validityRE {(?xi)
+ ^
+ (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
+ $
+ }
+ if {$state(-strict) && ![regexp -- $validityRE $user]} {
+ unset $token
+ # Provide a better error message in this error case
+ if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
+ return -code error \
+ "Illegal encoding character usage \"$bad\" in URL user"
+ }
+ return -code error "Illegal characters in URL user"
+ }
+ }
+ if {$srvurl ne ""} {
+ # RFC 3986 allows empty paths (not even a /), but servers
+ # return 400 if the path in the HTTP request doesn't start
+ # with / , so add it here if needed.
+ if {[string index $srvurl 0] ne "/"} {
+ set srvurl /$srvurl
+ }
+ # Check for validity according to RFC 3986, Appendix A
+ set validityRE {(?xi)
+ ^
+ # Path part (already must start with / character)
+ (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )*
+ # Query part (optional, permits ? characters)
+ (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
+ $
+ }
+ if {$state(-strict) && ![regexp -- $validityRE $srvurl]} {
+ unset $token
+ # Provide a better error message in this error case
+ if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
+ return -code error \
+ "Illegal encoding character usage \"$bad\" in URL path"
+ }
+ return -code error "Illegal characters in URL path"
+ }
+ if {![regexp {^[^?#]+} $srvurl state(path)]} {
+ set state(path) /
+ }
+ } else {
+ set srvurl /
+ set state(path) /
+ }
+ if {$proto eq ""} {
+ set proto http
+ }
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
+ unset $token
+ return -code error "Unsupported URL type \"$proto\""
+ }
+ set defport [lindex $urlTypes($lower) 0]
+ set defcmd [lindex $urlTypes($lower) 1]
+
+ if {$port eq ""} {
+ set port $defport
+ }
+ if {![catch {$http(-proxyfilter) $host} proxy]} {
+ set phost [lindex $proxy 0]
+ set pport [lindex $proxy 1]
+ } else {
+ set phost {}
+ set pport {}
+ }
+
+ # OK, now reassemble into a full URL
+ set url ${proto}://
+ if {$user ne ""} {
+ append url $user
+ append url @
+ }
+ append url $host
+ if {$port != $defport} {
+ append url : $port
+ }
+ append url $srvurl
+ # Don't append the fragment! RFC 7230 Sec 5.1
+ set state(url) $url
+
+ # Proxy connections aren't shared among different hosts.
+ set state(socketinfo) $host:$port
+
+ # Save the accept types at this point to prevent a race condition. [Bug
+ # c11a51c482]
+ set state(accept-types) $http(-accept)
+
+ # Check whether this is an Upgrade request.
+ set connectionValues [SplitCommaSeparatedFieldValue \
+ [GetFieldValue $state(-headers) Connection]]
+ set connectionValues [string tolower $connectionValues]
+ set upgradeValues [SplitCommaSeparatedFieldValue \
+ [GetFieldValue $state(-headers) Upgrade]]
+ set state(upgradeRequest) [expr { "upgrade" in $connectionValues
+ && [llength $upgradeValues] >= 1}]
+ set state(connectionValues) $connectionValues
+
+ if {$isQuery || $isQueryChannel} {
+ # It's a POST.
+ # A client wishing to send a non-idempotent request SHOULD wait to send
+ # that request until it has received the response status for the
+ # previous request.
+ if {$http(-postfresh)} {
+ # Override -keepalive for a POST. Use a new connection, and thus
+ # avoid the small risk of a race against server timeout.
+ set state(-keepalive) 0
+ } else {
+ # Allow -keepalive but do not -pipeline - wait for the previous
+ # transaction to finish.
+ # There is a small risk of a race against server timeout.
+ set state(-pipeline) 0
+ }
+ } elseif {$state(upgradeRequest)} {
+ # It's an upgrade request. Method must be GET (untested).
+ # Force -keepalive to 0 so the connection is not made over a persistent
+ # socket, i.e. one used for multiple HTTP requests.
+ set state(-keepalive) 0
+ } else {
+ # It's a non-upgrade GET or HEAD.
+ set state(-pipeline) $http(-pipeline)
+ }
+
+ # We cannot handle chunked encodings with -handler, so force HTTP/1.0
+ # until we can manage this.
+ if {[info exists state(-handler)]} {
+ set state(-protocol) 1.0
+ }
+
+ # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it.
+ if {$state(-protocol) eq "1.0"} {
+ set state(connection) close
+ set state(-keepalive) 0
+ }
+
+ # Handle proxy requests here for http:// but not for https://
+ # The proxying for https is done in the ::http::socketForTls command.
+ # A proxy request for http:// needs the full URL in the HTTP request line,
+ # including the server name.
+ # The *tls* test below attempts to describe protocols in addition to
+ # "https on port 443" that use HTTP over TLS.
+ if {($phost ne "") && (![string match -nocase *tls* $defcmd])} {
+ set srvurl $url
+ set targetAddr [list $phost $pport]
+ set state(proxyUsed) HttpProxy
+ # The value of state(proxyUsed) none|HttpProxy depends only on the
+ # all-transactions http::config settings and on the target URL.
+ # Even if this is a persistent socket there is no need to change the
+ # value of state(proxyUsed) for other transactions that use the socket:
+ # they have the same value already.
+ } else {
+ set targetAddr [list $host $port]
+ }
+
+ set sockopts [list -async]
+
+ # Pass -myaddr directly to the socket command
+ if {[info exists state(-myaddr)]} {
+ lappend sockopts -myaddr $state(-myaddr)
+ }
+
+ set state(connArgs) [list $proto $phost $srvurl]
+ set state(openCmd) [list {*}$defcmd {*}$sockopts -type $token {*}$targetAddr]
+
+ # See if we are supposed to use a previously opened channel.
+ # - In principle, ANY call to http::geturl could use a previously opened
+ # channel if it is available - the "Connection: keep-alive" header is a
+ # request to leave the channel open AFTER completion of this call.
+ # - In fact, we try to use an existing channel only if -keepalive 1 -- this
+ # means that at most one channel is left open for each value of
+ # $state(socketinfo). This property simplifies the mapping of open
+ # channels.
+ set reusing 0
+ set state(alreadyQueued) 0
+ set state(ReusingPlaceholder) 0
+ if {$state(-keepalive)} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ if {[info exists socketMapping($state(socketinfo))]} {
+ # - If the connection is idle, it has a "fileevent readable" binding
+ # to http::CheckEof, in case the server times out and half-closes
+ # the socket (http::CheckEof closes the other half).
+ # - We leave this binding in place until just before the last
+ # puts+flush in http::Connected (GET/HEAD) or http::Write (POST),
+ # after which the HTTP response might be generated.
+
+ if { [info exists socketClosing($state(socketinfo))]
+ && $socketClosing($state(socketinfo))
+ } {
+ # socketClosing(*) is set because the server has sent a
+ # "Connection: close" header.
+ # Do not use the persistent socket again.
+ # Since we have only one persistent socket per server, and the
+ # old socket is not yet dead, add the request to the write queue
+ # of the dying socket, which will be replayed by ReplayIfClose.
+ # Also add it to socketWrQueue(*) which is used only if an error
+ # causes a call to Finish.
+ set reusing 1
+ set sock $socketMapping($state(socketinfo))
+ set state(proxyUsed) $socketProxyId($state(socketinfo))
+ Log "reusing closing socket $sock for $state(socketinfo) - token $token"
+
+ set state(alreadyQueued) 1
+ lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3
+ lappend com3 $token
+ set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3]
+ lappend socketWrQueue($state(socketinfo)) $token
+ ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo))
+ ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo))
+ } elseif {
+ [catch {fconfigure $socketMapping($state(socketinfo))}]
+ && (![SockIsPlaceHolder $socketMapping($state(socketinfo))])
+ } {
+ ###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)"
+ # FIXME Is it still possible for this code to be executed? If
+ # so, this could be another place to call TestForReplay,
+ # rather than discarding the queued transactions.
+ Log "WARNING: socket for $state(socketinfo) was closed\
+ - token $token"
+ Log "WARNING - if testing, pay special attention to this\
+ case (GH) which is seldom executed - token $token"
+
+ # This will call CancelReadPipeline, CancelWritePipeline, and
+ # cancel any queued requests, responses.
+ Unset $state(socketinfo)
+ } else {
+ # Use the persistent socket.
+ # - The socket may not be ready to write: an earlier request might
+ # still be still writing (in the pipelined case) or
+ # writing/reading (in the nonpipeline case). This possibility
+ # is handled by socketWrQueue later in this command.
+ # - The socket may not yet exist, and be defined with a placeholder.
+ set reusing 1
+ set sock $socketMapping($state(socketinfo))
+ set state(proxyUsed) $socketProxyId($state(socketinfo))
+ if {[SockIsPlaceHolder $sock]} {
+ set state(ReusingPlaceholder) 1
+ lappend socketPhQueue($sock) $token
+ } else {
+ }
+ Log "reusing open socket $sock for $state(socketinfo) - token $token"
+ }
+ # Do not automatically close the connection socket.
+ set state(connection) keep-alive
+ }
+ }
+
+ set state(reusing) $reusing
+ unset reusing
+
+ if {![info exists sock]} {
+ # N.B. At this point ([info exists sock] == $state(reusing)).
+ # This will no longer be true after we set a value of sock here.
+ # Give the socket a placeholder name.
+ set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
+ }
+ set state(sock) $sock
+
+ if {$state(reusing)} {
+ # Define these for use (only) by http::ReplayIfDead if the persistent
+ # connection has died.
+ set state(tmpConnArgs) $state(connArgs)
+ set state(tmpState) [array get state]
+ set state(tmpOpenCmd) $state(openCmd)
+ }
+ return $token
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc ::http::SockIsPlaceHolder
+# ------------------------------------------------------------------------------
+# Command to return 0 if the argument is a genuine socket handle, or 1 if is a
+# placeholder value generated by geturl or ReplayCore before the real socket is
+# created.
+#
+# Arguments:
+# sock - either a valid socket handle or a placeholder value
+#
+# Return Value: 0 or 1
+# ------------------------------------------------------------------------------
+
+proc http::SockIsPlaceHolder {sock} {
+ expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}}
+}
+
+
+# ------------------------------------------------------------------------------
+# state(reusing)
+# ------------------------------------------------------------------------------
+# - state(reusing) is set by geturl, ReplayCore
+# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket,
+# ConfigureNewSocket, and ScheduleRequest when creating and configuring the
+# connection.
+# - state(reusing) is used by Connect, Connected, Event x 2 when deciding
+# whether to call TestForReplay.
+# - Other places where state(reusing) is used:
+# - Connected - if reusing and not pipelined, start the state(-timeout)
+# timeout (when writing).
+# - DoneRequest - if reusing and pipelined, send the next pipelined write
+# - Event - if reusing and pipelined, start the state(-timeout)
+# timeout (when reading).
+# - Event - if (not reusing) and pipelined, send the next pipelined
+# write.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+# Proc http::AsyncTransaction
+# ------------------------------------------------------------------------------
+# This command is called by geturl and ReplayCore to prepare the HTTP
+# transaction prescribed by a suitably prepared token.
+#
+# Arguments:
+# token - connection token (name of an array)
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::AsyncTransaction {token} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ set sock $state(sock)
+
+ # See comments above re the start of this timeout in other cases.
+ if {(!$state(reusing)) && ($state(-timeout) > 0)} {
+ set state(after) [after $state(-timeout) \
+ [list http::reset $token timeout]]
+ }
+
+ if { $state(-keepalive)
+ && (![info exists socketMapping($state(socketinfo))])
+ } {
+ # This code is executed only for the first -keepalive request on a
+ # socket. It makes the socket persistent.
+ ##Log " PreparePersistentConnection" $token -- $sock -- DO
+ set DoLater [PreparePersistentConnection $token]
+ } else {
+ ##Log " PreparePersistentConnection" $token -- $sock -- SKIP
+ set DoLater {-traceread 0 -tracewrite 0}
+ }
+
+ if {$state(ReusingPlaceholder)} {
+ # - This request was added to the socketPhQueue of a persistent
+ # connection.
+ # - But the connection has not yet been created and is a placeholder;
+ # - And the placeholder was created by an earlier request.
+ # - When that earlier request calls OpenSocket, its placeholder is
+ # replaced with a true socket, and it then executes the equivalent of
+ # OpenSocket for any subsequent requests that have
+ # $state(ReusingPlaceholder).
+ Log >J$tk after idle coro NO - ReusingPlaceholder
+ } elseif {$state(alreadyQueued)} {
+ # - This request was added to the socketWrQueue and socketPlayCmd
+ # of a persistent connection that will close at the end of its current
+ # read operation.
+ Log >J$tk after idle coro NO - alreadyQueued
+ } else {
+ Log >J$tk after idle coro YES
+ set CoroName ${token}--SocketCoroutine
+ set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
+ $token $DoLater]]
+ dict set socketCoEvent($state(socketinfo)) $token $cancel
+ set state(socketcoro) $cancel
+ }
+
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::PreparePersistentConnection
+# ------------------------------------------------------------------------------
+# This command is called by AsyncTransaction to initialise a "persistent
+# connection" based upon a socket placeholder. It is called the first time the
+# socket is associated with a "-keepalive" request.
+#
+# Arguments:
+# token - connection token (name of an array)
+#
+# Return Value: - DoLater, a dictionary of boolean values listing unfinished
+# tasks; to be passed to ConfigureNewSocket via OpenSocket.
+# ------------------------------------------------------------------------------
+
+proc http::PreparePersistentConnection {token} {
+ variable $token
+ upvar 0 $token state
+
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ set DoLater {-traceread 0 -tracewrite 0}
+ set socketMapping($state(socketinfo)) $state(sock)
+ set socketProxyId($state(socketinfo)) $state(proxyUsed)
+ # - The value of state(proxyUsed) was set in http::CreateToken to either
+ # "none" or "HttpProxy".
+ # - $token is the first transaction to use this placeholder, so there are
+ # no other tokens whose (proxyUsed) must be modified.
+
+ if {![info exists socketRdState($state(socketinfo))]} {
+ set socketRdState($state(socketinfo)) {}
+ # set varName ::http::socketRdState($state(socketinfo))
+ # trace add variable $varName unset ::http::CancelReadPipeline
+ dict set DoLater -traceread 1
+ }
+ if {![info exists socketWrState($state(socketinfo))]} {
+ set socketWrState($state(socketinfo)) {}
+ # set varName ::http::socketWrState($state(socketinfo))
+ # trace add variable $varName unset ::http::CancelWritePipeline
+ dict set DoLater -tracewrite 1
+ }
+
+ if {$state(-pipeline)} {
+ #Log new, init for pipelined, GRANT write access to $token in geturl
+ # Also grant premature read access to the socket. This is OK.
+ set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
+ } else {
+ # socketWrState is not used by this non-pipelined transaction.
+ # We cannot leave it as "Wready" because the next call to
+ # http::geturl with a pipelined transaction would conclude that the
+ # socket is available for writing.
+ #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
+ set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
+ }
+
+ # Value of socketPhQueue() may have already been set by ReplayCore.
+ if {![info exists socketPhQueue($state(sock))]} {
+ set socketPhQueue($state(sock)) {}
+ }
+ set socketRdQueue($state(socketinfo)) {}
+ set socketWrQueue($state(socketinfo)) {}
+ set socketClosing($state(socketinfo)) 0
+ set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
+ set socketCoEvent($state(socketinfo)) {}
+ set socketProxyId($state(socketinfo)) {}
+
+ return $DoLater
+}
+
+# ------------------------------------------------------------------------------
+# Proc ::http::OpenSocket
+# ------------------------------------------------------------------------------
+# This command is called as a coroutine idletask to start the asynchronous HTTP
+# transaction in most cases. For the exceptions, see the calling code in
+# command AsyncTransaction.
+#
+# Arguments:
+# token - connection token (name of an array)
+# DoLater - dictionary of boolean values listing unfinished tasks
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::OpenSocket {token DoLater} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ Log >K$tk Start OpenSocket coroutine
+
+ if {![info exists state(-keepalive)]} {
+ # The request has already been cancelled by the calling script.
+ return
+ }
+
+ set sockOld $state(sock)
+
+ dict unset socketCoEvent($state(socketinfo)) $token
+ unset -nocomplain state(socketcoro)
+
+ if {[catch {
+ if {$state(reusing)} {
+ # If ($state(reusing)) is true, then we do not need to create a new
+ # socket, even if $sockOld is only a placeholder for a socket.
+ set sock $sockOld
+ } else {
+ # set sock in the [catch] below.
+ set pre [clock milliseconds]
+ ##Log pre socket opened, - token $token
+ ##Log $state(openCmd) - token $token
+ set sock [namespace eval :: $state(openCmd)]
+ set state(sock) $sock
+ # Normal return from $state(openCmd) always returns a valid socket.
+ # A TLS proxy connection with 407 or other failure from the
+ # proxy server raises an error.
+
+ # Initialisation of a new socket.
+ ##Log post socket opened, - token $token
+ ##Log socket opened, now fconfigure - token $token
+ set delay [expr {[clock milliseconds] - $pre}]
+ if {$delay > 3000} {
+ Log socket delay $delay - token $token
+ }
+ fconfigure $sock -translation {auto crlf} \
+ -buffersize $state(-blocksize)
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ fconfigure $sock -profile tcl8
+ }
+ ##Log socket opened, DONE fconfigure - token $token
+ }
+
+ Log "Using $sock for $state(socketinfo) - token $token" \
+ [expr {$state(-keepalive)?"keepalive":""}]
+
+ # Code above has set state(sock) $sock
+ ConfigureNewSocket $token $sockOld $DoLater
+ ##Log OpenSocket success $sock - token $token
+ } result errdict]} {
+ ##Log OpenSocket failed $result - token $token
+ # There may be other requests in the socketPhQueue.
+ # Prepare socketPlayCmd so that Finish will replay them.
+ if { ($state(-keepalive)) && (!$state(reusing))
+ && [info exists socketPhQueue($sockOld)]
+ && ($socketPhQueue($sockOld) ne {})
+ } {
+ if {$socketMapping($state(socketinfo)) ne $sockOld} {
+ Log "WARNING: this code should not be reached.\
+ {$socketMapping($state(socketinfo)) ne $sockOld}"
+ }
+ set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)]
+ set socketPhQueue($sockOld) {}
+ }
+ if {[string range $result 0 20] eq {proxy connect failed:}} {
+ # - The HTTPS proxy did not create a socket. The pre-existing value
+ # (a "placeholder socket") is unchanged.
+ # - The proxy returned a valid HTTP response to the failed CONNECT
+ # request, and http::SecureProxyConnect copied this to $token,
+ # and also set ${token}(connection) set to "close".
+ # - Remove the error message $result so that Finish delivers this
+ # HTTP response to the caller.
+ set result {}
+ }
+ Finish $token $result
+ # Because socket creation failed, the placeholder "socket" must be
+ # "closed" and (if persistent) removed from the persistent sockets
+ # table. In the {proxy connect failed:} case Finish does this because
+ # the value of ${token}(connection) is "close". In the other cases here,
+ # it does so because $result is non-empty.
+ }
+ ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc ::http::ConfigureNewSocket
+# ------------------------------------------------------------------------------
+# Command to initialise a newly-created socket. Called only from OpenSocket.
+#
+# This command is called by OpenSocket whenever a genuine socket (sockNew) has
+# been opened for for use by HTTP. It does two things:
+# (1) If $token uses a placeholder socket, this command replaces the placeholder
+# socket with the real socket, not only in $token but in all other requests
+# that use the same placeholder.
+# (2) It calls ScheduleRequest to schedule each request that uses the socket.
+#
+#
+# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder).
+# sockNew is ${token}(sock)
+# sockOld sockNew CASES
+# sock sock (if $reusing, and sockOld is sock)
+# ph sock (if (not $reusing), and sockOld is ph)
+# ph ph (if $reusing, and sockOld is ph) - not called in this case
+# sock ph (cannot occur unless a bug) - not called in this case
+# (if (not $reusing), and sockOld is sock) - illogical
+#
+# Arguments:
+# token - connection token (name of an array)
+# sockOld - handle or placeholder used for a socket before the call to
+# OpenSocket
+# DoLater - dictionary of boolean values listing unfinished tasks
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::ConfigureNewSocket {token sockOld DoLater} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ set reusing $state(reusing)
+ set sock $state(sock)
+ set proxyUsed $state(proxyUsed)
+ ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed
+
+ if {(!$reusing) && ($sock ne $sockOld)} {
+ # Replace the placeholder value sockOld with sock.
+
+ if { [info exists socketMapping($state(socketinfo))]
+ && ($socketMapping($state(socketinfo)) eq $sockOld)
+ } {
+ set socketMapping($state(socketinfo)) $sock
+ set socketProxyId($state(socketinfo)) $proxyUsed
+ # tokens that use the placeholder $sockOld are updated below.
+ ##Log set socketMapping($state(socketinfo)) $sock
+ }
+
+ # Now finish any tasks left over from PreparePersistentConnection on
+ # the connection.
+ #
+ # The "unset" traces are fired by init (clears entire arrays), and
+ # by http::Unset.
+ # Unset is called by CloseQueuedQueries and (possibly never) by geturl.
+ #
+ # CancelReadPipeline, CancelWritePipeline call http::Finish for each
+ # token.
+ #
+ # FIXME If Finish is placeholder-aware, these traces can be set earlier,
+ # in PreparePersistentConnection.
+
+ if {[dict get $DoLater -traceread]} {
+ set varName ::http::socketRdState($state(socketinfo))
+ trace add variable $varName unset ::http::CancelReadPipeline
+ }
+ if {[dict get $DoLater -tracewrite]} {
+ set varName ::http::socketWrState($state(socketinfo))
+ trace add variable $varName unset ::http::CancelWritePipeline
+ }
+ }
+
+ # Do this in all cases.
+ ScheduleRequest $token
+
+ # Now look at all other tokens that use the placeholder $sockOld.
+ if { (!$reusing)
+ && ($sock ne $sockOld)
+ && [info exists socketPhQueue($sockOld)]
+ } {
+ ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
+ foreach tok $socketPhQueue($sockOld) {
+ # 1. Amend the token's (sock).
+ ##Log set ${tok}(sock) $sock
+ set ${tok}(sock) $sock
+ set ${tok}(proxyUsed) $proxyUsed
+
+ # 2. Schedule the token's HTTP request.
+ # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0.
+ set ${tok}(reusing) 1
+ set ${tok}(alreadyQueued) 0
+ ScheduleRequest $tok
+ }
+ set socketPhQueue($sockOld) {}
+ }
+ ##Log " ConfigureNewSocket" $token DONE
+
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# The values of array variables socketMapping etc.
+# ------------------------------------------------------------------------------
+# connId "$host:$port"
+# socketMapping($connId) the handle or placeholder for the socket that is used
+# for "-keepalive 1" requests to $connId.
+# socketRdState($connId) the token that is currently reading from the socket.
+# Other values: Rready (ready for next token to read).
+# socketWrState($connId) the token that is currently writing to the socket.
+# Other values: Wready (ready for next token to write),
+# peNding (would be ready for next write, except that
+# the integrity of a non-pipelined transaction requires
+# waiting until the read(s) in progress are finished).
+# socketRdQueue($connId) List of tokens that are queued for reading later.
+# socketWrQueue($connId) List of tokens that are queued for writing later.
+# socketPhQueue($sock) List of tokens that are queued to use a placeholder
+# socket, when the real socket has not yet been created.
+# socketClosing($connId) (boolean) true iff a server response header indicates
+# that the server will close the connection at the end of
+# the current response.
+# socketPlayCmd($connId) The command to execute to replay pending and
+# part-completed transactions if the socket closes early.
+# socketCoEvent($connId) Identifier for the "after idle" event that will launch
+# an OpenSocket coroutine to open or re-use a socket.
+# socketProxyId($connId) The type of proxy that this socket uses: values are
+# those of state(proxyUsed) i.e. none, HttpProxy,
+# SecureProxy, and SecureProxyFailed.
+# The value is not used for anything by http, its purpose
+# is to set the value of state() for caller information.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*)
+# ------------------------------------------------------------------------------
+# The element socketWrState($connId) has a value which is either the name of
+# the token that is permitted to write to the socket, or "Wready" if no
+# token is permitted to write.
+#
+# The code that sets the value to Wready immediately calls
+# http::NextPipelinedWrite, which examines socketWrQueue($connId) and
+# processes the next request in the queue, if there is one. The value
+# Wready is not found when the interpreter is in the event loop unless the
+# socket is idle.
+#
+# The element socketRdState($connId) has a value which is either the name of
+# the token that is permitted to read from the socket, or "Rready" if no
+# token is permitted to read.
+#
+# The code that sets the value to Rready then examines
+# socketRdQueue($connId) and processes the next request in the queue, if
+# there is one. The value Rready is not found when the interpreter is in
+# the event loop unless the socket is idle.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+# Proc http::ScheduleRequest
+# ------------------------------------------------------------------------------
+# Command to either begin the HTTP request, or add it to the appropriate queue.
+# Called from two places in ConfigureNewSocket.
+#
+# Arguments:
+# token - connection token (name of an array)
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::ScheduleRequest {token} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ Log >L$tk ScheduleRequest
+
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ set Unfinished 0
+
+ set reusing $state(reusing)
+ set sockNew $state(sock)
+
+ # The "if" tests below: must test against the current values of
+ # socketWrState, socketRdState, and so the tests must be done here,
+ # not earlier in PreparePersistentConnection.
+
+ if {$state(alreadyQueued)} {
+ # The request has been appended to the queue of a persistent socket
+ # (that is scheduled to close and have its queue replayed).
+ #
+ # A write may or may not be in progress. There is no need to set
+ # socketWrState to prevent another call stealing write access - all
+ # subsequent calls on this socket will come here because the socket
+ # will close after the current read, and its
+ # socketClosing($connId) is 1.
+ ##Log "HTTP request for token $token is queued"
+
+ } elseif { $reusing
+ && $state(-pipeline)
+ && ($socketWrState($state(socketinfo)) ne "Wready")
+ } {
+ ##Log "HTTP request for token $token is queued for pipelined use"
+ lappend socketWrQueue($state(socketinfo)) $token
+
+ } elseif { $reusing
+ && (!$state(-pipeline))
+ && ($socketWrState($state(socketinfo)) ne "Wready")
+ } {
+ # A write is queued or in progress. Lappend to the write queue.
+ ##Log "HTTP request for token $token is queued for nonpipeline use"
+ lappend socketWrQueue($state(socketinfo)) $token
+
+ } elseif { $reusing
+ && (!$state(-pipeline))
+ && ($socketWrState($state(socketinfo)) eq "Wready")
+ && ($socketRdState($state(socketinfo)) ne "Rready")
+ } {
+ # A read is queued or in progress, but not a write. Cannot start the
+ # nonpipeline transaction, but must set socketWrState to prevent a
+ # pipelined request jumping the queue.
+ ##Log "HTTP request for token $token is queued for nonpipeline use"
+ #Log re-use nonpipeline, GRANT delayed write access to $token in geturl
+ set socketWrState($state(socketinfo)) peNding
+ lappend socketWrQueue($state(socketinfo)) $token
+
+ } else {
+ if {$reusing && $state(-pipeline)} {
+ #Log new, init for pipelined, GRANT write access to $token in geturl
+ # DO NOT grant premature read access to the socket.
+ # set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
+ } elseif {$reusing} {
+ # socketWrState is not used by this non-pipelined transaction.
+ # We cannot leave it as "Wready" because the next call to
+ # http::geturl with a pipelined transaction would conclude that the
+ # socket is available for writing.
+ #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
+ set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
+ } else {
+ }
+
+ # Process the request now.
+ # - Command is not called unless $state(sock) is a real socket handle
+ # and not a placeholder.
+ # - All (!$reusing) cases come here.
+ # - Some $reusing cases come here too if the connection is
+ # marked as ready. Those $reusing cases are:
+ # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") &&
+ # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready")
+ # OR $pipeline
+ #
+ #Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
+ ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token
+ # Connect does its own fconfigure.
+
+ lassign $state(connArgs) proto phost srvurl
+
+ if {[catch {
+ fileevent $state(sock) writable \
+ [list http::Connect $token $proto $phost $srvurl]
+ } res opts]} {
+ # The socket no longer exists.
+ ##Log bug -- socket gone -- $res -- $opts
+ }
+
+ }
+
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SendHeader
+# ------------------------------------------------------------------------------
+# Command to send a request header, and keep a copy in state(requestHeaders)
+# for debugging purposes.
+#
+# Arguments:
+# token - connection token (name of an array)
+# key - header name
+# value - header value
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::SendHeader {token key value} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ set sock $state(sock)
+ lappend state(requestHeaders) [string tolower $key] $value
+ puts $sock "$key: $value"
+ return
+}
+
+# http::Connected --
+#
+# Callback used when the connection to the HTTP server is actually
+# established.
+#
+# Arguments:
+# token State token.
+# proto What protocol (http, https, etc.) was used to connect.
+# phost Are we using keep-alive? Non-empty if yes.
+# srvurl Service-local URL that we're requesting
+# Results:
+# None.
+
+proc http::Connected {token proto phost srvurl} {
+ variable http
+ variable urlTypes
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} {
+ set state(after) [after $state(-timeout) \
+ [list http::reset $token timeout]]
+ }
+
+ # Set back the variables needed here.
+ set sock $state(sock)
+ set isQueryChannel [info exists state(-querychannel)]
+ set isQuery [info exists state(-query)]
+ regexp {^(.+):([^:]+)$} $state(socketinfo) {} host port
+
+ set lower [string tolower $proto]
+ set defport [lindex $urlTypes($lower) 0]
+
+ # Send data in cr-lf format, but accept any line terminators.
+ # Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest.
+ # We are concerned here with the request (write) not the response (read).
+ lassign [fconfigure $sock -translation] trRead trWrite
+ fconfigure $sock -translation [list $trRead crlf] \
+ -buffersize $state(-blocksize)
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ fconfigure $sock -profile tcl8
+ }
+
+ # The following is disallowed in safe interpreters, but the socket is
+ # already in non-blocking mode in that case.
+
+ catch {fconfigure $sock -blocking off}
+ set how GET
+ if {$isQuery} {
+ set state(querylength) [string length $state(-query)]
+ if {$state(querylength) > 0} {
+ set how POST
+ set contDone 0
+ } else {
+ # There's no query data.
+ unset state(-query)
+ set isQuery 0
+ }
+ } elseif {$state(-validate)} {
+ set how HEAD
+ } elseif {$isQueryChannel} {
+ set how POST
+ # The query channel must be blocking for the async Write to
+ # work properly.
+ fconfigure $state(-querychannel) -blocking 1 -translation binary
+ set contDone 0
+ }
+ if {[info exists state(-method)] && ($state(-method) ne "")} {
+ set how $state(-method)
+ }
+ set accept_types_seen 0
+
+ Log ^B$tk begin sending request - token $token
+
+ if {[catch {
+ if {[info exists state(bypass)]} {
+ set state(method) [lindex [split $state(bypass) { }] 0]
+ set state(requestHeaders) {}
+ set state(requestLine) $state(bypass)
+ } else {
+ set state(method) $how
+ set state(requestHeaders) {}
+ set state(requestLine) "$how $srvurl HTTP/$state(-protocol)"
+ }
+ puts $sock $state(requestLine)
+ set hostValue [GetFieldValue $state(-headers) Host]
+ if {$hostValue ne {}} {
+ # Allow Host spoofing. [Bug 928154]
+ regexp {^[^:]+} $hostValue state(host)
+ SendHeader $token Host $hostValue
+ } elseif {$port == $defport} {
+ # Don't add port in this case, to handle broken servers. [Bug
+ # #504508]
+ set state(host) $host
+ SendHeader $token Host $host
+ } else {
+ set state(host) $host
+ SendHeader $token Host "$host:$port"
+ }
+ SendHeader $token User-Agent $http(-useragent)
+ if {($state(-protocol) > 1.0) && $state(-keepalive)} {
+ # Send this header, because a 1.1 server is not compelled to treat
+ # this as the default.
+ set ConnVal keep-alive
+ } elseif {($state(-protocol) > 1.0)} {
+ # RFC2616 sec 8.1.2.1
+ set ConnVal close
+ } else {
+ # ($state(-protocol) <= 1.0)
+ # RFC7230 A.1
+ # Some server implementations of HTTP/1.0 have a faulty
+ # implementation of RFC 2068 Keep-Alive.
+ # Don't leave this to chance.
+ # For HTTP/1.0 we have already "set state(connection) close"
+ # and "state(-keepalive) 0".
+ set ConnVal close
+ }
+ # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
+ # Pat Thoyts).
+ if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
+ SendHeader $token Proxy-Authorization $http(-proxyauth)
+ }
+ # RFC7230 A.1 - "clients are encouraged not to send the
+ # Proxy-Connection header field in any requests"
+ set accept_encoding_seen 0
+ set content_type_seen 0
+ set connection_seen 0
+ foreach {key value} $state(-headers) {
+ set value [string map [list \n "" \r ""] $value]
+ set key [string map {" " -} [string trim $key]]
+ if {[string equal -nocase $key "host"]} {
+ continue
+ }
+ if {[string equal -nocase $key "accept-encoding"]} {
+ set accept_encoding_seen 1
+ }
+ if {[string equal -nocase $key "accept"]} {
+ set accept_types_seen 1
+ }
+ if {[string equal -nocase $key "content-type"]} {
+ set content_type_seen 1
+ }
+ if {[string equal -nocase $key "content-length"]} {
+ set contDone 1
+ set state(querylength) $value
+ }
+ if { [string equal -nocase $key "connection"]
+ && [info exists state(bypass)]
+ } {
+ # Value supplied in -headers overrides $ConnVal.
+ set connection_seen 1
+ } elseif {[string equal -nocase $key "connection"]} {
+ # Remove "close" or "keep-alive" and use our own value.
+ # In an upgrade request, the upgrade is not guaranteed.
+ # Value "close" or "keep-alive" tells the server what to do
+ # if it refuses the upgrade. We send a single "Connection"
+ # header because some websocket servers, e.g. civetweb, reject
+ # multiple headers. Bug [d01de3281f] of tcllib/websocket.
+ set connection_seen 1
+ set listVal $state(connectionValues)
+ if {[set pos [lsearch $listVal close]] != -1} {
+ set listVal [lreplace $listVal $pos $pos]
+ }
+ if {[set pos [lsearch $listVal keep-alive]] != -1} {
+ set listVal [lreplace $listVal $pos $pos]
+ }
+ lappend listVal $ConnVal
+ set value [join $listVal {, }]
+ }
+ if {[string length $key]} {
+ SendHeader $token $key $value
+ }
+ }
+ # Allow overriding the Accept header on a per-connection basis. Useful
+ # for working with REST services. [Bug c11a51c482]
+ if {!$accept_types_seen} {
+ SendHeader $token Accept $state(accept-types)
+ }
+ if { (!$accept_encoding_seen)
+ && (![info exists state(-handler)])
+ && $http(-zip)
+ } {
+ SendHeader $token Accept-Encoding gzip,deflate
+ } elseif {!$accept_encoding_seen} {
+ SendHeader $token Accept-Encoding identity
+ } else {
+ }
+ if {!$connection_seen} {
+ SendHeader $token Connection $ConnVal
+ }
+ if {$isQueryChannel && ($state(querylength) == 0)} {
+ # Try to determine size of data in channel. If we cannot seek, the
+ # surrounding catch will trap us
+
+ set start [tell $state(-querychannel)]
+ seek $state(-querychannel) 0 end
+ set state(querylength) \
+ [expr {[tell $state(-querychannel)] - $start}]
+ seek $state(-querychannel) $start
+ }
+
+ # Note that we don't do Cookie2; that's much nastier and not normally
+ # observed in practice either. It also doesn't fix the multitude of
+ # bugs in the basic cookie spec.
+ if {$http(-cookiejar) ne ""} {
+ set cookies ""
+ set separator ""
+ foreach {key value} [{*}$http(-cookiejar) \
+ getCookies $proto $host $state(path)] {
+ append cookies $separator $key = $value
+ set separator "; "
+ }
+ if {$cookies ne ""} {
+ SendHeader $token Cookie $cookies
+ }
+ }
+
+ # Flush the request header and set up the fileevent that will either
+ # push the POST data or read the response.
+ #
+ # fileevent note:
+ #
+ # It is possible to have both the read and write fileevents active at
+ # this point. The only scenario it seems to affect is a server that
+ # closes the connection without reading the POST data. (e.g., early
+ # versions TclHttpd in various error cases). Depending on the
+ # platform, the client may or may not be able to get the response from
+ # the server because of the error it will get trying to write the post
+ # data. Having both fileevents active changes the timing and the
+ # behavior, but no two platforms (among Solaris, Linux, and NT) behave
+ # the same, and none behave all that well in any case. Servers should
+ # always read their POST data if they expect the client to read their
+ # response.
+
+ if {$isQuery || $isQueryChannel} {
+ # POST method.
+ if {!$content_type_seen} {
+ SendHeader $token Content-Type $state(-type)
+ }
+ if {!$contDone} {
+ SendHeader $token Content-Length $state(querylength)
+ }
+ puts $sock ""
+ flush $sock
+ # Flush flushes the error in the https case with a bad handshake:
+ # else the socket never becomes writable again, and hangs until
+ # timeout (if any).
+
+ lassign [fconfigure $sock -translation] trRead trWrite
+ fconfigure $sock -translation [list $trRead binary]
+ fileevent $sock writable [list http::Write $token]
+ # The http::Write command decides when to make the socket readable,
+ # using the same test as the GET/HEAD case below.
+ } else {
+ # GET or HEAD method.
+ if { (![catch {fileevent $sock readable} binding])
+ && ($binding eq [list http::CheckEof $sock])
+ } {
+ # Remove the "fileevent readable" binding of an idle persistent
+ # socket to http::CheckEof. We can no longer treat bytes
+ # received as junk. The server might still time out and
+ # half-close the socket if it has not yet received the first
+ # "puts".
+ fileevent $sock readable {}
+ }
+ puts $sock ""
+ flush $sock
+ Log ^C$tk end sending request - token $token
+ # End of writing (GET/HEAD methods). The request has been sent.
+
+ DoneRequest $token
+ }
+
+ } err]} {
+ # The socket probably was never connected, OR the connection dropped
+ # later, OR https handshake error, which may be discovered as late as
+ # the "flush" command above...
+ Log "WARNING - if testing, pay special attention to this\
+ case (GI) which is seldom executed - token $token"
+ if {[info exists state(reusing)] && $state(reusing)} {
+ # The socket was closed at the server end, and closed at
+ # this end by http::CheckEof.
+ if {[TestForReplay $token write $err a]} {
+ return
+ } else {
+ Finish $token {failed to re-use socket}
+ }
+
+ # else:
+ # This is NOT a persistent socket that has been closed since its
+ # last use.
+ # If any other requests are in flight or pipelined/queued, they will
+ # be discarded.
+ } elseif {$state(status) eq ""} {
+ # https handshake errors come here, for
+ # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6.
+ set msg [registerError $sock]
+ registerError $sock {}
+ if {$msg eq {}} {
+ set msg {failed to use socket}
+ }
+ Finish $token $msg
+ } elseif {$state(status) ne "error"} {
+ Finish $token $err
+ }
+ }
+ return
+}
+
+# http::registerError
+#
+# Called (for example when processing TclTLS activity) to register
+# an error for a connection on a specific socket. This helps
+# http::Connected to deliver meaningful error messages, e.g. when a TLS
+# certificate fails verification.
+#
+# Usage: http::registerError socket ?newValue?
+#
+# "set" semantics, except that a "get" (a call without a new value) for a
+# non-existent socket returns {}, not an error.
+
+proc http::registerError {sock args} {
+ variable registeredErrors
+
+ if { ([llength $args] == 0)
+ && (![info exists registeredErrors($sock)])
+ } {
+ return
+ } elseif { ([llength $args] == 1)
+ && ([lindex $args 0] eq {})
+ } {
+ unset -nocomplain registeredErrors($sock)
+ return
+ }
+ set registeredErrors($sock) {*}$args
+}
+
+# http::DoneRequest --
+#
+# Command called when a request has been sent. It will arrange the
+# next request and/or response as appropriate.
+#
+# If this command is called when $socketClosing(*), the request $token
+# that calls it must be pipelined and destined to fail.
+
+proc http::DoneRequest {token} {
+ variable http
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ set sock $state(sock)
+
+ # If pipelined, connect the next HTTP request to the socket.
+ if {$state(reusing) && $state(-pipeline)} {
+ # Enable next token (if any) to write.
+ # The value "Wready" is set only here, and
+ # in http::Event after reading the response-headers of a
+ # non-reusing transaction.
+ # Previous value is $token. It cannot be pending.
+ set socketWrState($state(socketinfo)) Wready
+
+ # Now ready to write the next pipelined request (if any).
+ http::NextPipelinedWrite $token
+ } else {
+ # If pipelined, this is the first transaction on this socket. We wait
+ # for the response headers to discover whether the connection is
+ # persistent. (If this is not done and the connection is not
+ # persistent, we SHOULD retry and then MUST NOT pipeline before knowing
+ # that we have a persistent connection
+ # (rfc2616 8.1.2.2)).
+ }
+
+ # Connect to receive the response, unless the socket is pipelined
+ # and another response is being sent.
+ # This code block is separate from the code below because there are
+ # cases where socketRdState already has the value $token.
+ if { $state(-keepalive)
+ && $state(-pipeline)
+ && [info exists socketRdState($state(socketinfo))]
+ && ($socketRdState($state(socketinfo)) eq "Rready")
+ } {
+ #Log pipelined, GRANT read access to $token in Connected
+ set socketRdState($state(socketinfo)) $token
+ }
+
+ if { $state(-keepalive)
+ && $state(-pipeline)
+ && [info exists socketRdState($state(socketinfo))]
+ && ($socketRdState($state(socketinfo)) ne $token)
+ } {
+ # Do not read from the socket until it is ready.
+ ##Log "HTTP response for token $token is queued for pipelined use"
+ # If $socketClosing(*), then the caller will be a pipelined write and
+ # execution will come here.
+ # This token has already been recorded as "in flight" for writing.
+ # When the socket is closed, the read queue will be cleared in
+ # CloseQueuedQueries and so the "lappend" here has no effect.
+ lappend socketRdQueue($state(socketinfo)) $token
+ } else {
+ # In the pipelined case, connection for reading depends on the
+ # value of socketRdState.
+ # In the nonpipeline case, connection for reading always occurs.
+ ReceiveResponse $token
+ }
+ return
+}
+
+# http::ReceiveResponse
+#
+# Connects token to its socket for reading.
+
+proc http::ReceiveResponse {token} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ set sock $state(sock)
+
+ #Log ---- $state(socketinfo) >> conn to $token for HTTP response
+ lassign [fconfigure $sock -translation] trRead trWrite
+ fconfigure $sock -translation [list auto $trWrite] \
+ -buffersize $state(-blocksize)
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ fconfigure $sock -profile tcl8
+ }
+ Log ^D$tk begin receiving response - token $token
+
+ coroutine ${token}--EventCoroutine http::Event $sock $token
+ if {[info exists state(-handler)] || [info exists state(-progress)]} {
+ fileevent $sock readable [list http::EventGateway $sock $token]
+ } else {
+ fileevent $sock readable ${token}--EventCoroutine
+ }
+ return
+}
+
+
+# http::EventGateway
+#
+# Bug [c2dc1da315].
+# - Recursive launch of the coroutine can occur if a -handler or -progress
+# callback is used, and the callback command enters the event loop.
+# - To prevent this, the fileevent "binding" is disabled while the
+# coroutine is in flight.
+# - If a recursive call occurs despite these precautions, it is not
+# trapped and discarded here, because it is better to report it as a
+# bug.
+# - Although this solution is believed to be sufficiently general, it is
+# used only if -handler or -progress is specified. In other cases,
+# the coroutine is called directly.
+
+proc http::EventGateway {sock token} {
+ variable $token
+ upvar 0 $token state
+ fileevent $sock readable {}
+ catch {${token}--EventCoroutine} res opts
+ if {[info commands ${token}--EventCoroutine] ne {}} {
+ # The coroutine can be deleted by completion (a non-yield return), by
+ # http::Finish (when there is a premature end to the transaction), by
+ # http::reset or http::cleanup, or if the caller set option -channel
+ # but not option -handler: in the last case reading from the socket is
+ # now managed by commands ::http::Copy*, http::ReceiveChunked, and
+ # http::MakeTransformationChunked.
+ #
+ # Catch in case the coroutine has closed the socket.
+ catch {fileevent $sock readable [list http::EventGateway $sock $token]}
+ }
+
+ # If there was an error, re-throw it.
+ return -options $opts $res
+}
+
+
+# http::NextPipelinedWrite
+#
+# - Connecting a socket to a token for writing is done by this command and by
+# command KeepSocket.
+# - If another request has a pipelined write scheduled for $token's socket,
+# and if the socket is ready to accept it, connect the write and update
+# the queue accordingly.
+# - This command is called from http::DoneRequest and http::Event,
+# IF $state(-pipeline) AND (the current transfer has reached the point at
+# which the socket is ready for the next request to be written).
+# - This command is called when a token has write access and is pipelined and
+# keep-alive, and sets socketWrState to Wready.
+# - The command need not consider the case where socketWrState is set to a token
+# that does not yet have write access. Such a token is waiting for Rready,
+# and the assignment of the connection to the token will be done elsewhere (in
+# http::KeepSocket).
+# - This command cannot be called after socketWrState has been set to a
+# "pending" token value (that is then overwritten by the caller), because that
+# value is set by this command when it is called by an earlier token when it
+# relinquishes its write access, and the pending token is always the next in
+# line to write.
+
+proc http::NextPipelinedWrite {token} {
+ variable http
+ variable socketRdState
+ variable socketWrState
+ variable socketWrQueue
+ variable socketClosing
+ variable $token
+ upvar 0 $token state
+ set connId $state(socketinfo)
+
+ if { [info exists socketClosing($connId)]
+ && $socketClosing($connId)
+ } {
+ # socketClosing(*) is set because the server has sent a
+ # "Connection: close" header.
+ # Behave as if the queues are empty - so do nothing.
+ } elseif { $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "Wready")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && ([set token2 [lindex $socketWrQueue($connId) 0]
+ set ${token2}(-pipeline)
+ ]
+ )
+ } {
+ # - The usual case for a pipelined connection, ready for a new request.
+ #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
+ set conn [set ${token2}(connArgs)]
+ set socketWrState($connId) $token2
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token2 {*}$conn]
+ #Log ---- $connId << conn to $token2 for HTTP request (b)
+
+ # In the tests below, the next request will be nonpipeline.
+ } elseif { $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "Wready")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && (![ set token3 [lindex $socketWrQueue($connId) 0]
+ set ${token3}(-pipeline)
+ ]
+ )
+
+ && [info exists socketRdState($connId)]
+ && ($socketRdState($connId) eq "Rready")
+ } {
+ # The case in which the next request will be non-pipelined, and the read
+ # and write queues is ready: which is the condition for a non-pipelined
+ # write.
+ set conn [set ${token3}(connArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+ } elseif { $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "Wready")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && (![set token2 [lindex $socketWrQueue($connId) 0]
+ set ${token2}(-pipeline)
+ ]
+ )
+ } {
+ # - The case in which the next request will be non-pipelined, but the
+ # read queue is NOT ready.
+ # - A read is queued or in progress, but not a write. Cannot start the
+ # nonpipeline transaction, but must set socketWrState to prevent a new
+ # pipelined request (in http::geturl) jumping the queue.
+ # - Because socketWrState($connId) is not set to Wready, the assignment
+ # of the connection to $token2 will be done elsewhere - by command
+ # http::KeepSocket when $socketRdState($connId) is set to "Rready".
+
+ #Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
+ set socketWrState($connId) peNding
+ }
+ return
+}
+
+# http::CancelReadPipeline
+#
+# Cancel pipelined responses on a closing "Keep-Alive" socket.
+#
+# - Called by a variable trace on "unset socketRdState($connId)".
+# - The variable relates to a Keep-Alive socket, which has been closed.
+# - Cancels all pipelined responses. The requests have been sent,
+# the responses have not yet been received.
+# - This is a hard cancel that ends each transaction with error status,
+# and closes the connection. Do not use it if you want to replay failed
+# transactions.
+# - N.B. Always delete ::http::socketRdState($connId) before deleting
+# ::http::socketRdQueue($connId), or this command will do nothing.
+#
+# Arguments
+# As for a trace command on a variable.
+
+proc http::CancelReadPipeline {name1 connId op} {
+ variable socketRdQueue
+ ##Log CancelReadPipeline $name1 $connId $op
+ if {[info exists socketRdQueue($connId)]} {
+ set msg {the connection was closed by CancelReadPipeline}
+ foreach token $socketRdQueue($connId) {
+ set tk [namespace tail $token]
+ Log ^X$tk end of response "($msg)" - token $token
+ set ${token}(status) eof
+ Finish $token ;#$msg
+ }
+ set socketRdQueue($connId) {}
+ }
+ return
+}
+
+# http::CancelWritePipeline
+#
+# Cancel queued events on a closing "Keep-Alive" socket.
+#
+# - Called by a variable trace on "unset socketWrState($connId)".
+# - The variable relates to a Keep-Alive socket, which has been closed.
+# - In pipelined or nonpipeline case: cancels all queued requests. The
+# requests have not yet been sent, the responses are not due.
+# - This is a hard cancel that ends each transaction with error status,
+# and closes the connection. Do not use it if you want to replay failed
+# transactions.
+# - N.B. Always delete ::http::socketWrState($connId) before deleting
+# ::http::socketWrQueue($connId), or this command will do nothing.
+#
+# Arguments
+# As for a trace command on a variable.
+
+proc http::CancelWritePipeline {name1 connId op} {
+ variable socketWrQueue
+
+ ##Log CancelWritePipeline $name1 $connId $op
+ if {[info exists socketWrQueue($connId)]} {
+ set msg {the connection was closed by CancelWritePipeline}
+ foreach token $socketWrQueue($connId) {
+ set tk [namespace tail $token]
+ Log ^X$tk end of response "($msg)" - token $token
+ set ${token}(status) eof
+ Finish $token ;#$msg
+ }
+ set socketWrQueue($connId) {}
+ }
+ return
+}
+
+# http::ReplayIfDead --
+#
+# - A query on a re-used persistent socket failed at the earliest opportunity,
+# because the socket had been closed by the server. Keep the token, tidy up,
+# and try to connect on a fresh socket.
+# - The connection is monitored for eof by the command http::CheckEof. Thus
+# http::ReplayIfDead is needed only when a server event (half-closing an
+# apparently idle connection), and a client event (sending a request) occur at
+# almost the same time, and neither client nor server detects the other's
+# action before performing its own (an "asynchronous close event").
+# - To simplify testing of http::ReplayIfDead, set TEST_EOF 1 in
+# http::KeepSocket, and then http::ReplayIfDead will be called if http::geturl
+# is called at any time after the server timeout.
+#
+# Arguments:
+# token Connection token.
+#
+# Side Effects:
+# Use the same token, but try to open a new socket.
+
+proc http::ReplayIfDead {token doing} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+
+ Log running http::ReplayIfDead for $token $doing
+
+ # 1. Merge the tokens for transactions in flight, the read (response) queue,
+ # and the write (request) queue.
+
+ set InFlightR {}
+ set InFlightW {}
+
+ # Obtain the tokens for transactions in flight.
+ if {$state(-pipeline)} {
+ # Two transactions may be in flight. The "read" transaction was first.
+ # It is unlikely that the server would close the socket if a response
+ # was pending; however, an earlier request (as well as the present
+ # request) may have been sent and ignored if the socket was half-closed
+ # by the server.
+
+ if { [info exists socketRdState($state(socketinfo))]
+ && ($socketRdState($state(socketinfo)) ne "Rready")
+ } {
+ lappend InFlightR $socketRdState($state(socketinfo))
+ } elseif {($doing eq "read")} {
+ lappend InFlightR $token
+ }
+
+ if { [info exists socketWrState($state(socketinfo))]
+ && $socketWrState($state(socketinfo)) ni {Wready peNding}
+ } {
+ lappend InFlightW $socketWrState($state(socketinfo))
+ } elseif {($doing eq "write")} {
+ lappend InFlightW $token
+ }
+
+ # Report any inconsistency of $token with socket*state.
+ if { ($doing eq "read")
+ && [info exists socketRdState($state(socketinfo))]
+ && ($token ne $socketRdState($state(socketinfo)))
+ } {
+ Log WARNING - ReplayIfDead pipelined token $token $doing \
+ ne socketRdState($state(socketinfo)) \
+ $socketRdState($state(socketinfo))
+
+ } elseif {
+ ($doing eq "write")
+ && [info exists socketWrState($state(socketinfo))]
+ && ($token ne $socketWrState($state(socketinfo)))
+ } {
+ Log WARNING - ReplayIfDead pipelined token $token $doing \
+ ne socketWrState($state(socketinfo)) \
+ $socketWrState($state(socketinfo))
+ }
+ } else {
+ # One transaction should be in flight.
+ # socketRdState, socketWrQueue are used.
+ # socketRdQueue should be empty.
+
+ # Report any inconsistency of $token with socket*state.
+ if {$token ne $socketRdState($state(socketinfo))} {
+ Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+ ne socketRdState($state(socketinfo)) \
+ $socketRdState($state(socketinfo))
+ }
+
+ # Report the inconsistency that socketRdQueue is non-empty.
+ if { [info exists socketRdQueue($state(socketinfo))]
+ && ($socketRdQueue($state(socketinfo)) ne {})
+ } {
+ Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+ has read queue socketRdQueue($state(socketinfo)) \
+ $socketRdQueue($state(socketinfo)) ne {}
+ }
+
+ lappend InFlightW $socketRdState($state(socketinfo))
+ set socketRdQueue($state(socketinfo)) {}
+ }
+
+ set newQueue {}
+ lappend newQueue {*}$InFlightR
+ lappend newQueue {*}$socketRdQueue($state(socketinfo))
+ lappend newQueue {*}$InFlightW
+ lappend newQueue {*}$socketWrQueue($state(socketinfo))
+
+
+ # 2. Tidy up token. This is a cut-down form of Finish/CloseSocket.
+ # Do not change state(status).
+ # No need to after cancel state(after) - either this is done in
+ # ReplayCore/ReInit, or Finish is called.
+
+ catch {close $state(sock)}
+ Unset $state(socketinfo)
+
+ # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit.
+ # - Transactions, if any, that are awaiting responses cannot be completed.
+ # They are listed for re-sending in newQueue.
+ # - All tokens are preserved for re-use by ReplayCore, and their variables
+ # will be re-initialised by calls to ReInit.
+ # - The relevant element of socketMapping, socketRdState, socketWrState,
+ # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set
+ # to new values in ReplayCore.
+
+ ReplayCore $newQueue
+ return
+}
+
+# http::ReplayIfClose --
+#
+# A request on a socket that was previously "Connection: keep-alive" has
+# received a "Connection: close" response header. The server supplies
+# that response correctly, but any later requests already queued on this
+# connection will be lost when the socket closes.
+#
+# This command takes arguments that represent the socketWrState,
+# socketRdQueue and socketWrQueue for this connection. The socketRdState
+# is not needed because the server responds in full to the request that
+# received the "Connection: close" response header.
+#
+# Existing request tokens $token (::http::$n) are preserved. The caller
+# will be unaware that the request was processed this way.
+
+proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
+ Log running http::ReplayIfClose for $Wstate $Rqueue $Wqueue
+
+ if {$Wstate in $Rqueue || $Wstate in $Wqueue} {
+ Log WARNING duplicate token in http::ReplayIfClose - token $Wstate
+ set Wstate Wready
+ }
+
+ # 1. Create newQueue
+ set InFlightW {}
+ if {$Wstate ni {Wready peNding}} {
+ lappend InFlightW $Wstate
+ }
+ ##Log $Rqueue -- $InFlightW -- $Wqueue
+ set newQueue {}
+ lappend newQueue {*}$Rqueue
+ lappend newQueue {*}$InFlightW
+ lappend newQueue {*}$Wqueue
+
+ # 2. Cleanup - none needed, done by the caller.
+
+ ReplayCore $newQueue
+ return
+}
+
+# http::ReInit --
+#
+# Command to restore a token's state to a condition that
+# makes it ready to replay a request.
+#
+# Command http::geturl stores extra state in state(tmp*) so
+# we don't need to do the argument processing again.
+#
+# The caller must:
+# - Set state(reusing) and state(sock) to their new values after calling
+# this command.
+# - Unset state(tmpState), state(tmpOpenCmd) if future calls to ReplayCore
+# or ReInit are inappropriate for this token. Typically only one retry
+# is allowed.
+# The caller may also unset state(tmpConnArgs) if this value (and the
+# token) will be used immediately. The value is needed by tokens that
+# will be stored in a queue.
+#
+# Arguments:
+# token Connection token.
+#
+# Return Value: (boolean) true iff the re-initialisation was successful.
+
+proc http::ReInit {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {!(
+ [info exists state(tmpState)]
+ && [info exists state(tmpOpenCmd)]
+ && [info exists state(tmpConnArgs)]
+ )
+ } {
+ Log FAILED in http::ReInit via ReplayCore - NO tmp vars for $token
+ return 0
+ }
+
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (ReInit)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
+ }
+
+ # Don't alter state(status) - this would trigger http::wait if it is in use.
+ set tmpState $state(tmpState)
+ set tmpOpenCmd $state(tmpOpenCmd)
+ set tmpConnArgs $state(tmpConnArgs)
+ foreach name [array names state] {
+ if {$name ne "status"} {
+ unset state($name)
+ }
+ }
+
+ # Don't alter state(status).
+ # Restore state(tmp*) - the caller may decide to unset them.
+ # Restore state(tmpConnArgs) which is needed for connection.
+ # state(tmpState), state(tmpOpenCmd) are needed only for retries.
+
+ dict unset tmpState status
+ array set state $tmpState
+ set state(tmpState) $tmpState
+ set state(tmpOpenCmd) $tmpOpenCmd
+ set state(tmpConnArgs) $tmpConnArgs
+
+ return 1
+}
+
+# http::ReplayCore --
+#
+# Command to replay a list of requests, using existing connection tokens.
+#
+# Abstracted from http::geturl which stores extra state in state(tmp*) so
+# we don't need to do the argument processing again.
+#
+# Arguments:
+# newQueue List of connection tokens.
+#
+# Side Effects:
+# Use existing tokens, but try to open a new socket.
+
+proc http::ReplayCore {newQueue} {
+ variable TmpSockCounter
+
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ if {[llength $newQueue] == 0} {
+ # Nothing to do.
+ return
+ }
+
+ ##Log running ReplayCore for {*}$newQueue
+ set newToken [lindex $newQueue 0]
+ set newQueue [lrange $newQueue 1 end]
+
+ # 3. Use newToken, and restore its values of state(*). Do not restore
+ # elements tmp* - we try again only once.
+
+ set token $newToken
+ variable $token
+ upvar 0 $token state
+
+ if {![ReInit $token]} {
+ Log FAILED in http::ReplayCore - NO tmp vars
+ Log ReplayCore reject $token
+ Finish $token {cannot send this request again}
+ return
+ }
+
+ set tmpState $state(tmpState)
+ set tmpOpenCmd $state(tmpOpenCmd)
+ set tmpConnArgs $state(tmpConnArgs)
+ unset state(tmpState)
+ unset state(tmpOpenCmd)
+ unset state(tmpConnArgs)
+
+ set state(reusing) 0
+ set state(ReusingPlaceholder) 0
+ set state(alreadyQueued) 0
+ Log ReplayCore replay $token
+
+ # Give the socket a placeholder name before it is created.
+ set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
+ set state(sock) $sock
+
+ # Move the $newQueue into the placeholder socket's socketPhQueue.
+ set socketPhQueue($sock) {}
+ foreach tok $newQueue {
+ if {[ReInit $tok]} {
+ set ${tok}(reusing) 1
+ set ${tok}(sock) $sock
+ lappend socketPhQueue($sock) $tok
+ Log ReplayCore replay $tok
+ } else {
+ Log ReplayCore reject $tok
+ set ${tok}(reusing) 1
+ set ${tok}(sock) NONE
+ Finish $tok {cannot send this request again}
+ }
+ }
+
+ AsyncTransaction $token
+
+ return
+}
+
+# Data access functions:
+# Data - the URL data
+# Status - the transaction status: ok, reset, eof, timeout, error
+# Code - the HTTP transaction code, e.g., 200
+# Size - the size of the URL data
+
+proc http::responseBody {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(body)
+}
+proc http::status {token} {
+ if {![info exists $token]} {
+ return "error"
+ }
+ variable $token
+ upvar 0 $token state
+ return $state(status)
+}
+proc http::responseLine {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(http)
+}
+proc http::requestLine {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(requestLine)
+}
+proc http::responseCode {token} {
+ variable $token
+ upvar 0 $token state
+ if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
+ return $numeric_code
+ } else {
+ return $state(http)
+ }
+}
+proc http::size {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(currentsize)
+}
+proc http::requestHeaders {token args} {
+ set lenny [llength $args]
+ if {$lenny > 1} {
+ return -code error {usage: ::http::requestHeaders token ?headerName?}
+ } else {
+ return [Meta $token request {*}$args]
+ }
+}
+proc http::responseHeaders {token args} {
+ set lenny [llength $args]
+ if {$lenny > 1} {
+ return -code error {usage: ::http::responseHeaders token ?headerName?}
+ } else {
+ return [Meta $token response {*}$args]
+ }
+}
+proc http::requestHeaderValue {token header} {
+ Meta $token request $header VALUE
+}
+proc http::responseHeaderValue {token header} {
+ Meta $token response $header VALUE
+}
+proc http::Meta {token who args} {
+ variable $token
+ upvar 0 $token state
+
+ if {$who eq {request}} {
+ set whom requestHeaders
+ } elseif {$who eq {response}} {
+ set whom meta
+ } else {
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ }
+
+ set header [string tolower [lindex $args 0]]
+ set how [string tolower [lindex $args 1]]
+ set lenny [llength $args]
+ if {$lenny == 0} {
+ return $state($whom)
+ } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ } else {
+ set result {}
+ set combined {}
+ foreach {key value} $state($whom) {
+ if {$key eq $header} {
+ lappend result $key $value
+ append combined $value {, }
+ }
+ }
+ if {$lenny == 1} {
+ return $result
+ } else {
+ return [string range $combined 0 end-2]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::responseInfo
+# ------------------------------------------------------------------------------
+# Command to return a dictionary of the most useful metadata of a HTTP
+# response.
+#
+# Arguments:
+# token - connection token (name of an array)
+#
+# Return Value: a dict. See man page http(n) for a description of each item.
+# ------------------------------------------------------------------------------
+
+proc http::responseInfo {token} {
+ variable $token
+ upvar 0 $token state
+ set result {}
+ foreach {key origin name} {
+ stage STATE state
+ status STATE status
+ responseCode STATE responseCode
+ reasonPhrase STATE reasonPhrase
+ contentType STATE type
+ binary STATE binary
+ redirection RESP location
+ upgrade STATE upgrade
+ error ERROR -
+ postError STATE posterror
+ method STATE method
+ charset STATE charset
+ compression STATE coding
+ httpRequest STATE -protocol
+ httpResponse STATE httpResponse
+ url STATE url
+ connectionRequest REQ connection
+ connectionResponse RESP connection
+ connectionActual STATE connection
+ transferEncoding STATE transfer
+ totalPost STATE querylength
+ currentPost STATE queryoffset
+ totalSize STATE totalsize
+ currentSize STATE currentsize
+ proxyUsed STATE proxyUsed
+ } {
+ if {$origin eq {STATE}} {
+ if {[info exists state($name)]} {
+ dict set result $key $state($name)
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ } elseif {$origin eq {REQ}} {
+ dict set result $key [requestHeaderValue $token $name]
+ } elseif {$origin eq {RESP}} {
+ dict set result $key [responseHeaderValue $token $name]
+ } elseif {$origin eq {ERROR}} {
+ # Don't flood the dict with data. The command ::http::error is
+ # available.
+ if {[info exists state(error)]} {
+ set msg [lindex $state(error) 0]
+ } else {
+ set msg {}
+ }
+ dict set result $key $msg
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ }
+ return $result
+}
+proc http::error {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(error)]} {
+ return $state(error)
+ }
+ return
+}
+proc http::postError {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(postErrorFull)]} {
+ return $state(postErrorFull)
+ }
+ return
+}
+
+# http::cleanup
+#
+# Garbage collect the state associated with a transaction
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Unsets the state array.
+
+proc http::cleanup {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info commands ${token}--EventCoroutine] ne {}} {
+ rename ${token}--EventCoroutine {}
+ }
+ if {[info commands ${token}--SocketCoroutine] ne {}} {
+ rename ${token}--SocketCoroutine {}
+ }
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (cleanup)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
+ }
+ if {[info exists state]} {
+ unset state
+ }
+ return
+}
+
+# http::Connect
+#
+# This callback is made when an asynchronous connection completes.
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Sets the status of the connection, which unblocks
+# the waiting geturl call
+
+proc http::Connect {token proto phost srvurl} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ if {[catch {eof $state(sock)} tmp] || $tmp} {
+ set err "due to unexpected EOF"
+ } elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
+ # set err is done in test
+ } else {
+ # All OK
+ set state(state) connecting
+ fileevent $state(sock) writable {}
+ ::http::Connected $token $proto $phost $srvurl
+ return
+ }
+
+ # Error cases.
+ Log "WARNING - if testing, pay special attention to this\
+ case (GJ) which is seldom executed - token $token"
+ if {[info exists state(reusing)] && $state(reusing)} {
+ # The socket was closed at the server end, and closed at
+ # this end by http::CheckEof.
+ if {[TestForReplay $token write $err b]} {
+ return
+ }
+
+ # else:
+ # This is NOT a persistent socket that has been closed since its
+ # last use.
+ # If any other requests are in flight or pipelined/queued, they will
+ # be discarded.
+ }
+ Finish $token "connect failed: $err"
+ return
+}
+
+# http::Write
+#
+# Write POST query data to the socket
+#
+# Arguments
+# token The token for the connection
+#
+# Side Effects
+# Write the socket and handle callbacks.
+
+proc http::Write {token} {
+ variable http
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ set sock $state(sock)
+
+ # Output a block. Tcl will buffer this if the socket blocks
+ set done 0
+ if {[catch {
+ # Catch I/O errors on dead sockets
+
+ if {[info exists state(-query)]} {
+ # Chop up large query strings so queryprogress callback can give
+ # smooth feedback.
+ if { $state(queryoffset) + $state(-queryblocksize)
+ >= $state(querylength)
+ } {
+ # This will be the last puts for the request-body.
+ if { (![catch {fileevent $sock readable} binding])
+ && ($binding eq [list http::CheckEof $sock])
+ } {
+ # Remove the "fileevent readable" binding of an idle
+ # persistent socket to http::CheckEof. We can no longer
+ # treat bytes received as junk. The server might still time
+ # out and half-close the socket if it has not yet received
+ # the first "puts".
+ fileevent $sock readable {}
+ }
+ }
+ puts -nonewline $sock \
+ [string range $state(-query) $state(queryoffset) \
+ [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
+ incr state(queryoffset) $state(-queryblocksize)
+ if {$state(queryoffset) >= $state(querylength)} {
+ set state(queryoffset) $state(querylength)
+ set done 1
+ }
+ } else {
+ # Copy blocks from the query channel
+
+ set outStr [read $state(-querychannel) $state(-queryblocksize)]
+ if {[eof $state(-querychannel)]} {
+ # This will be the last puts for the request-body.
+ if { (![catch {fileevent $sock readable} binding])
+ && ($binding eq [list http::CheckEof $sock])
+ } {
+ # Remove the "fileevent readable" binding of an idle
+ # persistent socket to http::CheckEof. We can no longer
+ # treat bytes received as junk. The server might still time
+ # out and half-close the socket if it has not yet received
+ # the first "puts".
+ fileevent $sock readable {}
+ }
+ }
+ puts -nonewline $sock $outStr
+ incr state(queryoffset) [string length $outStr]
+ if {[eof $state(-querychannel)]} {
+ set done 1
+ }
+ }
+ } err opts]} {
+ # Do not call Finish here, but instead let the read half of the socket
+ # process whatever server reply there is to get.
+ set state(posterror) $err
+ set info [dict get $opts -errorinfo]
+ set code [dict get $opts -code]
+ set state(postErrorFull) [list $err $info $code]
+ set done 1
+ }
+
+ if {$done} {
+ catch {flush $sock}
+ fileevent $sock writable {}
+ Log ^C$tk end sending request - token $token
+ # End of writing (POST method). The request has been sent.
+
+ DoneRequest $token
+ }
+
+ # Callback to the client after we've completely handled everything.
+
+ if {[string length $state(-queryprogress)]} {
+ namespace eval :: $state(-queryprogress) \
+ [list $token $state(querylength) $state(queryoffset)]
+ }
+ return
+}
+
+# http::Event
+#
+# Handle input on the socket. This command is the core of
+# the coroutine commands ${token}--EventCoroutine that are
+# bound to "fileevent $sock readable" and process input.
+#
+# Arguments
+# sock The socket receiving input.
+# token The token returned from http::geturl
+#
+# Side Effects
+# Read the socket and handle callbacks.
+
+proc http::Event {sock token} {
+ variable http
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ while 1 {
+ yield
+ ##Log Event call - token $token
+
+ if {![info exists state]} {
+ Log "Event $sock with invalid token '$token' - remote close?"
+ if {!([catch {eof $sock} tmp] || $tmp)} {
+ if {[set d [read $sock]] ne ""} {
+ Log "WARNING: additional data left on closed socket\
+ - token $token"
+ } else {
+ }
+ } else {
+ }
+ Log ^X$tk end of response (token error) - token $token
+ CloseSocket $sock
+ return
+ } else {
+ }
+ if {$state(state) eq "connecting"} {
+ ##Log - connecting - token $token
+ if { $state(reusing)
+ && $state(-pipeline)
+ && ($state(-timeout) > 0)
+ && (![info exists state(after)])
+ } {
+ set state(after) [after $state(-timeout) \
+ [list http::reset $token timeout]]
+ } else {
+ }
+
+ if {[catch {gets $sock state(http)} nsl]} {
+ Log "WARNING - if testing, pay special attention to this\
+ case (GK) which is seldom executed - token $token"
+ if {[info exists state(reusing)] && $state(reusing)} {
+ # The socket was closed at the server end, and closed at
+ # this end by http::CheckEof.
+
+ if {[TestForReplay $token read $nsl c]} {
+ return
+ } else {
+ }
+ # else:
+ # This is NOT a persistent socket that has been closed since
+ # its last use.
+ # If any other requests are in flight or pipelined/queued,
+ # they will be discarded.
+ } else {
+ # https handshake errors come here, for
+ # Tcl 8.7 with http::SecureProxyConnect.
+ set msg [registerError $sock]
+ registerError $sock {}
+ if {$msg eq {}} {
+ set msg $nsl
+ }
+ Log ^X$tk end of response (error) - token $token
+ Finish $token $msg
+ return
+ }
+ } elseif {$nsl >= 0} {
+ ##Log - connecting 1 - token $token
+ set state(state) "header"
+ } elseif { ([catch {eof $sock} tmp] || $tmp)
+ && [info exists state(reusing)]
+ && $state(reusing)
+ } {
+ # The socket was closed at the server end, and we didn't notice.
+ # This is the first read - where the closure is usually first
+ # detected.
+
+ if {[TestForReplay $token read {} d]} {
+ return
+ } else {
+ }
+
+ # else:
+ # This is NOT a persistent socket that has been closed since its
+ # last use.
+ # If any other requests are in flight or pipelined/queued, they
+ # will be discarded.
+ } else {
+ }
+ } elseif {$state(state) eq "header"} {
+ if {[catch {gets $sock line} nhl]} {
+ ##Log header failed - token $token
+ Log ^X$tk end of response (error) - token $token
+ Finish $token $nhl
+ return
+ } elseif {$nhl == 0} {
+ ##Log header done - token $token
+ Log ^E$tk end of response headers - token $token
+ # We have now read all headers
+ # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
+ if { ($state(http) == "")
+ || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)
+ } {
+ set state(state) "connecting"
+ continue
+ # This was a "return" in the pre-coroutine code.
+ } else {
+ }
+
+ # We have $state(http) so let's split it into its components.
+ if {[regexp {^HTTP/(\S+) ([0-9]{3}) (.*)$} $state(http) \
+ -> httpResponse responseCode reasonPhrase]
+ } {
+ set state(httpResponse) $httpResponse
+ set state(responseCode) $responseCode
+ set state(reasonPhrase) $reasonPhrase
+ } else {
+ set state(httpResponse) $state(http)
+ set state(responseCode) $state(http)
+ set state(reasonPhrase) $state(http)
+ }
+
+ if { ([info exists state(connection)])
+ && ([info exists socketMapping($state(socketinfo))])
+ && ("keep-alive" in $state(connection))
+ && ($state(-keepalive))
+ && (!$state(reusing))
+ && ($state(-pipeline))
+ } {
+ # Response headers received for first request on a
+ # persistent socket. Now ready for pipelined writes (if
+ # any).
+ # Previous value is $token. It cannot be "pending".
+ set socketWrState($state(socketinfo)) Wready
+ http::NextPipelinedWrite $token
+ } else {
+ }
+
+ # Once a "close" has been signaled, the client MUST NOT send any
+ # more requests on that connection.
+ #
+ # If either the client or the server sends the "close" token in
+ # the Connection header, that request becomes the last one for
+ # the connection.
+
+ if { ([info exists state(connection)])
+ && ([info exists socketMapping($state(socketinfo))])
+ && ("close" in $state(connection))
+ && ($state(-keepalive))
+ } {
+ # The server warns that it will close the socket after this
+ # response.
+ ##Log WARNING - socket will close after response for $token
+ # Prepare data for a call to ReplayIfClose.
+ Log $token socket will close after this transaction
+ # 1. Cancel socket-assignment coro events that have not yet
+ # launched, and add the tokens to the write queue.
+ if {[info exists socketCoEvent($state(socketinfo))]} {
+ foreach {tok can} $socketCoEvent($state(socketinfo)) {
+ lappend socketWrQueue($state(socketinfo)) $tok
+ unset -nocomplain ${tok}(socketcoro)
+ after cancel $can
+ Log $tok Cancel socket after-idle event (Event)
+ Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro
+ }
+ set socketCoEvent($state(socketinfo)) {}
+ } else {
+ }
+
+ if { ($socketRdQueue($state(socketinfo)) ne {})
+ || ($socketWrQueue($state(socketinfo)) ne {})
+ || ($socketWrState($state(socketinfo)) ni
+ [list Wready peNding $token])
+ } {
+ set InFlightW $socketWrState($state(socketinfo))
+ if {$InFlightW in [list Wready peNding $token]} {
+ set InFlightW Wready
+ } else {
+ set msg "token ${InFlightW} is InFlightW"
+ ##Log $msg - token $token
+ }
+ set socketPlayCmd($state(socketinfo)) \
+ [list ReplayIfClose $InFlightW \
+ $socketRdQueue($state(socketinfo)) \
+ $socketWrQueue($state(socketinfo))]
+
+ # - All tokens are preserved for re-use by ReplayCore.
+ # - Queues are preserved in case of Finish with error,
+ # but are not used for anything else because
+ # socketClosing(*) is set below.
+ # - Cancel the state(after) timeout events.
+ foreach tokenVal $socketRdQueue($state(socketinfo)) {
+ if {[info exists ${tokenVal}(after)]} {
+ after cancel [set ${tokenVal}(after)]
+ unset ${tokenVal}(after)
+ } else {
+ }
+ # Tokens in the read queue have no (socketcoro) to
+ # cancel.
+ }
+ } else {
+ set socketPlayCmd($state(socketinfo)) \
+ {ReplayIfClose Wready {} {}}
+ }
+
+ # Do not allow further connections on this socket (but
+ # geturl can add new requests to the replay).
+ set socketClosing($state(socketinfo)) 1
+ } else {
+ }
+
+ set state(state) body
+
+ # According to
+ # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
+ # any comma-separated "Connection:" list implies keep-alive, but I
+ # don't see this in the RFC so we'll play safe and
+ # scan any list for "close".
+ # Done here to support combining duplicate header field's values.
+ if { [info exists state(connection)]
+ && ("close" ni $state(connection))
+ && ("keep-alive" ni $state(connection))
+ } {
+ lappend state(connection) "keep-alive"
+ } else {
+ }
+
+ # If doing a HEAD, then we won't get any body
+ if {$state(-validate)} {
+ Log ^F$tk end of response for HEAD request - token $token
+ set state(state) complete
+ Eot $token
+ return
+ } elseif {
+ ($state(method) eq {CONNECT})
+ && [string is integer -strict $state(responseCode)]
+ && ($state(responseCode) >= 200)
+ && ($state(responseCode) < 300)
+ } {
+ # A successful CONNECT response has no body.
+ # (An unsuccessful CONNECT has headers and body.)
+ # The code below is abstracted from Eot/Finish, but
+ # keeps the socket open.
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ set state(state) complete
+ set state(status) ok
+ if {[info commands ${token}--EventCoroutine] ne {}} {
+ rename ${token}--EventCoroutine {}
+ }
+ if {[info commands ${token}--SocketCoroutine] ne {}} {
+ rename ${token}--SocketCoroutine {}
+ }
+ if {[info exists state(socketcoro)]} {
+ Log $token Cancel socket after-idle event (Finish)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
+ }
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+ if { [info exists state(-command)]
+ && (![info exists state(done-command-cb)])
+ } {
+ set state(done-command-cb) yes
+ if {[catch {namespace eval :: $state(-command) $token} err]} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+ return
+ } else {
+ }
+
+ # - For non-chunked transfer we may have no body - in this case
+ # we may get no further file event if the connection doesn't
+ # close and no more data is sent. We can tell and must finish
+ # up now - not later - the alternative would be to wait until
+ # the server times out.
+ # - In this case, the server has NOT told the client it will
+ # close the connection, AND it has NOT indicated the resource
+ # length EITHER by setting the Content-Length (totalsize) OR
+ # by using chunked Transfer-Encoding.
+ # - Do not worry here about the case (Connection: close) because
+ # the server should close the connection.
+ # - IF (NOT Connection: close) AND (NOT chunked encoding) AND
+ # (totalsize == 0).
+
+ if { (!( [info exists state(connection)]
+ && ("close" in $state(connection))
+ )
+ )
+ && ($state(transfer) eq {})
+ && ($state(totalsize) == 0)
+ } {
+ set msg {body size is 0 and no events likely - complete}
+ Log "$msg - token $token"
+ set msg {(length unknown, set to 0)}
+ Log ^F$tk end of response body {*}$msg - token $token
+ set state(state) complete
+ Eot $token
+ return
+ } else {
+ }
+
+ # We have to use binary translation to count bytes properly.
+ lassign [fconfigure $sock -translation] trRead trWrite
+ fconfigure $sock -translation [list binary $trWrite]
+
+ if {
+ $state(-binary) || [IsBinaryContentType $state(type)]
+ } {
+ # Turn off conversions for non-text data.
+ set state(binary) 1
+ } else {
+ }
+ if {[info exists state(-channel)]} {
+ if {$state(binary) || [llength [ContentEncoding $token]]} {
+ fconfigure $state(-channel) -translation binary
+ } else {
+ }
+ if {![info exists state(-handler)]} {
+ # Initiate a sequence of background fcopies.
+ fileevent $sock readable {}
+ rename ${token}--EventCoroutine {}
+ CopyStart $sock $token
+ return
+ } else {
+ }
+ } else {
+ }
+ } elseif {$nhl > 0} {
+ # Process header lines.
+ ##Log header - token $token - $line
+ if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
+ set key [string tolower $key]
+ switch -- $key {
+ content-type {
+ set state(type) [string trim [string tolower $value]]
+ # Grab the optional charset information.
+ if {[regexp -nocase \
+ {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \
+ $state(type) -> cs]} {
+ set state(charset) [string map {{\"} \"} $cs]
+ } else {
+ regexp -nocase {charset\s*=\s*(\S+?);?} \
+ $state(type) -> state(charset)
+ }
+ }
+ content-length {
+ set state(totalsize) [string trim $value]
+ }
+ content-encoding {
+ set state(coding) [string trim $value]
+ }
+ transfer-encoding {
+ set state(transfer) \
+ [string trim [string tolower $value]]
+ }
+ proxy-connection -
+ connection {
+ # RFC 7230 Section 6.1 states that a comma-separated
+ # list is an acceptable value.
+ if {![info exists state(connectionRespFlag)]} {
+ # This is the first "Connection" response header.
+ # Scrub the earlier value set by iniitialisation.
+ set state(connectionRespFlag) {}
+ set state(connection) {}
+ }
+ foreach el [SplitCommaSeparatedFieldValue $value] {
+ lappend state(connection) [string tolower $el]
+ }
+ }
+ upgrade {
+ set state(upgrade) [string trim $value]
+ }
+ set-cookie {
+ if {$http(-cookiejar) ne ""} {
+ ParseCookie $token [string trim $value]
+ } else {
+ }
+ }
+ }
+ lappend state(meta) $key [string trim $value]
+ } else {
+ }
+ } else {
+ }
+ } else {
+ # Now reading body
+ ##Log body - token $token
+ if {[catch {
+ if {[info exists state(-handler)]} {
+ set n [namespace eval :: $state(-handler) [list $sock $token]]
+ ##Log handler $n - token $token
+ # N.B. the protocol has been set to 1.0 because the -handler
+ # logic is not expected to handle chunked encoding.
+ # FIXME Allow -handler with 1.1 on dechunked stacked chan.
+ if {$state(totalsize) == 0} {
+ # We know the transfer is complete only when the server
+ # closes the connection - i.e. eof is not an error.
+ set state(state) complete
+ } else {
+ }
+ if {![string is integer -strict $n]} {
+ if 1 {
+ # Do not tolerate bad -handler - fail with error
+ # status.
+ set msg {the -handler command for http::geturl must\
+ return an integer (the number of bytes\
+ read)}
+ Log ^X$tk end of response (handler error) -\
+ token $token
+ Eot $token $msg
+ } else {
+ # Tolerate the bad -handler, and continue. The
+ # penalty:
+ # (a) Because the handler returns nonsense, we know
+ # the transfer is complete only when the server
+ # closes the connection - i.e. eof is not an
+ # error.
+ # (b) http::size will not be accurate.
+ # (c) The transaction is already downgraded to 1.0
+ # to avoid chunked transfer encoding. It MUST
+ # also be forced to "Connection: close" or the
+ # HTTP/1.0 equivalent; or it MUST fail (as
+ # above) if the server sends
+ # "Connection: keep-alive" or the HTTP/1.0
+ # equivalent.
+ set n 0
+ set state(state) complete
+ }
+ } else {
+ }
+ } elseif {[info exists state(transfer_final)]} {
+ # This code forgives EOF in place of the final CRLF.
+ set line [GetTextLine $sock]
+ set n [string length $line]
+ set state(state) complete
+ if {$n > 0} {
+ # - HTTP trailers (late response headers) are permitted
+ # by Chunked Transfer-Encoding, and can be safely
+ # ignored.
+ # - Do not count these bytes in the total received for
+ # the response body.
+ Log "trailer of $n bytes after final chunk -\
+ token $token"
+ append state(transfer_final) $line
+ set n 0
+ } else {
+ Log ^F$tk end of response body (chunked) - token $token
+ Log "final chunk part - token $token"
+ Eot $token
+ }
+ } elseif { [info exists state(transfer)]
+ && ($state(transfer) eq "chunked")
+ } {
+ ##Log chunked - token $token
+ set size 0
+ set hexLenChunk [GetTextLine $sock]
+ #set ntl [string length $hexLenChunk]
+ if {[string trim $hexLenChunk] ne ""} {
+ scan $hexLenChunk %x size
+ if {$size != 0} {
+ ##Log chunk-measure $size - token $token
+ set chunk [BlockingRead $sock $size]
+ set n [string length $chunk]
+ if {$n >= 0} {
+ append state(body) $chunk
+ incr state(log_size) [string length $chunk]
+ ##Log chunk $n cumul $state(log_size) -\
+ token $token
+ } else {
+ }
+ if {$size != [string length $chunk]} {
+ Log "WARNING: mis-sized chunk:\
+ was [string length $chunk], should be\
+ $size - token $token"
+ set n 0
+ set state(connection) close
+ Log ^X$tk end of response (chunk error) \
+ - token $token
+ set msg {error in chunked encoding - fetch\
+ terminated}
+ Eot $token $msg
+ } else {
+ }
+ # CRLF that follows chunk.
+ # If eof, this is handled at the end of this proc.
+ GetTextLine $sock
+ } else {
+ set n 0
+ set state(transfer_final) {}
+ }
+ } else {
+ # Line expected to hold chunk length is empty, or eof.
+ ##Log bad-chunk-measure - token $token
+ set n 0
+ set state(connection) close
+ Log ^X$tk end of response (chunk error) - token $token
+ Eot $token {error in chunked encoding -\
+ fetch terminated}
+ }
+ } else {
+ ##Log unchunked - token $token
+ if {$state(totalsize) == 0} {
+ # We know the transfer is complete only when the server
+ # closes the connection.
+ set state(state) complete
+ set reqSize $state(-blocksize)
+ } else {
+ # Ask for the whole of the unserved response-body.
+ # This works around a problem with a tls::socket - for
+ # https in keep-alive mode, and a request for
+ # $state(-blocksize) bytes, the last part of the
+ # resource does not get read until the server times out.
+ set reqSize [expr { $state(totalsize)
+ - $state(currentsize)}]
+
+ # The workaround fails if reqSize is
+ # capped at $state(-blocksize).
+ # set reqSize [expr {min($reqSize, $state(-blocksize))}]
+ }
+ set c $state(currentsize)
+ set t $state(totalsize)
+ ##Log non-chunk currentsize $c of totalsize $t -\
+ token $token
+ set block [read $sock $reqSize]
+ set n [string length $block]
+ if {$n >= 0} {
+ append state(body) $block
+ ##Log non-chunk [string length $state(body)] -\
+ token $token
+ } else {
+ }
+ }
+ # This calculation uses n from the -handler, chunked, or
+ # unchunked case as appropriate.
+ if {[info exists state]} {
+ if {$n >= 0} {
+ incr state(currentsize) $n
+ set c $state(currentsize)
+ set t $state(totalsize)
+ ##Log another $n currentsize $c totalsize $t -\
+ token $token
+ } else {
+ }
+ # If Content-Length - check for end of data.
+ if {
+ ($state(totalsize) > 0)
+ && ($state(currentsize) >= $state(totalsize))
+ } {
+ Log ^F$tk end of response body (unchunked) -\
+ token $token
+ set state(state) complete
+ Eot $token
+ } else {
+ }
+ } else {
+ }
+ } err]} {
+ Log ^X$tk end of response (error ${err}) - token $token
+ Finish $token $err
+ return
+ } else {
+ if {[info exists state(-progress)]} {
+ namespace eval :: $state(-progress) \
+ [list $token $state(totalsize) $state(currentsize)]
+ } else {
+ }
+ }
+ }
+
+ # catch as an Eot above may have closed the socket already
+ # $state(state) may be connecting, header, body, or complete
+ if {(![catch {eof $sock} eof]) && $eof} {
+ # [eof sock] succeeded and the result was 1
+ ##Log eof - token $token
+ if {[info exists $token]} {
+ set state(connection) close
+ if {$state(state) eq "complete"} {
+ # This includes all cases in which the transaction
+ # can be completed by eof.
+ # The value "complete" is set only in http::Event, and it is
+ # used only in the test above.
+ Log ^F$tk end of response body (unchunked, eof) -\
+ token $token
+ Eot $token
+ } else {
+ # Premature eof.
+ Log ^X$tk end of response (unexpected eof) - token $token
+ Eot $token eof
+ }
+ } else {
+ # open connection closed on a token that has been cleaned up.
+ Log ^X$tk end of response (token error) - token $token
+ CloseSocket $sock
+ }
+ } else {
+ # EITHER [eof sock] failed - presumed done by Eot
+ # OR [eof sock] succeeded and the result was 0
+ }
+ }
+ return
+}
+
+# http::TestForReplay
+#
+# Command called if eof is discovered when a socket is first used for a
+# new transaction. Typically this occurs if a persistent socket is used
+# after a period of idleness and the server has half-closed the socket.
+#
+# token - the connection token returned by http::geturl
+# doing - "read" or "write"
+# err - error message, if any
+# caller - code to identify the caller - used only in logging
+#
+# Return Value: boolean, true iff the command calls http::ReplayIfDead.
+
+proc http::TestForReplay {token doing err caller} {
+ variable http
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ if {$doing eq "read"} {
+ set code Q
+ set action response
+ set ing reading
+ } else {
+ set code P
+ set action request
+ set ing writing
+ }
+
+ if {$err eq {}} {
+ set err "detect eof when $ing (server timed out?)"
+ }
+
+ if {$state(method) eq "POST" && !$http(-repost)} {
+ # No Replay.
+ # The present transaction will end when Finish is called.
+ # That call to Finish will abort any other transactions
+ # currently in the write queue.
+ # For calls from http::Event this occurs when execution
+ # reaches the code block at the end of that proc.
+ set msg {no retry for POST with http::config -repost 0}
+ Log reusing socket failed "($caller)" - $msg - token $token
+ Log error - $err - token $token
+ Log ^X$tk end of $action (error) - token $token
+ return 0
+ } else {
+ # Replay.
+ set msg {try a new socket}
+ Log reusing socket failed "($caller)" - $msg - token $token
+ Log error - $err - token $token
+ Log ^$code$tk Any unfinished (incl this one) failed - token $token
+ ReplayIfDead $token $doing
+ return 1
+ }
+}
+
+# http::IsBinaryContentType --
+#
+# Determine if the content-type means that we should definitely transfer
+# the data as binary. [Bug 838e99a76d]
+#
+# Arguments
+# type The content-type of the data.
+#
+# Results:
+# Boolean, true if we definitely should be binary.
+
+proc http::IsBinaryContentType {type} {
+ lassign [split [string tolower $type] "/;"] major minor
+ if {$major eq "text"} {
+ return false
+ }
+ # There's a bunch of XML-as-application-format things about. See RFC 3023
+ # and so on.
+ if {$major eq "application"} {
+ set minor [string trimright $minor]
+ if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} {
+ return false
+ }
+ }
+ # Not just application/foobar+xml but also image/svg+xml, so let us not
+ # restrict things for now...
+ if {[string match "*+xml" $minor]} {
+ return false
+ }
+ return true
+}
+
+proc http::ParseCookie {token value} {
+ variable http
+ variable CookieRE
+ variable $token
+ upvar 0 $token state
+
+ if {![regexp $CookieRE $value -> cookiename cookieval opts]} {
+ # Bad cookie! No biscuit!
+ return
+ }
+
+ # Convert the options into a list before feeding into the cookie store;
+ # ugly, but quite easy.
+ set realopts {hostonly 1 path / secure 0 httponly 0}
+ dict set realopts origin $state(host)
+ dict set realopts domain $state(host)
+ foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] {
+ regexp {^(.*?)(?:=(.*))?$} $option -> optname optval
+ switch -exact -- [string tolower $optname] {
+ expires {
+ if {[catch {
+ #Sun, 06 Nov 1994 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d %b %Y %T %Z"]
+ }] && [catch {
+ # Google does this one
+ #Mon, 01-Jan-1990 00:00:00 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d-%b-%Y %T %Z"]
+ }] && [catch {
+ # This is in the RFC, but it is also in the original
+ # Netscape cookie spec, now online at:
+ #
+ #Sunday, 06-Nov-94 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%A, %d-%b-%y %T %Z"]
+ }]} {catch {
+ #Sun Nov 6 08:49:37 1994
+ dict set realopts expires \
+ [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"]
+ }}
+ }
+ max-age {
+ # Normalize
+ if {[string is integer -strict $optval]} {
+ dict set realopts expires [expr {[clock seconds] + $optval}]
+ }
+ }
+ domain {
+ # From the domain-matches definition [RFC 2109, section 2]:
+ # Host A's name domain-matches host B's if [...]
+ # A is a FQDN string and has the form NB, where N is a
+ # non-empty name string, B has the form .B', and B' is a
+ # FQDN string. (So, x.y.com domain-matches .y.com but
+ # not y.com.)
+ if {$optval ne "" && ![string match *. $optval]} {
+ dict set realopts domain [string trimleft $optval "."]
+ dict set realopts hostonly [expr {
+ ! [string match .* $optval]
+ }]
+ }
+ }
+ path {
+ if {[string match /* $optval]} {
+ dict set realopts path $optval
+ }
+ }
+ secure - httponly {
+ dict set realopts [string tolower $optname] 1
+ }
+ }
+ }
+ dict set realopts key $cookiename
+ dict set realopts value $cookieval
+ {*}$http(-cookiejar) storeCookie $realopts
+}
+
+# http::GetTextLine --
+#
+# Get one line with the stream in crlf mode.
+# Used if Transfer-Encoding is chunked, to read the line that
+# reports the size of the following chunk.
+# Empty line is not distinguished from eof. The caller must
+# be able to handle this.
+#
+# Arguments
+# sock The socket receiving input.
+#
+# Results:
+# The line of text, without trailing newline
+
+proc http::GetTextLine {sock} {
+ set tr [fconfigure $sock -translation]
+ lassign $tr trRead trWrite
+ fconfigure $sock -translation [list crlf $trWrite]
+ set r [BlockingGets $sock]
+ fconfigure $sock -translation $tr
+ return $r
+}
+
+# http::BlockingRead
+#
+# Replacement for a blocking read.
+# The caller must be a coroutine.
+# Used when we expect to read a chunked-encoding
+# chunk of known size.
+
+proc http::BlockingRead {sock size} {
+ if {$size < 1} {
+ return
+ }
+ set result {}
+ while 1 {
+ set need [expr {$size - [string length $result]}]
+ set block [read $sock $need]
+ set eof [expr {[catch {eof $sock} tmp] || $tmp}]
+ append result $block
+ if {[string length $result] >= $size || $eof} {
+ return $result
+ } else {
+ yield
+ }
+ }
+}
+
+# http::BlockingGets
+#
+# Replacement for a blocking gets.
+# The caller must be a coroutine.
+# Empty line is not distinguished from eof. The caller must
+# be able to handle this.
+
+proc http::BlockingGets {sock} {
+ while 1 {
+ set count [gets $sock line]
+ set eof [expr {[catch {eof $sock} tmp] || $tmp}]
+ if {$count >= 0 || $eof} {
+ return $line
+ } else {
+ yield
+ }
+ }
+}
+
+# http::CopyStart
+#
+# Error handling wrapper around fcopy
+#
+# Arguments
+# sock The socket to copy from
+# token The token returned from http::geturl
+#
+# Side Effects
+# This closes the connection upon error
+
+proc http::CopyStart {sock token {initial 1}} {
+ upvar 0 $token state
+ if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
+ foreach coding [ContentEncoding $token] {
+ if {$coding eq {deflateX}} {
+ # Use the standards-compliant choice.
+ set coding2 decompress
+ } else {
+ set coding2 $coding
+ }
+ lappend state(zlib) [zlib stream $coding2]
+ }
+ MakeTransformationChunked $sock [namespace code [list CopyChunk $token]]
+ } else {
+ if {$initial} {
+ foreach coding [ContentEncoding $token] {
+ if {$coding eq {deflateX}} {
+ # Use the standards-compliant choice.
+ set coding2 decompress
+ } else {
+ set coding2 $coding
+ }
+ zlib push $coding2 $sock
+ }
+ }
+ if {[catch {
+ # FIXME Keep-Alive on https tls::socket with unchunked transfer
+ # hangs until the server times out. A workaround is possible, as for
+ # the case without -channel, but it does not use the neat "fcopy"
+ # solution.
+ fcopy $sock $state(-channel) -size $state(-blocksize) -command \
+ [list http::CopyDone $token]
+ } err]} {
+ Finish $token $err
+ }
+ }
+ return
+}
+
+proc http::CopyChunk {token chunk} {
+ upvar 0 $token state
+ if {[set count [string length $chunk]]} {
+ incr state(currentsize) $count
+ if {[info exists state(zlib)]} {
+ foreach stream $state(zlib) {
+ set chunk [$stream add $chunk]
+ }
+ }
+ puts -nonewline $state(-channel) $chunk
+ if {[info exists state(-progress)]} {
+ namespace eval :: [linsert $state(-progress) end \
+ $token $state(totalsize) $state(currentsize)]
+ }
+ } else {
+ Log "CopyChunk Finish - token $token"
+ if {[info exists state(zlib)]} {
+ set excess ""
+ foreach stream $state(zlib) {
+ catch {
+ $stream put -finalize $excess
+ set excess ""
+ set overflood ""
+ while {[set overflood [$stream get]] ne ""} { append excess $overflood }
+ }
+ }
+ puts -nonewline $state(-channel) $excess
+ foreach stream $state(zlib) { $stream close }
+ unset state(zlib)
+ }
+ Eot $token ;# FIX ME: pipelining.
+ }
+ return
+}
+
+# http::CopyDone
+#
+# fcopy completion callback
+#
+# Arguments
+# token The token returned from http::geturl
+# count The amount transferred
+#
+# Side Effects
+# Invokes callbacks
+
+proc http::CopyDone {token count {error {}}} {
+ variable $token
+ upvar 0 $token state
+ set sock $state(sock)
+ incr state(currentsize) $count
+ if {[info exists state(-progress)]} {
+ namespace eval :: $state(-progress) \
+ [list $token $state(totalsize) $state(currentsize)]
+ }
+ # At this point the token may have been reset.
+ if {[string length $error]} {
+ Finish $token $error
+ } elseif {[catch {eof $sock} iseof] || $iseof} {
+ Eot $token
+ } else {
+ CopyStart $sock $token 0
+ }
+ return
+}
+
+# http::Eot
+#
+# Called when either:
+# a. An eof condition is detected on the socket.
+# b. The client decides that the response is complete.
+# c. The client detects an inconsistency and aborts the transaction.
+#
+# Does:
+# 1. Set state(status)
+# 2. Reverse any Content-Encoding
+# 3. Convert charset encoding and line ends if necessary
+# 4. Call http::Finish
+#
+# Arguments
+# token The token returned from http::geturl
+# force (previously) optional, has no effect
+# reason - "eof" means premature EOF (not EOF as the natural end of
+# the response)
+# - "" means completion of response, with or without EOF
+# - anything else describes an error condition other than
+# premature EOF.
+#
+# Side Effects
+# Clean up the socket
+
+proc http::Eot {token {reason {}}} {
+ variable $token
+ upvar 0 $token state
+ if {$reason eq "eof"} {
+ # Premature eof.
+ set state(status) eof
+ set reason {}
+ } elseif {$reason ne ""} {
+ # Abort the transaction.
+ set state(status) $reason
+ } else {
+ # The response is complete.
+ set state(status) ok
+ }
+
+ if {[string length $state(body)] > 0} {
+ if {[catch {
+ foreach coding [ContentEncoding $token] {
+ if {$coding eq {deflateX}} {
+ # First try the standards-compliant choice.
+ set coding2 decompress
+ if {[catch {zlib $coding2 $state(body)} result]} {
+ # If that fails, try the MS non-compliant choice.
+ set coding2 inflate
+ set state(body) [zlib $coding2 $state(body)]
+ } else {
+ # error {failed at standards-compliant deflate}
+ set state(body) $result
+ }
+ } else {
+ set state(body) [zlib $coding $state(body)]
+ }
+ }
+ } err]} {
+ Log "error doing decompression for token $token: $err"
+ Finish $token $err
+ return
+ }
+
+ if {!$state(binary)} {
+ # If we are getting text, set the incoming channel's encoding
+ # correctly. iso8859-1 is the RFC default, but this could be any
+ # IANA charset. However, we only know how to convert what we have
+ # encodings for.
+
+ set enc [CharsetToEncoding $state(charset)]
+ if {$enc ne "binary"} {
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)]
+ } else {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
+ }
+
+ # Translate text line endings.
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ }
+ if {[info exists state(-guesstype)] && $state(-guesstype)} {
+ GuessType $token
+ }
+ }
+ Finish $token $reason
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::GuessType
+# ------------------------------------------------------------------------------
+# Command to attempt limited analysis of a resource with undetermined
+# Content-Type, i.e. "application/octet-stream". This value can be set for two
+# reasons:
+# (a) by the server, in a Content-Type header
+# (b) by http::geturl, as the default value if the server does not supply a
+# Content-Type header.
+#
+# This command converts a resource if:
+# (1) it has type application/octet-stream
+# (2) it begins with an XML declaration "?"
+# (3) one tag is named "encoding" and has a recognised value; or no "encoding"
+# tag exists (defaulting to utf-8)
+#
+# RFC 9110 Sec. 8.3 states:
+# "If a Content-Type header field is not present, the recipient MAY either
+# assume a media type of "application/octet-stream" ([RFC2046], Section 4.5.1)
+# or examine the data to determine its type."
+#
+# The RFC goes on to describe the pitfalls of "MIME sniffing", including
+# possible security risks.
+#
+# Arguments:
+# token - connection token
+#
+# Return Value: (boolean) true iff a change has been made
+# ------------------------------------------------------------------------------
+
+proc http::GuessType {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {$state(type) ne {application/octet-stream}} {
+ return 0
+ }
+
+ set body $state(body)
+ # e.g. { ...}
+
+ if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
+ return 0
+ }
+ # e.g. {}
+
+ set contents [regsub -- {[[:space:]]+} $match { }]
+ set contents [string range [string tolower $contents] 6 end-2]
+ # e.g. {version="1.0" encoding="utf-8"}
+ # without excess whitespace or upper-case letters
+
+ if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
+ return 0
+ }
+ # The application/xml default encoding:
+ set res utf-8
+
+ set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
+ foreach tag $tagList {
+ regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
+ if {$name eq {encoding}} {
+ set res $value
+ }
+ }
+ set enc [CharsetToEncoding $res]
+ if {$enc eq "binary"} {
+ return 0
+ }
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)]
+ } else {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ set state(type) application/xml
+ set state(binary) 0
+ set state(charset) $res
+ return 1
+}
+
+
+# http::wait --
+#
+# See documentation for details.
+#
+# Arguments:
+# token Connection token.
+#
+# Results:
+# The status after the wait.
+
+proc http::wait {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {![info exists state(status)] || $state(status) eq ""} {
+ # We must wait on the original variable name, not the upvar alias
+ vwait ${token}(status)
+ }
+
+ return [status $token]
+}
+
+# http::formatQuery --
+#
+# See documentation for details. Call http::formatQuery with an even
+# number of arguments, where the first is a name, the second is a value,
+# the third is another name, and so on.
+#
+# Arguments:
+# args A list of name-value pairs.
+#
+# Results:
+# TODO
+
+proc http::formatQuery {args} {
+ if {[llength $args] % 2} {
+ return \
+ -code error \
+ -errorcode [list HTTP BADARGCNT $args] \
+ {Incorrect number of arguments, must be an even number.}
+ }
+ set result ""
+ set sep ""
+ foreach i $args {
+ append result $sep [quoteString $i]
+ if {$sep eq "="} {
+ set sep &
+ } else {
+ set sep =
+ }
+ }
+ return $result
+}
+
+# http::quoteString --
+#
+# Do x-www-urlencoded character mapping
+#
+# Arguments:
+# string The string the needs to be encoded
+#
+# Results:
+# The encoded string
+
+proc http::quoteString {string} {
+ variable http
+ variable formMap
+
+ # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
+ # a pre-computed map and [string map] to do the conversion (much faster
+ # than [regsub]/[subst]). [Bug 1020491]
+
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ set string [encoding convertto -profile tcl8 $http(-urlencoding) $string]
+ } else {
+ set string [encoding convertto $http(-urlencoding) $string]
+ }
+ return [string map $formMap $string]
+}
+
+# http::ProxyRequired --
+# Default proxy filter.
+#
+# Arguments:
+# host The destination host
+#
+# Results:
+# The current proxy settings
+
+proc http::ProxyRequired {host} {
+ variable http
+ if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
+ return
+ }
+ if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
+ set port 8080
+ } else {
+ set port $http(-proxyport)
+ }
+
+ # Simple test (cf. autoproxy) for hosts that must be accessed directly,
+ # not through the proxy server.
+ foreach domain $http(-proxynot) {
+ if {[string match -nocase $domain $host]} {
+ return {}
+ }
+ }
+ return [list $http(-proxyhost) $port]
+}
+
+# http::CharsetToEncoding --
+#
+# Tries to map a given IANA charset to a tcl encoding. If no encoding
+# can be found, returns binary.
+#
+
+proc http::CharsetToEncoding {charset} {
+ variable encodings
+
+ set charset [string tolower $charset]
+ if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} {
+ set encoding "iso8859-$num"
+ } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} {
+ set encoding "iso2022-$ext"
+ } elseif {[regexp {shift[-_]?jis} $charset]} {
+ set encoding "shiftjis"
+ } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} {
+ set encoding "cp$num"
+ } elseif {$charset eq "us-ascii"} {
+ set encoding "ascii"
+ } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} {
+ switch -- $num {
+ 5 {set encoding "iso8859-9"}
+ 1 - 2 - 3 {
+ set encoding "iso8859-$num"
+ }
+ default {
+ set encoding "binary"
+ }
+ }
+ } else {
+ # other charset, like euc-xx, utf-8,... may directly map to encoding
+ set encoding $charset
+ }
+ set idx [lsearch -exact $encodings $encoding]
+ if {$idx >= 0} {
+ return $encoding
+ } else {
+ return "binary"
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::ContentEncoding
+# ------------------------------------------------------------------------------
+# Return the list of content-encoding transformations we need to do in order.
+#
+ # --------------------------------------------------------------------------
+ # Options for Accept-Encoding, Content-Encoding: the switch command
+ # --------------------------------------------------------------------------
+ # The symbol deflateX allows http to attempt both versions of "deflate",
+ # unless there is a -channel - for a -channel, only "decompress" is tried.
+ # Alternative/extra lines for switch:
+ # The standards-compliant version of "deflate" can be chosen with:
+ # deflate { lappend r decompress }
+ # The Microsoft non-compliant version of "deflate" can be chosen with:
+ # deflate { lappend r inflate }
+ # The previously used implementation of "compress", which appears to be
+ # incorrect and is rarely used by web servers, can be chosen with:
+ # compress - x-compress { lappend r decompress }
+ # --------------------------------------------------------------------------
+#
+# Arguments:
+# token - Connection token.
+#
+# Return Value: list
+# ------------------------------------------------------------------------------
+
+proc http::ContentEncoding {token} {
+ upvar 0 $token state
+ set r {}
+ if {[info exists state(coding)]} {
+ foreach coding [split $state(coding) ,] {
+ switch -exact -- $coding {
+ deflate { lappend r deflateX }
+ gzip - x-gzip { lappend r gunzip }
+ identity {}
+ br {
+ return -code error\
+ "content-encoding \"br\" not implemented"
+ }
+ default {
+ Log "unknown content-encoding \"$coding\" ignored"
+ }
+ }
+ }
+ }
+ return $r
+}
+
+proc http::ReceiveChunked {chan command} {
+ set data ""
+ set size -1
+ yield
+ while {1} {
+ chan configure $chan -translation {crlf binary}
+ while {[gets $chan line] < 1} { yield }
+ chan configure $chan -translation {binary binary}
+ if {[scan $line %x size] != 1} {
+ return -code error "invalid size: \"$line\""
+ }
+ set chunk ""
+ while {$size && ![chan eof $chan]} {
+ set part [chan read $chan $size]
+ incr size -[string length $part]
+ append chunk $part
+ }
+ if {[catch {
+ uplevel #0 [linsert $command end $chunk]
+ }]} {
+ http::Log "Error in callback: $::errorInfo"
+ }
+ if {[string length $chunk] == 0} {
+ # channel might have been closed in the callback
+ catch {chan event $chan readable {}}
+ return
+ }
+ }
+}
+
+# http::SplitCommaSeparatedFieldValue --
+# Return the individual values of a comma-separated field value.
+#
+# Arguments:
+# fieldValue Comma-separated header field value.
+#
+# Results:
+# List of values.
+proc http::SplitCommaSeparatedFieldValue {fieldValue} {
+ set r {}
+ foreach el [split $fieldValue ,] {
+ lappend r [string trim $el]
+ }
+ return $r
+}
+
+
+# http::GetFieldValue --
+# Return the value of a header field.
+#
+# Arguments:
+# headers Headers key-value list
+# fieldName Name of header field whose value to return.
+#
+# Results:
+# The value of the fieldName header field
+#
+# Field names are matched case-insensitively (RFC 7230 Section 3.2).
+#
+# If the field is present multiple times, it is assumed that the field is
+# defined as a comma-separated list and the values are combined (by separating
+# them with commas, see RFC 7230 Section 3.2.2) and returned at once.
+proc http::GetFieldValue {headers fieldName} {
+ set r {}
+ foreach {field value} $headers {
+ if {[string equal -nocase $fieldName $field]} {
+ if {$r eq {}} {
+ set r $value
+ } else {
+ append r ", $value"
+ }
+ }
+ }
+ return $r
+}
+
+proc http::MakeTransformationChunked {chan command} {
+ coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
+ chan event $chan readable [namespace current]::dechunk$chan
+ return
+}
+
+interp alias {} http::data {} http::responseBody
+interp alias {} http::code {} http::responseLine
+interp alias {} http::mapReply {} http::quoteString
+interp alias {} http::meta {} http::responseHeaders
+interp alias {} http::metaValue {} http::responseHeaderValue
+interp alias {} http::ncode {} http::responseCode
+
+
+# ------------------------------------------------------------------------------
+# Proc http::socketForTls
+# ------------------------------------------------------------------------------
+# Command to use in place of ::socket as the value of ::tls::socketCmd.
+# This command does the same as http::socket, and also handles https connections
+# through a proxy server.
+#
+# Notes.
+# - The proxy server works differently for https and http. This implementation
+# is for https. The proxy for http is implemented in http::CreateToken (in
+# code that was previously part of http::geturl).
+# - This code implicitly uses the tls options set for https in a call to
+# http::register, and does not need to call commands tls::*. This simple
+# implementation is possible because tls uses a callback to ::socket that can
+# be redirected by changing the value of ::tls::socketCmd.
+#
+# Arguments:
+# args - as for ::socket
+#
+# Return Value: a socket identifier
+# ------------------------------------------------------------------------------
+
+proc http::socketForTls {args} {
+ variable http
+ set host [lindex $args end-1]
+ set port [lindex $args end]
+ if { ($http(-proxyfilter) ne {})
+ && (![catch {$http(-proxyfilter) $host} proxy])
+ } {
+ set phost [lindex $proxy 0]
+ set pport [lindex $proxy 1]
+ } else {
+ set phost {}
+ set pport {}
+ }
+ if {$phost eq ""} {
+ set sock [::http::socket {*}$args]
+ } else {
+ set sock [::http::SecureProxyConnect {*}$args $phost $pport]
+ }
+ return $sock
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SecureProxyConnect
+# ------------------------------------------------------------------------------
+# Command to open a socket through a proxy server to a remote server for use by
+# tls. The caller must perform the tls handshake.
+#
+# Notes
+# - Based on patch supplied by Melissa Chawla in ticket 1173760, and
+# Proxy-Authorization header cf. autoproxy by Pat Thoyts.
+# - Rewritten as a call to http::geturl, because response headers and body are
+# needed if the CONNECT request fails. CONNECT is implemented for this case
+# only, by state(bypass).
+# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT.
+# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014),
+# RFC 9112 (June 2022).
+#
+# Arguments:
+# args - as for ::socket, ending in host, port; with proxy host, proxy
+# port appended.
+#
+# Return Value: a socket identifier
+# ------------------------------------------------------------------------------
+
+proc http::SecureProxyConnect {args} {
+ variable http
+ variable ConnectVar
+ variable ConnectCounter
+ variable failedProxyValues
+ set varName ::http::ConnectVar([incr ConnectCounter])
+
+ # Extract (non-proxy) target from args.
+ set host [lindex $args end-3]
+ set port [lindex $args end-2]
+ set args [lreplace $args end-3 end-2]
+
+ # Proxy server URL for connection.
+ # This determines where the socket is opened.
+ set phost [lindex $args end-1]
+ set pport [lindex $args end]
+ if {[string first : $phost] != -1} {
+ # IPv6 address, wrap it in [] so we can append :pport
+ set phost "\[${phost}\]"
+ }
+ set url http://${phost}:${pport}
+ # Elements of args other than host and port are not used when
+ # AsyncTransaction opens a socket. Those elements are -async and the
+ # -type $tokenName for the https transaction. Option -async is used by
+ # AsyncTransaction anyway, and -type $tokenName should not be propagated:
+ # the proxy request adds its own -type value.
+
+ set targ [lsearch -exact $args -type]
+ if {$targ != -1} {
+ # Record in the token that this is a proxy call.
+ set token [lindex $args $targ+1]
+ upvar 0 ${token} state
+ set tim $state(-timeout)
+ set state(proxyUsed) SecureProxyFailed
+ # This value is overwritten with "SecureProxy" below if the CONNECT is
+ # successful. If it is unsuccessful, the socket will be closed
+ # below, and so in this unsuccessful case there are no other transactions
+ # whose (proxyUsed) must be updated.
+ } else {
+ set tim 0
+ }
+ if {$tim == 0} {
+ # Do not use infinite timeout for the proxy.
+ set tim 30000
+ }
+
+ # Prepare and send a CONNECT request to the proxy, using
+ # code similar to http::geturl.
+ set requestHeaders [list Host $host]
+ lappend requestHeaders Connection keep-alive
+ if {$http(-proxyauth) != {}} {
+ lappend requestHeaders Proxy-Authorization $http(-proxyauth)
+ }
+
+ set token2 [CreateToken $url -keepalive 0 -timeout $tim \
+ -headers $requestHeaders -command [list http::AllDone $varName]]
+ variable $token2
+ upvar 0 $token2 state2
+
+ # Kludges:
+ # Setting this variable overrides the HTTP request line and also allows
+ # -headers to override the Connection: header set by -keepalive.
+ # The arguments "-keepalive 0" ensure that when Finish is called for an
+ # unsuccessful request, the socket is always closed.
+ set state2(bypass) "CONNECT $host:$port HTTP/1.1"
+
+ AsyncTransaction $token2
+
+ if {[info coroutine] ne {}} {
+ # All callers in the http package are coroutines launched by
+ # the event loop.
+ # The cwait command requires a coroutine because it yields
+ # to the caller; $varName is traced and the coroutine resumes
+ # when the variable is written.
+ cwait $varName
+ } else {
+ return -code error {code must run in a coroutine}
+ # For testing with a non-coroutine caller outside the http package.
+ # vwait $varName
+ }
+ unset $varName
+
+ if { ($state2(state) ne "complete")
+ || ($state2(status) ne "ok")
+ || (![string is integer -strict $state2(responseCode)])
+ } {
+ set msg {the HTTP request to the proxy server did not return a valid\
+ and complete response}
+ if {[info exists state2(error)]} {
+ append msg ": " [lindex $state2(error) 0]
+ }
+ cleanup $token2
+ return -code error $msg
+ }
+
+ set code $state2(responseCode)
+
+ if {($code >= 200) && ($code < 300)} {
+ # All OK. The caller in package tls will now call "tls::import $sock".
+ # The cleanup command does not close $sock.
+ # Other tidying was done in http::Event.
+
+ # If this is a persistent socket, any other transactions that are
+ # already marked to use the socket will have their (proxyUsed) updated
+ # when http::OpenSocket calls http::ConfigureNewSocket.
+ set state(proxyUsed) SecureProxy
+ set sock $state2(sock)
+ cleanup $token2
+ return $sock
+ }
+
+ if {$targ != -1} {
+ # Non-OK HTTP status code; token is known because option -type
+ # (cf. targ) was passed through tcltls, and so the useful
+ # parts of the proxy's response can be copied to state(*).
+ # Do not copy state2(sock).
+ # Return the proxy response to the caller of geturl.
+ foreach name $failedProxyValues {
+ if {[info exists state2($name)]} {
+ set state($name) $state2($name)
+ }
+ }
+ set state(connection) close
+ set msg "proxy connect failed: $code"
+ # - This error message will be detected by http::OpenSocket and will
+ # cause it to present the proxy's HTTP response as that of the
+ # original $token transaction, identified only by state(proxyUsed)
+ # as the response of the proxy.
+ # - The cases where this would mislead the caller of http::geturl are
+ # given a different value of msg (below) so that http::OpenSocket will
+ # treat them as errors, but will preserve the $token array for
+ # inspection by the caller.
+ # - Status code 305 (Proxy Required) was deprecated for security reasons
+ # in RFC 2616 (June 1999) and in any case should never be served by a
+ # proxy.
+ # - Other 3xx responses from the proxy are inappropriate, and should not
+ # occur.
+ # - A 401 response from the proxy is inappropriate, and should not
+ # occur. It would be confusing if returned to the caller.
+
+ if {($code >= 300) && ($code < 400)} {
+ set msg "the proxy server responded to the HTTP request with an\
+ inappropriate $code redirect"
+ set loc [responseHeaderValue $token2 location]
+ if {$loc ne {}} {
+ append msg "to " $loc
+ }
+ } elseif {($code == 401)} {
+ set msg "the proxy server responded to the HTTP request with an\
+ inappropriate 401 request for target-host credentials"
+ } else {
+ }
+ } else {
+ set msg "connection to proxy failed with status code $code"
+ }
+
+ # - ${token2}(sock) has already been closed because -keepalive 0.
+ # - Error return does not pass the socket ID to the
+ # $token transaction, which retains its socket placeholder.
+ cleanup $token2
+ return -code error $msg
+}
+
+proc http::AllDone {varName args} {
+ set $varName done
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::socket
+# ------------------------------------------------------------------------------
+# This command is a drop-in replacement for ::socket.
+# Arguments and return value as for ::socket.
+#
+# Notes.
+# - http::socket is specified in place of ::socket by the definition of urlTypes
+# in the namespace header of this file (http.tcl).
+# - The command makes a simple call to ::socket unless the user has called
+# http::config to change the value of -threadlevel from the default value 0.
+# - For -threadlevel 1 or 2, if the Thread package is available, the command
+# waits in the event loop while the socket is opened in another thread. This
+# is a workaround for bug [824251] - it prevents http::geturl from blocking
+# the event loop if the DNS lookup or server connection is slow.
+# - FIXME Use a thread pool if connections are very frequent.
+# - FIXME The peer thread can transfer the socket only to the main interpreter
+# in the present thread. Therefore this code works only if this script runs
+# in the main interpreter. In a child interpreter, the parent must alias a
+# command to ::http::socket in the child, run http::socket in the parent,
+# and then transfer the socket to the child.
+# - The http::socket command is simple, and can easily be replaced with an
+# alternative command that uses a different technique to open a socket while
+# entering the event loop.
+# - Unexpected behaviour by thread::send -async (Thread 2.8.6).
+# An error in thread::send -async causes return of just the error message
+# (not the expected 3 elements), and raises a bgerror in the main thread.
+# Hence wrap the command with catch as a precaution.
+# ------------------------------------------------------------------------------
+
+proc http::socket {args} {
+ variable ThreadVar
+ variable ThreadCounter
+ variable http
+
+ LoadThreadIfNeeded
+
+ set targ [lsearch -exact $args -type]
+ if {$targ != -1} {
+ set token [lindex $args $targ+1]
+ set args [lreplace $args $targ $targ+1]
+ upvar 0 $token state
+ }
+
+ if {!$http(usingThread)} {
+ # Use plain "::socket". This is the default.
+ return [eval ::socket $args]
+ }
+
+ set defcmd ::socket
+ set sockargs $args
+ set script "
+ set code \[catch {
+ [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
+ [list ::SockInThread [thread::id] $defcmd $sockargs]
+ } result opts\]
+ list \$code \$opts \$result
+ "
+
+ set state(tid) [thread::create]
+ set varName ::http::ThreadVar([incr ThreadCounter])
+ thread::send -async $state(tid) $script $varName
+ Log >T Thread Start Wait $args -- coro [info coroutine] $varName
+ if {[info coroutine] ne {}} {
+ # All callers in the http package are coroutines launched by
+ # the event loop.
+ # The cwait command requires a coroutine because it yields
+ # to the caller; $varName is traced and the coroutine resumes
+ # when the variable is written.
+ cwait $varName
+ } else {
+ return -code error {code must run in a coroutine}
+ # For testing with a non-coroutine caller outside the http package.
+ # vwait $varName
+ }
+ Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
+ thread::release $state(tid)
+ set state(tid) {}
+ set result [set $varName]
+ unset $varName
+ if {(![string is list $result]) || ([llength $result] != 3)} {
+ return -code error "result from peer thread is not a list of\
+ length 3: it is \n$result"
+ }
+ lassign $result threadCode threadDict threadResult
+ if {($threadCode != 0)} {
+ # This is an error in thread::send. Return the lot.
+ return -options $threadDict -code error $threadResult
+ }
+
+ # Now the results of the catch in the peer thread.
+ lassign $threadResult catchCode errdict sock
+
+ if {($catchCode == 0) && ($sock ni [chan names])} {
+ return -code error {Transfer of socket from peer thread failed.\
+ Check that this script is not running in a child interpreter.}
+ }
+ return -options $errdict -code $catchCode $sock
+}
+
+# The commands below are dependencies of http::socket and
+# http::SecureProxyConnect and are not used elsewhere.
+
+# ------------------------------------------------------------------------------
+# Proc http::LoadThreadIfNeeded
+# ------------------------------------------------------------------------------
+# Command to load the Thread package if it is needed. If it is needed and not
+# loadable, the outcome depends on $http(-threadlevel):
+# value 0 => Thread package not required, no problem
+# value 1 => operate as if -threadlevel 0
+# value 2 => error return
+#
+# Arguments: none
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::LoadThreadIfNeeded {} {
+ variable http
+ if {$http(usingThread) || ($http(-threadlevel) == 0)} {
+ return
+ }
+ if {[catch {package require Thread}]} {
+ if {$http(-threadlevel) == 2} {
+ set msg {[http::config -threadlevel] has value 2,\
+ but the Thread package is not available}
+ return -code error $msg
+ }
+ return
+ }
+ set http(usingThread) 1
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SockInThread
+# ------------------------------------------------------------------------------
+# Command http::socket is a ::socket replacement. It defines and runs this
+# command, http::SockInThread, in a peer thread.
+#
+# Arguments:
+# caller
+# defcmd
+# sockargs
+#
+# Return value: list of values that describe the outcome. The return is
+# intended to be a normal (non-error) return in all cases.
+# ------------------------------------------------------------------------------
+
+proc http::SockInThread {caller defcmd sockargs} {
+ package require Thread
+
+ set catchCode [catch {eval $defcmd $sockargs} sock errdict]
+ if {$catchCode == 0} {
+ set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
+ }
+ return [list $catchCode $errdict $sock]
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::cwaiter::cwait
+# ------------------------------------------------------------------------------
+# Command to substitute for vwait, without the ordering issues.
+# A command that uses cwait must be a coroutine that is launched by an event,
+# e.g. fileevent or after idle, and has no calling code to be resumed upon
+# "yield". It cannot return a value.
+#
+# Arguments:
+# varName - fully-qualified name of the variable that the calling script
+# will write to resume the coroutine. Any scalar variable or
+# array element is permitted.
+# coroName - (optional) name of the coroutine to be called when varName is
+# written - defaults to this coroutine
+# timeout - (optional) timeout value in ms
+# timeoutValue - (optional) value to assign to varName if there is a timeout
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+namespace eval http::cwaiter {
+ namespace export cwait
+ variable log {}
+ variable logOn 0
+}
+
+proc http::cwaiter::cwait {
+ varName {coroName {}} {timeout {}} {timeoutValue {}}
+} {
+ set thisCoro [info coroutine]
+ if {$thisCoro eq {}} {
+ return -code error {cwait cannot be called outside a coroutine}
+ }
+ if {$coroName eq {}} {
+ set coroName $thisCoro
+ }
+ if {[string range $varName 0 1] ne {::}} {
+ return -code error {argument varName must be fully qualified}
+ }
+ if {$timeout eq {}} {
+ set toe {}
+ } elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
+ set toe [after $timeout [list set $varName $timeoutValue]]
+ } else {
+ return -code error {if timeout is supplied it must be a positive integer}
+ }
+
+ set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
+ trace add variable $varName write $cmd
+ CoLog "Yield $varName $coroName"
+ yield
+ CoLog "Resume $varName $coroName"
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::cwaiter::CwaitHelper
+# ------------------------------------------------------------------------------
+# Helper command called by the trace set by cwait.
+# - Ignores the arguments added by trace.
+# - A simple call to $coroName works, and in error cases gives a suitable stack
+# trace, but because it is inside a trace the headline error message is
+# something like {can't set "::Result(6)": error}, not the actual
+# error. So let the trace command return.
+# - Remove the trace immediately. We don't want multiple calls.
+# ------------------------------------------------------------------------------
+
+proc http::cwaiter::CwaitHelper {varName coroName toe args} {
+ CoLog "got $varName for $coroName"
+ set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
+ trace remove variable $varName write $cmd
+ after cancel $toe
+
+ after 0 $coroName
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::cwaiter::LogInit
+# ------------------------------------------------------------------------------
+# Call this command to initiate debug logging and clear the log.
+# ------------------------------------------------------------------------------
+
+proc http::cwaiter::LogInit {} {
+ variable log
+ variable logOn
+ set log {}
+ set logOn 1
+ return
+}
+
+proc http::cwaiter::LogRead {} {
+ variable log
+ return $log
+}
+
+proc http::cwaiter::CoLog {msg} {
+ variable log
+ variable logOn
+ if {$logOn} {
+ append log $msg \n
+ }
+ return
+}
+
+namespace eval http {
+ namespace import ::http::cwaiter::*
+}
+
+# Local variables:
+# indent-tabs-mode: t
+# End:
diff --git a/src/bootsupport/modules_tcl8/include_modules.config b/src/bootsupport/modules_tcl8/include_modules.config
index 090a7cf6..1eb94de4 100644
--- a/src/bootsupport/modules_tcl8/include_modules.config
+++ b/src/bootsupport/modules_tcl8/include_modules.config
@@ -1,9 +1,8 @@
-
-#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project
-#They must be already built, so generally shouldn't come directly from src/modules.
-
-#each entry - base module
-set bootsupport_modules [list\
-]
-
+## e.g
+#set bootsupport_modules [list\
+# src/vendormodules cksum\
+# modules punkcheck\
+#]
+#set bootsupport_module_folders [list\
+#]
diff --git a/src/bootsupport/modules_tcl8/md5-2.0.8.tm b/src/bootsupport/modules_tcl8/md5-2.0.8.tm
new file mode 100644
index 00000000..51f35dce
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/md5-2.0.8.tm
@@ -0,0 +1,739 @@
+# md5.tcl - Copyright (C) 2003 Pat Thoyts
+#
+# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of MD5 based upon the example code given in
+# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas
+# from the earlier tcllib md5 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and
+# provides support for external compiled implementations either using
+# critcl (md5c) or Trf.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2-; # tcl minimum version
+
+namespace eval ::md5 {
+ variable accel
+ array set accel {critcl 0 cryptkit 0 trf 0}
+
+ namespace export md5 hmac MD5Init MD5Update MD5Final
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# MD5Init --
+#
+# Create and initialize an MD5 state variable. This will be
+# cleaned up when we call MD5Final
+#
+proc ::md5::MD5Init {} {
+ variable accel
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ # RFC1321:3.3 - Initialize MD5 state structure
+ array set state \
+ [list \
+ A [expr {0x67452301}] \
+ B [expr {0xefcdab89}] \
+ C [expr {0x98badcfe}] \
+ D [expr {0x10325476}] \
+ n 0 i "" ]
+ if {$accel(cryptkit)} {
+ cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5
+ } elseif {$accel(trf)} {
+ set s {}
+ switch -exact -- $::tcl_platform(platform) {
+ windows { set s [open NUL w] }
+ unix { set s [open /dev/null w] }
+ }
+ if {$s != {}} {
+ fconfigure $s -translation binary -buffering none
+ ::md5 -attach $s -mode write \
+ -read-type variable \
+ -read-destination [subst $token](trfread) \
+ -write-type variable \
+ -write-destination [subst $token](trfwrite)
+ array set state [list trfread 0 trfwrite 0 trf $s]
+ }
+ }
+ return $token
+}
+
+# MD5Update --
+#
+# This is called to add more data into the hash. You may call this
+# as many times as you require. Note that passing in "ABC" is equivalent
+# to passing these letters in as separate calls -- hence this proc
+# permits hashing of chunked data
+#
+# If we have a C-based implementation available, then we will use
+# it here in preference to the pure-Tcl implementation.
+#
+proc ::md5::MD5Update {token data} {
+ variable accel
+ upvar #0 $token state
+
+ if {$accel(critcl)} {
+ if {[info exists state(md5c)]} {
+ set state(md5c) [md5c $data $state(md5c)]
+ } else {
+ set state(md5c) [md5c $data]
+ }
+ return
+ } elseif {[info exists state(ckctx)]} {
+ if {[string length $data] > 0} {
+ cryptkit::cryptEncrypt $state(ckctx) $data
+ }
+ return
+ } elseif {[info exists state(trf)]} {
+ puts -nonewline $state(trf) $data
+ return
+ }
+
+ # Update the state values
+ incr state(n) [string length $data]
+ append state(i) $data
+
+ # Calculate the hash for any complete blocks
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD5Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Adjust the state for the blocks completed.
+ set state(i) [string range $state(i) $n end]
+ return
+}
+
+# MD5Final --
+#
+# This procedure is used to close the current hash and returns the
+# hash data. Once this procedure has been called the hash context
+# is freed and cannot be used again.
+#
+# Note that the output is 128 bits represented as binary data.
+#
+proc ::md5::MD5Final {token} {
+ upvar #0 $token state
+
+ # Check for either of the C-compiled versions.
+ if {[info exists state(md5c)]} {
+ set r $state(md5c)
+ unset state
+ return $r
+ } elseif {[info exists state(ckctx)]} {
+ cryptkit::cryptEncrypt $state(ckctx) ""
+ cryptkit::cryptGetAttributeString $state(ckctx) \
+ CRYPT_CTXINFO_HASHVALUE r 16
+ cryptkit::cryptDestroyContext $state(ckctx)
+ # If nothing was hashed, we get no r variable set!
+ if {[info exists r]} {
+ unset state
+ return $r
+ }
+ } elseif {[info exists state(trf)]} {
+ close $state(trf)
+ set r $state(trfwrite)
+ unset state
+ return $r
+ }
+
+ # RFC1321:3.1 - Padding
+ #
+ set len [string length $state(i)]
+ set pad [expr {56 - ($len % 64)}]
+ if {$len % 64 > 56} {
+ incr pad 64
+ }
+ if {$pad == 0} {
+ incr pad 64
+ }
+
+ #puts "P $pad|bits=[expr {8 * $state(n)}]"
+
+ append state(i) [binary format a$pad \x80]
+
+ # RFC1321:3.2 - Append length in bits as little-endian wide int.
+ append state(i) [binary format ii [expr {8 * $state(n)}] 0]
+
+ #puts DATA=[Hex $state(i)]([string length $state(i)])
+
+ # Calculate the hash for the remaining block.
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD5Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ #puts md5-post__________________________________________
+ #parray ::${token}
+
+ # RFC1321:3.5 - Output
+ set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)]
+ unset state
+
+ #puts HASH=[Hex $r]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+# This is equivalent to the MD5Init procedure except that a key is
+# added into the algorithm
+#
+proc ::md5::HMACInit {K} {
+
+ # Key K is adjusted to be 64 bytes long. If K is larger, then use
+ # the MD5 digest of K and pad this instead.
+ set len [string length $K]
+ if {$len > 64} {
+ set tok [MD5Init]
+ MD5Update $tok $K
+ set K [MD5Final $tok]
+ set len [string length $K]
+ }
+ set pad [expr {64 - $len}]
+ append K [string repeat \0 $pad]
+
+ # Cacluate the padding buffers.
+ set Ki {}
+ set Ko {}
+ binary scan $K i16 Ks
+ foreach k $Ks {
+ append Ki [binary format i [expr {$k ^ 0x36363636}]]
+ append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+ }
+
+ set tok [MD5Init]
+ MD5Update $tok $Ki; # initialize with the inner pad
+
+ # preserve the Ko value for the final stage.
+ # FRINK: nocheck
+ set [subst $tok](Ko) $Ko
+
+ return $tok
+}
+
+# HMACUpdate --
+#
+# Identical to calling MD5Update
+#
+proc ::md5::HMACUpdate {token data} {
+ MD5Update $token $data
+ return
+}
+
+# HMACFinal --
+#
+# This is equivalent to the MD5Final procedure. The hash context is
+# closed and the binary representation of the hash result is returned.
+#
+proc ::md5::HMACFinal {token} {
+ upvar #0 $token state
+
+ set tok [MD5Init]; # init the outer hashing function
+ MD5Update $tok $state(Ko); # prepare with the outer pad.
+ MD5Update $tok [MD5Final $token]; # hash the inner result
+ return [MD5Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but
+# includes an extra round and a set of constant modifiers throughout.
+#
+# Note:
+# This function body is substituted later on to inline some of the
+# procedures and to make is a bit more comprehensible.
+#
+set ::md5::MD5Hash_body {
+ variable $token
+ upvar 0 $token state
+
+ #puts TR__=[Hex $msg]([string length $msg])
+
+ # RFC1321:3.4 - Process Message in 16-Word Blocks
+ binary scan $msg i* blocks
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+ #puts BL
+
+ set A $state(A)
+ set B $state(B)
+ set C $state(C)
+ set D $state(D)
+
+ # Round 1
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4]
+ set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}]
+ # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8]
+ set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}]
+ # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12]
+ set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}]
+ # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16]
+ set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}]
+
+ # Round 2.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20]
+ set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}]
+ # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24]
+ set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}]
+ # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28]
+ set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}]
+ # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32]
+ set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}]
+
+ # Round 3.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36]
+ set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}]
+ # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40]
+ set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}]
+ # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44]
+ set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}]
+ # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48]
+ set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}]
+
+ # Round 4.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52]
+ set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}]
+ # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56]
+ set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}]
+ # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60]
+ set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}]
+ # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64]
+ set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}]
+
+ # Then perform the following additions. (That is, increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr state(A) $A
+ incr state(B) $B
+ incr state(C) $C
+ incr state(D) $D
+ }
+
+ return
+}
+
+proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::md5::bytes {v} {
+ #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+ format %c%c%c%c \
+ [expr {0xFF & $v}] \
+ [expr {(0xFF00 & $v) >> 8}] \
+ [expr {(0xFF0000 & $v) >> 16}] \
+ [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
+}
+
+# 32bit rotate-left
+proc ::md5::<<< {v n} {
+ return [expr {((($v << $n) \
+ | (($v >> (32 - $n)) \
+ & (0x7FFFFFFF >> (31 - $n))))) \
+ & 0xFFFFFFFF}]
+}
+
+# Convert our <<< pseudo-operator into a procedure call.
+regsub -all -line \
+ {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \
+ $::md5::MD5Hash_body \
+ {[expr {int(\1 + [<<< [expr {\2}] \3])}]} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function F
+proc ::md5::F {X Y Z} {
+ return [expr {($X & $Y) | ((~$X) & $Z)}]
+}
+
+# Inline the F function
+regsub -all -line \
+ {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {( (\1 \& \2) | ((~\1) \& \3) )} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function G
+proc ::md5::G {X Y Z} {
+ return [expr {(($X & $Z) | ($Y & (~$Z)))}]
+}
+
+# Inline the G function
+regsub -all -line \
+ {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {(((\1 \& \3) | (\2 \& (~\3))))} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function H
+proc ::md5::H {X Y Z} {
+ return [expr {$X ^ $Y ^ $Z}]
+}
+
+# Inline the H function
+regsub -all -line \
+ {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {(\1 ^ \2 ^ \3)} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function I
+proc ::md5::I {X Y Z} {
+ return [expr {$Y ^ ($X | (~$Z))}]
+}
+
+# Inline the I function
+regsub -all -line \
+ {\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {(\2 ^ (\1 | (~\3)))} \
+ ::md5::MD5Hash_body
+
+
+# RFC 1321:3.4 step 4: inline the set of constant modifiers.
+namespace eval md5 {
+ variable tName
+ variable tVal
+ variable map
+ foreach tName {
+ T01 T02 T03 T04 T05 T06 T07 T08 T09 T10
+ T11 T12 T13 T14 T15 T16 T17 T18 T19 T20
+ T21 T22 T23 T24 T25 T26 T27 T28 T29 T30
+ T31 T32 T33 T34 T35 T36 T37 T38 T39 T40
+ T41 T42 T43 T44 T45 T46 T47 T48 T49 T50
+ T51 T52 T53 T54 T55 T56 T57 T58 T59 T60
+ T61 T62 T63 T64
+ } tVal {
+ 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+ 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+ 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+ 0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+ 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+ 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8
+ 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+ 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+ 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+ 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+ 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+ 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+ 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+ 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+ 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+ 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+ } {
+ lappend map \$$tName $tVal
+ }
+ set ::md5::MD5Hash_body [string map $map $::md5::MD5Hash_body]
+ unset map tName tVal
+}
+
+# Define the MD5 hashing procedure with inline functions.
+proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_body
+unset ::md5::MD5Hash_body
+
+# -------------------------------------------------------------------------
+
+if {[package provide Trf] != {}} {
+ interp alias {} ::md5::Hex {} ::hex -mode encode --
+} else {
+ proc ::md5::Hex {data} {
+ binary scan $data H* result
+ return [string toupper $result]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::md5::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require md5c}]} {
+ set r [expr {[info commands ::md5::md5c] != {}}]
+ }
+ }
+ cryptkit {
+ if {![catch {package require cryptkit}]} {
+ set r [expr {![catch {cryptkit::cryptInit}]}]
+ }
+ }
+ trf {
+ if {![catch {package require Trf}]} {
+ set r [expr {![catch {::md5 aa} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::md5::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::md5::Chunk {token channel {chunksize 4096}} {
+ upvar #0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ MD5Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::md5 {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err\nlen: [llength $args]"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"md5 ?-hex? -filename file | string\""
+ }
+ set tok [MD5Init]
+
+ #puts md5_______________________________________________
+ #parray ::${tok}
+
+ #puts IN=(([lindex $args 0]))
+ MD5Update $tok [lindex $args 0]
+
+ #puts md5-final_________________________________________
+ #parray ::${tok}
+
+ set r [MD5Final $tok]
+
+ } else {
+
+ set tok [MD5Init]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [MD5Final $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::hmac {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -key { set opts(-key) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {![info exists opts(-key)]} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+ set tok [HMACInit $opts(-key)]
+ HMACUpdate $tok [lindex $args 0]
+ set r [HMACFinal $tok]
+
+ } else {
+
+ set tok [HMACInit $opts(-key)]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [HMACFinal $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::md5 {
+ variable e
+ foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } }
+ unset e
+}
+
+package provide md5 2.0.8
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
+
diff --git a/src/bootsupport/modules_tcl8/metaface-1.2.5.tm b/src/bootsupport/modules_tcl8/metaface-1.2.5.tm
new file mode 100644
index 00000000..ebcf579e
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/metaface-1.2.5.tm
@@ -0,0 +1,6411 @@
+package require dictutils
+package provide metaface [namespace eval metaface {
+ variable version
+ set version 1.2.5
+}]
+
+
+
+
+#example datastructure:
+#$_ID_
+#{
+#i
+# {
+# this
+# {
+# {16 ::p::16 item ::>x {}}
+# }
+# role2
+# {
+# {17 ::p::17 item ::>y {}}
+# {18 ::p::18 item ::>z {}}
+# }
+# }
+#context {}
+#}
+
+#$MAP
+#invocantdata {16 ::p::16 item ::>x {}}
+#interfaces {level0
+# {
+# api0 {stack {123 999}}
+# api1 {stack {333}}
+# }
+# level0_default api0
+# level1
+# {
+# }
+# level1_default {}
+# }
+#patterndata {patterndefaultmethod {}}
+
+
+namespace eval ::p::predator {}
+#temporary alternative to ::p::internals namespace.
+# - place predator functions here until ready to replace internals.
+
+
+namespace eval ::p::snap {
+ variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks.
+}
+
+
+
+
+# not called directly. Retrieved using 'info body ::p::predator::getprop_template'
+#review - why use a proc instead of storing it as a string?
+proc ::p::predator::getprop_template {_ID_ args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {"%varspace%" eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" "%varspace%"]} {
+ set ns "%varspace%"
+ } else {
+ set ns ::p::${OID}::%varspace%
+ }
+ }
+
+
+ if {[llength $args]} {
+ #lassign [lindex $invocant 0] OID alias itemCmd cmd
+ if {[array exists ${ns}::o_%prop%]} {
+ #return [set ${ns}::o_%prop%($args)]
+ if {[llength $args] == 1} {
+ return [set ::p::${OID}::o_%prop%([lindex $args 0])]
+ } else {
+ return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]]
+ }
+ } else {
+ set val [set ${ns}::o_%prop%]
+
+ set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}]
+ if {$rType eq "object"} {
+ #return [$val . item {*}$args]
+ return [$val {*}$args]
+ } else {
+ #treat as list?
+ return [lindex $val $args]
+ }
+ }
+ } else {
+ return [set ${ns}::o_%prop%]
+ }
+}
+
+
+proc ::p::predator::getprop_template_immediate {_ID_ args} {
+ if {[llength $args]} {
+ if {[array exists %ns%::o_%prop%]} {
+ return [set %ns%::o_%prop%($args)]
+ } else {
+ set val [set %ns%::o_%prop%]
+ set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}]
+ if {$rType eq "object"} {
+ #return [$val . item {*}$args]
+ #don't assume defaultmethod named 'item'!
+ return [$val {*}$args]
+ } else {
+ #treat as list?
+ return [lindex $val $args]
+ }
+ }
+ } else {
+ return [set %ns%::o_%prop%]
+ }
+}
+
+
+
+
+
+
+
+
+proc ::p::predator::getprop_array {_ID_ prop args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+
+ #upvar 0 ::p::${OID}::o_${prop} prop
+ #1st try: assume array
+ if {[catch {array get ::p::${OID}::o_${prop}} result]} {
+ #treat as list (why?)
+ #!review
+ if {[info exists ::p::${OID}::o_${prop}]} {
+ array set temp [::list]
+ set i 0
+ foreach element ::p::${OID}::o_${prop} {
+ set temp($i) $element
+ incr i
+ }
+ set result [array get temp]
+ } else {
+ error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format"
+ }
+ }
+ return $result
+}
+
+proc ::p::predator::setprop_template {prop _ID_ args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {"%varspace%" eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" "%varspace%"]} {
+ set ns "%varspace%"
+ } else {
+ set ns ::p::${OID}::%varspace%
+ }
+ }
+
+
+ if {[llength $args] == 1} {
+ #return [set ::p::${OID}::o_%prop% [lindex $args 0]]
+ return [set ${ns}::o_%prop% [lindex $args 0]]
+
+ } else {
+ if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} {
+ #treat attempt to perform indexed write to nonexistant var, same as indexed write to array
+
+ #2 args - single index followed by a value
+ if {[llength $args] == 2} {
+ return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]]
+ } else {
+ #multiple indices
+ #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]]
+ return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ]
+ }
+ } else {
+ #treat as list
+ return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]]
+ }
+ }
+}
+
+#--------------------------------------
+#property read & write traces
+#--------------------------------------
+
+
+proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} {
+
+ #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' "
+
+ #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain.
+
+ if {[llength $idx]} {
+ if {[llength $idx] == 1} {
+ set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx]
+ } else {
+ lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx]
+ }
+ return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value
+ } else {
+ if {![info exists $refname]} {
+ set $refname [$get_cmd $_ID_ {*}$indices]
+ } else {
+ set newval [$get_cmd $_ID_ {*}$indices]
+ if {[set $refname] ne $newval} {
+ set $refname $newval
+ }
+ }
+ return
+ }
+}
+
+
+
+
+proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} {
+ #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname
+ #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'"
+
+
+ #derive the name of the write command from the ref var.
+ set indices [lassign [split [namespace tail $refname] +] prop]
+
+
+ #assert - we will never have both a list in indices and an idx value
+ if {[llength $indices] && ($idx ne "")} {
+ #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x
+ #review - are there any datastructures which would/should allow this?
+ #this assertion is really just here as a sanity check for now
+ error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value"
+ }
+
+ #upvar #0 ::p::${OID}::_meta::map MAP
+ #puts "-->propref_trace_write map: $MAP"
+
+ #temporarily deactivate refsync trace
+ #puts stderr -->1>--removing_trace_o_${field}
+### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop]
+
+ #we need to catch, and re-raise any error that we may receive when writing the property
+ # because we have to reinstate the propvar_write_TraceHandler after the call.
+ #(e.g there may be a propertywrite handler that deliberately raises an error)
+
+ set excludesync_refs $refname
+ set cmd ::p::${OID}::(SET)$prop
+
+
+ set f_error 0
+ if {[catch {
+
+ if {![llength $indices]} {
+ if {[string length $idx]} {
+ $cmd $_ID_ $idx [set ${refname}($idx)]
+ #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx]
+
+ } else {
+ $cmd $_ID_ [set $refname]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list]
+ }
+ } else {
+ #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n"
+ $cmd $_ID_ {*}$indices [set $refname]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices
+ }
+
+ } result]} {
+ set f_error 1
+ }
+
+
+
+
+ #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write
+ #reactivate refsync trace
+ #puts stderr "****** reactivating refsync trace on o_$field"
+ #puts stderr -->2>--reactivating_trace_o_${field}
+ ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop]
+
+
+ if {$f_error} {
+ #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging.
+ # ? return -code error $errMsg ? -errorinfo
+
+ #!quick n dirty
+ #error $errorMsg
+ return -code error -errorinfo $::errorInfo $result
+ } else {
+ return $result
+ }
+}
+
+
+
+
+
+proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} {
+ #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'"
+ #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array')
+
+ set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set
+
+ #set updated_value [::p::predator::getprop_array $prop $_ID_]
+ #puts stderr "-->array_Trace updated_value:$updated_value"
+ if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} {
+ puts stderr "-->propref_trace_array error $errm"
+ array set $refname {}
+ }
+
+ #return value ignored for
+}
+
+
+#--------------------------------------
+#
+proc ::p::predator::object_array_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+
+
+ #don't rely on variable name passed by trace - may have been 'upvar'ed
+ set refvar ::p::${OID}::_ref::__OBJECT
+
+ #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar"
+
+ set iflist [dict get $MAP interfaces level0]
+
+ set plist [list]
+
+ #!todo - get propertylist from cache on object(?)
+ foreach IFID [lreverse $iflist] {
+ dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] {
+ #lassign $pdef v
+ if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} {
+ if {[array exists ::p::${OID}::o_${prop}]} {
+ lappend plist $prop [array get ::p::${OID}::o_${prop}]
+ } else {
+ #ignore - array only represents properties that have been set.
+ #error "property $v is not set"
+ #!todo - unset corresponding items in $refvar if needed?
+ }
+ }
+ }
+ }
+ array set $refvar $plist
+}
+
+
+proc ::p::predator::object_read_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+ #don't rely on variable name passed by trace.
+ set refvar ::p::${OID}::_ref::__OBJECT
+
+ #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n"
+
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+
+ if {[string length $IID]} {
+ #property
+ if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} {
+ puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg"
+ }
+ } else {
+ #method
+ error "property '$idx' not found"
+ }
+}
+
+
+proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+
+ #!todo - ???
+
+ if {![llength [info commands ::p::${OID}::$idx]]} {
+ error "no such method or property: '$idx'"
+ } else {
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set found 0
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set found 1
+ break
+ }
+ }
+
+ if {$found} {
+ unset ::p::${OID}::o_$idx
+ } else {
+ puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx"
+ }
+ }
+}
+
+
+proc ::p::predator::object_write_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+ #don't rely on variable name passed by trace.
+ set refvar ::p::${OID}::_ref::__OBJECT
+ #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar"
+
+
+ if {![llength [info commands ::p::${OID}::$idx]]} {
+ #!todo - create new property in interface upon attempt to write to non-existant?
+ # - or should we require some different kind of object-reference for that?
+ array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx
+ error "no such method or property: '$idx'"
+ } else {
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+
+ #$IID is now topmost interface in default iStack which has this property
+
+ if {[string length $IID]} {
+ #write to defined property
+
+ ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)]
+ } else {
+ #!todo - allow write of method body back to underlying object?
+ #attempted write to 'method' ..undo(?)
+ array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx
+ error "cannot write to method '$idx'"
+ #for now - disallow
+ }
+ }
+
+}
+
+
+
+proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} {
+ #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname
+
+ set refindices [lassign [split [namespace tail $refname] +] prop]
+ #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop
+ #if there is no PropertyUnset command - we unset the underlying variable directly
+
+ trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop]
+
+
+ if {[catch {
+
+ #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value
+ #i.e
+ if {[llength $refindices] && [string length $idx]} {
+ puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'"
+ error "unexpected call to propref_trace_unset"
+ }
+
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set iflist [dict get $MAP interfaces level0]
+ #find topmost interface containing this $prop
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+ if {![string length $IID]} {
+ error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])"
+ }
+
+
+
+
+
+
+ if {[string length $idx]} {
+ #eval "$_alias ${unset_}$field $idx"
+ #what happens to $refindices???
+
+
+ #!todo varspace
+
+ if {![llength $refindices]} {
+ #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ unset ::p::${OID}::o_${prop}($idx)
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx
+ }
+
+
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx
+ } else {
+ #assert - won't get here
+ error 1a
+
+ }
+
+ } else {
+ if {[llength $refindices]} {
+ #error 2a
+ #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ #review - what about list-type property?
+ #if {[array exists ::p::${OID}::o_${prop}]} ???
+ unset ::p::${OID}::o_${prop}($refindices)
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices
+ }
+
+
+
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices
+
+
+ } else {
+ #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ #ref is not of form prop+x etc and no idx in the trace - this is a plain unset
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ unset ::p::${OID}::o_${prop}
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ ""
+ }
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {}
+
+ }
+ }
+
+
+
+
+ } errM]} {
+ #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]"
+ set ruler [string repeat - 80]
+ puts stderr "\t$ruler"
+ puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+ puts stderr "\t$ruler"
+ puts stderr $errM
+ puts stderr "\t$ruler"
+
+ } else {
+ #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+ #puts stderr "*@*@*@*@ end propref_trace_unset - no error"
+ }
+
+ trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop]
+
+
+}
+
+
+
+
+proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} {
+
+ #Do not use 'info exists' (avoid triggering read trace) - use info vars
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ #puts " **> lappending '::p::REF::${OID}::$prop'"
+ lappend refvars ::p::${OID}::_ref::$prop
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*]
+
+
+
+ if {[string length $triggeringRef]} {
+ set idx [lsearch -exact $refvars $triggeringRef]
+ if {$idx >= 0} {
+ set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}]
+ }
+ }
+ if {![llength $refvars]} {
+ #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx"
+ return
+ }
+
+
+ #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset
+ # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b"
+ if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} {
+ #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???"
+ puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'"
+ }
+
+
+ puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' "
+
+
+
+ upvar $vtraced SYNCVARIABLE
+
+
+ #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars
+ array set traces [::list]
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ if {$ops in {read write unset array}} {
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ }
+ }
+ }
+ }
+
+
+
+
+ if {[array exists SYNCVARIABLE]} {
+
+ #underlying variable is an array - we are presumably unsetting just an element
+ set vtracedIsArray 1
+ } else {
+ #!? maybe the var was an array - but it's been unset?
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+ #some things we don't want to repeat for each refvar in case there are lots of them..
+
+ #set triggeringRefIdx $vidx
+
+ if {[string match "${prop}+*" [namespace tail $triggeringRef]]} {
+ set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end]
+ } else {
+ set triggering_indices [list]
+ }
+
+
+
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "--- unset branch refvar:$refvar"
+
+
+
+ if {[llength $vidx]} {
+ #trace called with an index - must be an array
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #!todo - add test
+ if {$vidx eq [lrange [split $reftail +] 1 end]} {
+ #unset if indices match
+ error "untested, possibly unused branch spuds1"
+ #puts "1111111111111111111111111"
+ unset $refvar
+ }
+ } else {
+ #test exists - #!todo - document which one
+
+ #see if we succeeded in unsetting this element in the underlying variables
+ #(may have been blocked by a PropertyUnset body)
+ set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]]
+ #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists"
+ if {$element_exists} {
+ #do nothing it wasn't actually unset
+ } else {
+ #puts "JJJJJ unsetting ${refvar}($vidx)"
+ unset ${refvar}($vidx)
+ }
+ }
+ }
+
+
+
+
+
+ } else {
+
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #check indices of triggering refvar match this refvars indices
+
+
+ if {$reftail eq [namespace tail $triggeringRef]} {
+ #!todo - add test
+ error "untested, possibly unused branch spuds2"
+ #puts "222222222222222222"
+ unset $refvar
+ } else {
+
+ #error "untested - branch spuds2a"
+
+
+ }
+
+ } else {
+ #!todo -add test
+ #reference is directly to property var
+ error "untested, possibly unused branch spuds3"
+ #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string?
+ puts "\t33333333333333333333"
+
+ if {[string length $triggeringRefIdx]} {
+ unset $refvar($triggeringRefIdx)
+ }
+ }
+ }
+
+ }
+
+
+
+
+ #!todo - understand.
+ #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n"
+ #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?)
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing setGet trace '$ops' on variable $rv"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+
+
+
+
+}
+
+
+proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} {
+
+ upvar $vtraced SYNCVARIABLE
+
+ set refvars [::list]
+ #Do not use 'info exists' (avoid triggering read trace) - use info vars
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ lappend refvars ::p::${OID}::_ref::$prop
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*]
+
+
+
+ #short_circuit breaks unset traces for array elements (why?)
+
+
+ if {![llength $refvars]} {
+ #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'"
+ return
+ } else {
+ puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'"
+ }
+
+ if {[catch {
+
+
+
+ #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars
+ array set traces [::list]
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ if {$ops in {read write unset array}} {
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ }
+ }
+ }
+ }
+
+
+
+
+ if {[array exists SYNCVARIABLE]} {
+
+ #underlying variable is an array - we are presumably unsetting just an element
+ set vtracedIsArray 1
+ } else {
+ #!? maybe the var was an array - but it's been unset?
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+ #some things we don't want to repeat for each refvar in case there are lots of them..
+ set triggeringRefIdx $vidx
+
+
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "--- unset branch refvar:$refvar"
+
+
+
+ if {[llength $vidx]} {
+ #trace called with an index - must be an array
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #!todo - add test
+ if {$vidx eq [lrange [split $reftail +] 1 end]} {
+ #unset if indices match
+ error "untested, possibly unused branch spuds1"
+ #puts "1111111111111111111111111"
+ unset $refvar
+ }
+ } else {
+ #test exists - #!todo - document which one
+
+ #see if we succeeded in unsetting this element in the underlying variables
+ #(may have been blocked by a PropertyUnset body)
+ set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]]
+ #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists"
+ if {$element_exists} {
+ #do nothing it wasn't actually unset
+ } else {
+ #puts "JJJJJ unsetting ${refvar}($vidx)"
+ unset ${refvar}($vidx)
+ }
+ }
+ }
+
+
+
+
+
+ } else {
+
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+ unset $refvar
+
+ }
+
+ }
+
+
+
+
+ #!todo - understand.
+ #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n"
+ #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?)
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing setGet trace '$ops' on variable $rv"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+ } errM]} {
+ set ruler [string repeat * 80]
+ puts stderr "\t$ruler"
+ puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op"
+ puts stderr "\t$ruler"
+ puts stderr $::errorInfo
+ puts stderr "\t$ruler"
+
+ }
+
+}
+
+proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} {
+ error hmmmmm
+ upvar $vtraced SYNCVARIABLE
+ #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' "
+ set refvars [::list]
+
+ #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace )
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references
+ #assert triggeringRef is in the list
+ if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} {
+ error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars"
+ }
+ set refposn [lsearch -exact $refvars $triggeringRef]
+ #assert - due to test above, we know $triggeringRef is in the list so refposn > 0
+ set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}]
+ if {![llength $refvars]} {
+ #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop"
+ return [list refs_updates [list]]
+ }
+
+ #suppress the propref_trace_* traces on all refvars
+ array set traces [::list]
+ array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ."
+ #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync
+ #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error?
+ #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref)
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+
+
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ } else {
+ #all other traces are 'external'
+ lappend external_traces($rv) $tinfo
+ #trace remove variable $rv $ops $cmd
+ }
+
+ }
+ }
+ #--------------------------------------------------------------------------------------------------------------------------
+ if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} {
+ if {![info exists SYNCVARIABLE]} {
+ error "WARNING: REVIEW why does $vartraced not exist here?"
+ }
+ #either the underlying variable is an array
+ # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern
+ set treat_vtraced_as_array 1
+ } else {
+ set treat_vtraced_as_array 0
+ }
+
+ set refs_updated [list]
+ set refs_deleted [list] ;#unset due to index no longer being relevant
+ if {$treat_vtraced_as_array} {
+ foreach refvar $refvars {
+ #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'"
+ set refvar_tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $refvar_tail]} {
+ #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y
+ set ref_indices [lrange [split $refvar_tail +] 1 end]
+ if {[llength $indices]} {
+ if {[llength $indices] == 1} {
+ if {[lindex $ref_indices 0] eq [lindex $indices 0]} {
+ #error "untested xxx-a"
+ set ${refvar} [set SYNCVARIABLE([lindex $indices 0])]
+ lappend refs_updated $refvar
+ } else {
+ #test exists
+ #error "xxx-ok single index"
+ #updating a different part of the property - nothing to do
+ }
+ } else {
+ #nested index
+ if {[lindex $ref_indices 0] eq [lindex $indices 0]} {
+ if {[llength $ref_indices] == 1} {
+ #error "untested xxx-b1"
+ set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ]
+ } else {
+ #assert llength $ref_indices > 1
+ #NOTE - we cannot test index equivalence reliably/simply just by comparing indices
+ #compare by value
+
+ if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} {
+ #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'"
+ if {[set $refvar] ne $possiblyNewVal} {
+ set $refvar $possiblyNewVal
+ }
+ } else {
+ #fail to retrieve underlying value corrsponding to these $indices
+ unset $refvar
+ }
+ }
+ } else {
+ #test exists
+ #error "untested xxx-ok deepindex"
+ #updating a different part of the property - nothing to do
+ }
+ }
+ } else {
+ error "untested xxx-c"
+
+ }
+
+ } else {
+ #refvar to update is plain e.g ::p::${OID}::_ref::${prop}
+ if {[llength $indices]} {
+ if {[llength $indices] == 1} {
+ set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])]
+ } else {
+ lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]]
+ }
+ lappend refs_updated $refvar
+ } else {
+ error "untested yyy"
+ set $refvar $SYNCVARIABLE
+ }
+ }
+ }
+ } else {
+ #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x)
+ #
+ foreach refvar $refvars {
+ #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'"
+ set refvar_tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $refvar_tail]} {
+ #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y
+ set ref_indices [lrange [split $refvar_tail +] 1 end]
+
+ if {[llength $indices]} {
+ #see if this update would affect this curried ref
+ #1st see if we can short-circuit our comparison based on numeric-indices
+ if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} {
+ #both sets of indices are purely numeric (no end end-1 etc)
+ set rlen [llength $ref_indices]
+ set ilen [llength $indices]
+ set minlen [expr {min($rlen,$ilen)}]
+ set matched_firstfew_indices 1 ;#assume the best
+ for {set i 0} {$i < $minlen} {incr i} {
+ if {[lindex $ref_indices $i] ne [lindex $indices $i]} {
+ break ;#
+ }
+ }
+ if {!$matched_firstfew_indices} {
+ #update of this refvar not required
+ #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices"
+ break ;#break to next refvar in the foreach loop
+ }
+ }
+ #failed to short-circuit
+
+ #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here
+ set newval [lindex $SYNCVARIABLE $ref_indices]
+ if {[set $refvar] ne $newval} {
+ set $refvar $newval
+ lappend refs_updated $refvar
+ }
+
+ } else {
+ #we must be updating the entire variable - so this curried ref will either need to be updated or unset
+ set newval [lindex $SYNCVARIABLE $ref_indices]
+ if {[set ${refvar}] ne $newval} {
+ set ${refvar} $newval
+ lappend refs_updated $refvar
+ }
+ }
+ } else {
+ #refvar to update is plain e.g ::p::${OID}::_ref::${prop}
+ if {[llength $indices]} {
+ #error "untested zzz-a"
+ set newval [lindex $SYNCVARIABLE $indices]
+ if {[lindex [set $refvar] $indices] ne $newval} {
+ lset ${refvar} $indices $newval
+ lappend refs_updated $refvar
+ }
+ } else {
+ if {[set ${refvar}] ne $SYNCVARIABLE} {
+ set ${refvar} $SYNCVARIABLE
+ lappend refs_updated $refvar
+ }
+ }
+
+ }
+
+ }
+ }
+ #--------------------------------------------------------------------------------------------------------------------------
+
+ #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ if {$rv ni $refs_deleted} {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+ }
+ foreach rv [array names external_traces] {
+ if {$rv ni $refs_deleted} {
+ foreach tinfo $external_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #trace add variable $rv $ops $cmd
+ }
+ }
+ }
+
+
+ return [list updated_refs $refs_updated]
+}
+
+#purpose: update all relevant references when context variable changed directly
+proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} {
+ #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way.
+ #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler
+
+ upvar $vtraced SYNCVARIABLE
+ #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op"
+ set t_info [trace vinfo $vtraced]
+ foreach t_spec $t_info {
+ set t_ops [lindex $t_spec 0]
+ if {$op in $t_ops} {
+ puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]"
+ }
+ }
+
+ #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*-
+ #vtype = array | array-item | list | simple
+
+ set refvars [::list]
+
+ ############################
+ #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!!
+ #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs)
+ #The alternative 'info vars' does not trigger traces
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ #puts " **> lappending '::p::REF::${OID}::$prop'"
+ lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ }
+ ############################
+
+ #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references
+
+
+ if {![llength $refvars]} {
+ #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop"
+ return
+ }
+
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+ #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars
+ array set predator_traces [::list]
+ #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace..
+ #ie for something like 'trace add variable someref {write read array} somefunc'
+ # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace
+ array set external_read_traces [::list] ;#pure read traces the library user may have added
+ array set external_readetc_traces [::list] ;#read + something else traces the library user may have added
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ #if {$ops in {read write unset array}} {}
+
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend predator_traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ } else {
+ #other traces
+ # puts "##trace $tinfo"
+ if {"read" in $ops} {
+ if {[llength $ops] == 1} {
+ #pure read -
+ lappend external_read_traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ } else {
+ #mixed operation trace - remove and reinstall without the 'read'
+ lappend external_readetc_traces($rv) $tinfo
+ set other_ops [lsearch -all -inline -not $ops "read"]
+ trace remove variable $rv $ops $cmd
+ #reinstall trace for non-read operations only
+ trace add variable $rv $other_ops $cmd
+ }
+ }
+ }
+ }
+ }
+
+
+ if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} {
+ #either the underlying variable is an array
+ # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern
+ set vtracedIsArray 1
+ } else {
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op"
+ #puts "**write*********** refvars: $refvars"
+
+ #!todo? unroll foreach into multiple foreaches within ifs?
+ #foreach refvar $refvars {}
+
+
+ #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar"
+ if {[string length $vidx]} {
+ #indexable
+ if {$vtracedIsArray} {
+
+ foreach refvar $refvars {
+ #puts stderr " - - a refvar $refvar vidx: $vidx"
+ set tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $tail]} {
+ #refvar is curried
+ #only set if vidx matches curried index
+ #!todo -review
+ set idx [lrange [split $tail +] 1 end]
+ if {$idx eq $vidx} {
+ set newval [set SYNCVARIABLE($vidx)]
+ if {[set $refvar] ne $newval} {
+ set ${refvar} $newval
+ }
+ #puts stderr "=a.1=> updated $refvar"
+ }
+ } else {
+ #refvar is simple
+ set newval [set SYNCVARIABLE($vidx)]
+ if {![info exists ${refvar}($vidx)]} {
+ #new key for this array
+ #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' "
+ array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ]
+ } else {
+ set oldval [set ${refvar}($vidx)]
+ if {$oldval ne $newval} {
+ #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' "
+ array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ]
+ }
+ }
+ #puts stderr "=a.2=> updated ${refvar} $vidx"
+ }
+ }
+
+
+
+ } else {
+
+
+ foreach refvar $refvars {
+ upvar $refvar internal_property_reference
+ #puts stderr " - - b vidx: $vidx"
+
+ #!? could be object not list??
+ #!!but what is the difference between an object, and a list of object names which happens to only contain one object??
+ #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations)
+ #There would still be an edge case of an initial write of a list of objects of length 1.
+ if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} {
+ error "untested review!"
+ #the o_prop is object-shaped
+ #assumes object has a defaultmethod which accepts indices
+ set newval [[set $SYNCVARIABLE] {*}$vidx]
+
+ } else {
+ set newval [lindex $SYNCVARIABLE {*}$vidx]
+ #if {[set $refvar] ne $newval} {
+ # set $refvar $newval
+ #}
+ if {$internal_property_reference ne $newval} {
+ set internal_property_reference $newval
+ }
+
+ }
+ #puts stderr "=b=> updated $refvar"
+ }
+
+
+ }
+
+
+
+ } else {
+ #no vidx
+
+ if {$vtracedIsArray} {
+
+
+ foreach refvar $refvars {
+ set targetref_tail [namespace tail $refvar]
+ set targetref_is_indexed [string match "${prop}+*" $targetref_tail]
+
+
+ #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef"
+ if {$targetref_is_indexed} {
+ #curried array item ref of the form ${prop}+x or ${prop}+x+y etc
+
+ #unindexed write on a property that is acting as an array..
+
+ #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok.
+
+ #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index).
+ # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing.
+ puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op"
+ } else {
+ #How do we know what to write to array ref?
+ puts stderr "\tc.2 WARNING: unimplemented/unused?"
+ #error no_tests_for_branch
+
+ #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation
+ #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate
+ array unset ${refvar}
+ array set ${refvar} [array get SYNCVARIABLE]
+ }
+ }
+
+
+
+ } else {
+ foreach refvar $refvars {
+ #puts stderr "\t\t_________________[namespace current]"
+ set targetref_tail [namespace tail $refvar]
+ upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail
+ set targetref_is_indexed [string match "${prop}+*" $targetref_tail]
+
+ if {$targetref_is_indexed} {
+ #puts "XXXXXXXXX vtraced:$vtraced"
+ #reference curried with index(es)
+ #we only set indexed refs if value has changed
+ # - this not required to be consistent with standard list-containing variable traces,
+ # as normally list elements can't be traced seperately anyway.
+ #
+
+
+ #only bother checking a ref if no setVia index
+ # i.e some operation on entire variable so need to test synchronisation for each element-ref
+ set targetref_indices [lrange [split $targetref_tail +] 1 end]
+ set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices]
+ #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal"
+ if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} {
+ set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal
+ #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]"
+ }
+
+
+ } else {
+ #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed!
+
+ #puts stderr "- d2 set"
+ #puts "refvar: [set $refvar]"
+ #puts "SYNCVARIABLE: $SYNCVARIABLE"
+
+ #if {[set $refvar] ne $SYNCVARIABLE} {
+ # set $refvar $SYNCVARIABLE
+ #}
+ if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} {
+ set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE
+ }
+
+ }
+ }
+
+
+ }
+
+ }
+
+
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names predator_traces] {
+ foreach tinfo $predator_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+ foreach rv [array names external_traces] {
+ foreach tinfo $external_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+
+
+}
+
+# end propvar_write_TraceHandler
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#
+
+#returns 0 if method implementation not present for interface
+proc ::p::predator::method_chainhead {iid method} {
+ #Interface proc
+ # examine the existing command-chain
+ set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex)
+ set cmdchain [list]
+
+ set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}]
+ set maxversion 0
+ #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob.
+ foreach test [lsort -dictionary $candidates] {
+ set c [namespace tail $test]
+ if {[regexp $re $c _match version]} {
+ lappend cmdchain $c
+ if {$version > $maxversion} {
+ set maxversion $version
+ }
+ }
+ }
+ return $maxversion
+}
+
+
+
+
+
+#this returns a script that upvars vars for all interfaces on the calling object -
+# - must be called at runtime from a method
+proc ::p::predator::upvar_all {_ID_} {
+ #::set OID [lindex $_ID_ 0 0]
+ ::set OID [::lindex [::dict get $_ID_ i this] 0 0]
+ ::set decl {}
+ #[set ::p::${OID}::_meta::map]
+ #[dict get [lindex [dict get $_ID_ i this] 0 1] map]
+
+ ::upvar #0 ::p::${OID}::_meta::map MAP
+ #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n"
+ #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0]
+
+ ::foreach ifid [dict get $MAP interfaces level0] {
+ if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} {
+ ::array unset nsvars
+ ::array set nsvars [::list]
+ ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] {
+ ::set varspace [::dict get $vinfo varspace]
+ ::lappend nsvars($varspace) $vname
+ }
+ #nsvars now contains vars grouped by varspace.
+
+ ::foreach varspace [::array names nsvars] {
+ if {$varspace eq ""} {
+ ::set ns ::p::${OID}
+ } else {
+ if {[::string match "::*" $varspace]} {
+ ::set ns $varspace
+ } else {
+ ::set ns ::p::${OID}::$varspace
+ }
+ }
+
+ ::append decl "namespace upvar $ns "
+ ::foreach vname [::set nsvars($varspace)] {
+ ::append decl "$vname $vname "
+ }
+ ::append decl " ;\n"
+ }
+ ::array unset nsvars
+ }
+ }
+ ::return $decl
+}
+
+#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator)
+proc ::p::predator::runtime_vardecls {} {
+ set result "::eval \[::p::predator::upvar_all \$_ID_\]"
+ #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_"
+
+ #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]"
+ #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]"
+ #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'"
+ return $result
+}
+
+
+
+
+
+
+#OBSOLETE!(?) - todo - move stuff out of here.
+proc ::p::predator::compile_interface {IFID caller_ID_} {
+ upvar 0 ::p::${IFID}:: IFACE
+
+ #namespace eval ::p::${IFID} {
+ # namespace ensemble create
+ #}
+
+ #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables
+
+ namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces
+
+ #set varDecls {}
+ #if {[llength $o_variables]} {
+ # #puts "*********!!!! $vlist"
+ # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] "
+ # foreach vdef $o_variables {
+ # append varDecls "[lindex $vdef 0] [lindex $vdef 0] "
+ # }
+ # append varDecls \n
+ #}
+
+ #runtime gathering of vars from other interfaces.
+ #append varDecls [runtime_vardecls]
+
+ set varDecls [runtime_vardecls]
+
+
+
+ #implement methods
+
+ #!todo - avoid globs on iface array? maintain list of methods in another slot?
+ #foreach {n mname} [array get IFACE m-1,name,*] {}
+
+
+ #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble.
+
+
+
+ #implement property getters/setters/unsetters
+ #'setter' overrides
+ #pw short for propertywrite
+ foreach {n property} [array get IFACE pw,name,*] {
+ if {[string length $property]} {
+ #set property [lindex [split $n ,] end]
+
+ #!todo - next_script
+ #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property]
+
+ set maxversion [::p::predator::method_chainhead $IFID (SET)$property]
+ set chainhead [expr {$maxversion + 1}]
+ set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1
+
+ set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??
+
+ set body $IFACE(pw,body,$property)
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body"
+ }
+
+ #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+
+ set maxversion [::p::predator::method_chainhead $IFID $property]
+ set headid [expr {$maxversion + 1}]
+
+ proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body
+
+ interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid
+
+ #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body
+ }
+ }
+ #'unset' overrides
+
+ dict for {property handler_info} $o_propertyunset_handlers {
+
+ set body [dict get $handler_info body]
+ set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array
+
+ set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (UNSET)$property.$headid
+
+ set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ???
+
+
+
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body"
+
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+
+
+ #implement
+ #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements)
+ if {[string trim $arraykeypattern] eq ""} {
+ set arraykeypattern "_dontcare_"
+ }
+ proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body
+
+
+ #chainhead pointer
+ interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid
+ }
+
+
+
+ interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE)
+
+ #the usual case will have no destructor - so use info exists to check.
+
+ if {[info exists ::p::${IFID}::_iface::o_destructor_body]} {
+ #!todo - chained destructors (support @next@).
+ #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID]
+ set next NEXT
+
+ set body [set ::p::${IFID}::_iface::o_destructor_body]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body"
+ }
+ #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body]
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ proc ::p::${IFID}::___system___destructor _ID_ $body
+ }
+
+
+ if {[info exists o_unknown]} {
+ #use 'apply' somehow?
+ interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown
+
+ #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown]
+ }
+
+
+ return
+}
+
+
+
+
+
+
+
+#'info args' - assuming arbitrary chain of 'interp aliases'
+proc ::p::predator::command_info_args {cmd} {
+ if {[llength [set next [interp alias {} $cmd]]]} {
+ set curriedargs [lrange $next 1 end]
+
+ if {[catch {set arglist [info args [lindex $next 0]]}]} {
+ set arglist [command_info_args [lindex $next 0]]
+ }
+ #trim curriedargs
+ return [lrange $arglist [llength $curriedargs] end]
+ } else {
+ info args $cmd
+ }
+}
+
+
+proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} {
+ if {[llength $args]} {
+ tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args
+ } else {
+ if {[llength $nextArgs] > 1} {
+ set argVals [::list]
+ set i 0
+ foreach arg [lrange $nextArgs 1 end] {
+ upvar 1 $arg $i
+ if {$arg eq "args"} {
+ #need to check if 'args' is actually available in caller
+ if {[info exists $i]} {
+ set argVals [concat $argVals [set $i]]
+ }
+ } else {
+ lappend argVals [set $i]
+ }
+ }
+ tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals
+ } else {
+ tailcall ::p::${IFID}::_iface::$mname $_ID_
+ }
+ }
+}
+
+#----------------------------------------------------------------------------------------------
+proc ::p::predator::next_script {IFID method caller caller_ID_} {
+
+ if {$caller eq "(CONSTRUCTOR).1"} {
+ return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}]
+ } elseif {$caller eq "$method.1"} {
+ #delegate to next interface lower down the stack which has a member named $method
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ } elseif {[string match "(GET)*.2" $caller]} {
+ # .1 is the getprop procedure, .2 is the bottom-most PropertyRead.
+
+ #jmn
+ set prop [string trimright $caller 1234567890]
+ set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing .
+
+ if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} {
+ #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}]
+ return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}]
+ } else {
+ #we can actually have a property read without a property or a method of that name - but it could also match the name of a method.
+ # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something)
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ }
+ } elseif {[string match "(SET)*.2" $caller]} {
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ } else {
+ #this branch will also handle (SET)*.x and (GET)*.x where x >2
+
+ #puts stdout "............next_script IFID:$IFID method:$method caller:$caller"
+ set callerid [string range $caller [string length "$method."] end]
+ set nextid [expr {$callerid - 1}]
+
+ if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} {
+ #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface.
+ #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid"
+ set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid]
+ }
+
+ return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}]
+ }
+}
+
+proc ::p::predator::do_next_if {_ID_ IFID method args} {
+ #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' ((("
+
+ #set invocants [dict get $_ID_ i]
+ #set this_invocantdata [lindex [dict get $invocants this] 0]
+ #lassign $this_invocantdata OID this_info
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set interfaces [dict get $MAP interfaces level0]
+ set patterninterfaces [dict get $MAP interfaces level1]
+
+ set L0_posn [lsearch $interfaces $IFID]
+ if {$L0_posn == -1} {
+ error "(::p::predator::do_next_if) called with interface not present at level0 for this object"
+ } elseif {$L0_posn > 0} {
+ #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack
+ set lower_interfaces [lrange $interfaces 0 $L0_posn-1]
+
+ foreach if_sub [lreverse $lower_interfaces] {
+ if {[string match "(GET)*" $method]} {
+ #do not test o_properties here! We need to call even if there is no underlying property on this interface
+ #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface)
+ # relevant test: higher_order_propertyread_chaining
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ } elseif {[string match "(SET)*" $method]} {
+ #must be called even if there is no matching $method in o_properties
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ } elseif {[string match "(UNSET)*" $method]} {
+ #review untested
+ #error "do_next_if (UNSET) untested"
+ #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'"
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+
+ } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} {
+ if {[llength $args]} {
+ #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args"
+
+ #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args
+
+ #!todo - handle case where llength $args is less than number of args for subinterface command
+ #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set)
+
+ #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature)
+ set head [interp alias {} ::p::${if_sub}::_iface::$method]
+ set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc
+ set argx [list]
+ foreach a $nextArgs {
+ lappend argx "\$a"
+ }
+
+ #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared
+
+ if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} {
+ tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args
+ } else {
+ #todo - upvars required for tail end of arglist
+ tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args
+ }
+
+ } else {
+ #auto-set: upvar vars from calling scope
+ #!todo - robustify? alias not necessarily matching command name..
+ set head [interp alias {} ::p::${if_sub}::_iface::$method]
+
+
+ set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc
+ if {[llength $nextArgs] > 1} {
+ set argVals [::list]
+ set i 0
+ foreach arg [lrange $nextArgs 1 end] {
+ upvar 1 $arg $i
+ if {$arg eq "args"} {
+ #need to check if 'args' is actually available in caller
+ if {[info exists $i]} {
+ set argVals [concat $argVals [set $i]]
+ }
+ } else {
+ lappend argVals [set $i]
+ }
+ }
+ #return [$head $_ID_ {*}$argVals]
+ tailcall $head $_ID_ {*}$argVals
+ } else {
+ #return [$head $_ID_]
+ tailcall $head $_ID_
+ }
+ }
+ } elseif {$method eq "(CONSTRUCTOR)"} {
+ #chained constructors will only get args if the @next@ caller explicitly provided them.
+ puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!"
+ #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args]
+ xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args
+ }
+ }
+ #no interfaces in the iStack contained a matching method.
+ return
+ } else {
+ #no further interfaces in this iStack
+ return
+ }
+}
+
+
+#only really makes sense for (CONSTRUCTOR) calls.
+#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class.
+proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} {
+ #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' ((("
+
+ #set invocants [dict get $_ID_ i]
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID this_info
+ #set OID [lindex [dict get $invocants this] 0 0]
+ #upvar #0 ::p::${OID}::_meta::map map
+ #lassign [lindex $map 0] OID alias itemCmd cmd
+
+
+ set caller_OID [lindex [dict get $caller_ID_ i this] 0 0]
+ upvar #0 ::p::${caller_OID}::_meta::map callermap
+
+ #set interfaces [lindex $map 1 0]
+ set patterninterfaces [dict get $callermap interfaces level1]
+
+ set L0_posn [lsearch $patterninterfaces $IFID]
+ if {$L0_posn == -1} {
+ error "do_next_pattern_if called with interface not present at level1 for this object"
+ } elseif {$L0_posn > 0} {
+
+
+ set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1]
+
+ foreach if_sub [lreverse $lower_interfaces] {
+ if {$method eq "(CONSTRUCTOR)"} {
+ #chained constructors will only get args if the @next@ caller explicitly provided them.
+ #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!"
+ tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args
+ }
+ }
+ #no interfaces in the iStack contained a matching method.
+ return
+ } else {
+ #no further interfaces in this iStack
+ return
+ }
+}
+
+
+
+
+
+#------------------------------------------------------------------------------------------------
+
+
+
+
+
+#-------------------------------------------------------------------------------------
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+
+
+#!todo - can we just call new_object somehow to create this?
+
+ #until we have a version of Tcl that doesn't have 'creative writing' scope issues -
+ # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword.
+ # (see http://mini.net/tcl/1030 'Dangers of creative writing')
+namespace eval ::p::-1 {
+ #namespace ensemble create
+
+ namespace eval _ref {}
+ namespace eval _meta {}
+
+ namespace eval _iface {
+ variable o_usedby
+ variable o_open
+ variable o_constructor
+ variable o_variables
+ variable o_properties
+ variable o_methods
+ variable o_definition
+ variable o_varspace
+ variable o_varspaces
+
+ array set o_usedby [list i0 1] ;#!todo - review
+ #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value?
+
+ set o_open 1
+ set o_constructor [list]
+ set o_variables [list]
+ set o_properties [dict create]
+ set o_methods [dict create]
+ array set o_definition [list]
+ set o_varspace ""
+ set o_varspaces [list]
+ }
+}
+
+
+#
+
+#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}]
+interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}]
+
+
+upvar #0 ::p::-1::_iface::o_definition def
+
+
+#! concatenate -> compose ??
+dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}}
+proc ::p::-1::Concatenate {_ID_ target args} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ if {![string match "::*" $target]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set target ::$target
+ } else {
+ set target ${ns}::$target
+ }
+ }
+ #add > character if not already present
+ set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >]
+ set _target [string map {::> ::} $target]
+
+ set ns [namespace qualifiers $target]
+ if {$ns eq ""} {
+ set ns "::"
+ } else {
+ namespace eval $ns {}
+ }
+
+ if {![llength [info commands $target]]} {
+ #degenerate case - target does not exist
+ #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone'
+ #review - should be 'Copy' so it has object state from namespaces and variables?
+ return [::p::-1::Clone $_ID_ $target {*}$args]
+
+ #set TARGETMAP [::p::predator::new_object $target]
+ #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd
+
+ } else {
+ #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1]
+ set TARGETMAP [$target --]
+
+ lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd
+
+ #Merge lastmodified(?) level0 and level1 interfaces.
+
+ }
+
+ return $target
+}
+
+
+
+#Object's Base-Interface proc with itself as curried invocant.
+#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant
+#namespace eval ::p::-1 {namespace export Create}
+dict set ::p::-1::_iface::o_methods Define {arglist definitions}
+#define objects in one step
+proc ::p::-1::Define {_ID_ definitions} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias default_method cmd
+ set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces
+ set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces
+
+ #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack
+ #set IFID0 [lindex $interfaces 0]
+ #set IFID1 [lindex $patterns 0] ;#1st pattern
+
+ #set IFID_TOP [lindex $interfaces end]
+ set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID]
+
+ #set ns ::p::${OID}
+
+ #set script [string map [list %definitions% $definitions] {
+ # if {[lindex [namespace path] 0] ne "::p::-1"} {
+ # namespace path [list ::p::-1 {*}[namespace path]]
+ # }
+ # %definitions%
+ # namespace path [lrange [namespace path] 1 end]
+ #
+ #}]
+
+ set script [string map [list %id% $_ID_ %definitions% $definitions] {
+ set ::p::-1::temp_unknown [namespace unknown]
+
+ namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}]
+
+
+ #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ]
+
+
+ %definitions%
+
+
+ namespace unknown ${::p::-1::temp_unknown}
+ return
+ }]
+
+
+
+ #uplevel 1 $script ;#this would run the script in the global namespace
+ #run script in the namespace of the open interface, this allows creating of private helper procs
+ #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack
+ #namespace inscope ::p::${OID} $script
+ namespace eval ::p::${OID} $script
+ #return $cmd
+}
+
+
+proc ::p::predator::redirect {func args} {
+
+ #todo - review tailcall - tests?
+ if {![llength [info commands ::p::-1::$func]]} {
+ #error "invalid command name \"$func\""
+ tailcall uplevel 1 [list ::unknown $func {*}$args]
+ } else {
+ tailcall uplevel 1 [list ::p::-1::$func {*}$args]
+ }
+}
+
+
+#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review.
+dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}}
+proc ::p::-1::Construct {_ID_ argpairs body args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+ namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ set ARGSETTER {}
+ foreach {argname argval} $argpairs {
+ append ARGSETTER "set $argname $argval\n"
+ }
+ #$_self (VIOLATE) $ARGSETTER$body
+
+ set body $ARGSETTER\n$body
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls\n[dict get $processed body]
+ # puts stderr "\t runtime_vardecls in Construct $varDecls"
+ }
+
+ set next "\[error {next not implemented}\]"
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ #namespace eval ::p::${iid_top} $body
+
+ #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_]
+ #does this handle Varspace before constructor?
+ return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args]
+}
+
+
+
+
+
+#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects
+namespace eval ::p::3 {}
+proc ::p::3::_create {child {OID "-2"}} {
+ #puts stderr "::p::3::_create $child $OID"
+ set _child [string map {::> ::} $child]
+ if {$OID eq "-2"} {
+ #set childmapdata [::p::internals::new_object $child]
+ #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ]
+ set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0]
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+ } else {
+ set child_ID $OID
+ #set _childmap [::p::internals::new_object $child "" $child_ID]
+ ::p::internals::new_object $child "" $child_ID
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+ }
+
+ #--------------
+
+ set oldinterfaces [dict get $CHILDMAP interfaces]
+ dict set oldinterfaces level0 [list 2]
+ set modifiedinterfaces $oldinterfaces
+ dict set CHILDMAP interfaces $modifiedinterfaces
+
+ #--------------
+
+
+
+
+ #puts stderr ">>>> creating alias for ::p::$child_ID"
+ #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]"
+
+ #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing!
+ #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]]
+ #puts stderr ">>>[interp alias {} ::p::$child_ID]"
+
+
+
+ #---------------
+ namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties
+ foreach method [dict keys $o_methods] {
+ #todo - change from interp alias to context proc
+ interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method
+ }
+ #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods]
+ #implement property even if interface already compiled because we need to create defaults for each new child obj.
+ # also need to add alias on base interface
+ #make sure we are only implementing properties from the current CREATOR
+ dict for {prop pdef} $o_properties {
+ #lassign $pdef prop default
+ interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop
+ interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop
+
+ }
+ ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}]
+ #---------------
+ #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child"
+ return $child
+}
+
+#configure -prop1 val1 -prop2 val2 ...
+dict set ::p::-1::_iface::o_methods Configure {arglist args}
+proc ::p::-1::Configure {_ID_ args} {
+
+ #!todo - add tests.
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd this
+
+ if {![expr {([llength $args] % 2) == 0}]} {
+ error "expected even number of Configure args e.g '-property1 value1 -property2 value2'"
+ }
+
+ #Do a separate loop to check all the arguments before we run the property setting loop
+ set properties_to_configure [list]
+ foreach {argprop val} $args {
+ if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} {
+ error "expected Configure args in the form: '-property1 value1 -property2 value2'"
+ }
+ lappend properties_to_configure [string range $argprop 1 end]
+ }
+
+ #gather all valid property names for all level0 interfaces in the relevant interface stack
+ set valid_property_names [list]
+ set iflist [dict get $MAP interfaces level0]
+ foreach id [lreverse $iflist] {
+ set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]]
+ foreach if_prop $interface_property_names {
+ if {$if_prop ni $valid_property_names} {
+ lappend valid_property_names $if_prop
+ }
+ }
+ }
+
+ foreach argprop $properties_to_configure {
+ if {$argprop ni $valid_property_names} {
+ error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names"
+ }
+ }
+
+ set top_IID [lindex $iflist end]
+ #args ok - go ahead and set all properties
+ foreach {prop val} $args {
+ set property [string range $prop 1 end]
+ #------------
+ #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update
+ #ie don't do this here: set [$this . $property .] $val
+ #-------------
+ ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val]
+ }
+ return
+}
+
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid}
+proc ::p::-1::AddPatternInterface {_ID_ iid} {
+ #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid"
+ if {![string is integer -strict $iid]} {
+ error "adding interface by name not yet supported. Please use integer id"
+ }
+
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ #lassign [lindex $invocant 0] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces
+
+
+
+ #it is theoretically possible to have the same interface present multiple times in an iStack.
+ # #!todo -review why/whether this is useful. should we disallow it and treat as an error?
+
+ lappend existing_ifaces $iid
+ #lset map {1 1} $existing_ifaces
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 $existing_ifaces
+ dict set MAP interfaces $extracted_sub_dict
+
+ #lset invocant {1 1} $existing_ifaces
+
+}
+
+
+#!todo - update usedby ??
+dict set ::p::-1::_iface::o_methods AddInterface {arglist iid}
+proc ::p::-1::AddInterface {_ID_ iid} {
+ #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid"
+ if {![string is integer -strict $iid]} {
+ error "adding interface by name not yet supported. Please use integer id"
+ }
+
+
+ lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list.
+ set this_invocant [lindex $list_of_invocants_for_role_this 0]
+
+ lassign $this_invocant OID _etc
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set existing_ifaces [dict get $MAP interfaces level0]
+
+ lappend existing_ifaces $iid
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 $existing_ifaces
+ dict set MAP interfaces $extracted_sub_dict
+ return [dict get $extracted_sub_dict level0]
+}
+
+
+
+# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module.
+# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist
+# and 'CreateOverlay' for the case where the target/child object already exists.
+# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence,
+# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object.
+# 'CreateNew' will raise an error if the target already exists
+# 'CreateOverlay' will raise an error if the target object does not exist.
+# 'Create' will work in either case. Creating the target if necessary.
+
+
+#simple form:
+# >somepattern .. Create >child
+#simple form with arguments to the constructor:
+# >somepattern .. Create >child arg1 arg2 etc
+#complex form - specify more info about the target (dict keyed on childobject name):
+# >somepattern .. Create {>child {-id 1}}
+#or
+# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}]
+#complex form - with arguments to the contructor:
+# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc
+dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}}
+proc ::p::-1::Create {_ID_ target_spec args} {
+ #$args are passed to constructor
+ if {[llength $target_spec] ==1} {
+ set child $target_spec
+ set targets [list $child {}]
+ } else {
+ set targets $target_spec
+ }
+
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case)
+
+ foreach {child target_spec_dict} $targets {
+ #puts ">>>::p::-1::Create $_ID_ $child $args <<<"
+
+
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+
+
+
+ #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID"
+
+ #child should already be fully ns qualified (?)
+ #ensure it is has a pattern-object marker >
+ #puts stderr ".... $child (nsqual: [namespace qualifiers $child])"
+
+
+ lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd
+ set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces
+ set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces
+ #puts "parent: $OID -> child:$child Patterns $patterns"
+
+ #todo - change to dict of interface stacks
+ set IFID0 [lindex $interfaces 0]
+ set IFID1 [lindex $patterns 0] ;#1st pattern
+
+ #upvar ::p::${OID}:: INFO
+
+ if {![string match {::*} $child]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set child ::$child
+ } else {
+ set child ${ns}::$child
+ }
+ }
+
+
+ #add > character if not already present
+ set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >]
+ set _child [string map {::> ::} $child]
+
+ set ns [namespace qualifiers $child]
+ if {$ns eq ""} {
+ set ns "::"
+ } else {
+ namespace eval $ns {}
+ }
+
+
+ #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls.
+ set new_interfaces [list]
+
+ if {![llength $patterns]} {
+ ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child"
+ #lappend patterns [::p::internals::new_interface $OID]
+
+ #lset invocant {1 1} $patterns
+ ##update our command because we changed the interface list.
+ #set IFID1 [lindex $patterns 0]
+
+ #set patterns [list [::p::internals::new_interface $OID]]
+
+ #set patterns [list [::p::internals::new_interface]]
+
+ #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id
+ #set patterns [list [set iid [incr ::p::ID]]]
+ set patterns [list [set iid [::p::get_new_object_id]]]
+
+ #---------
+ #set iface [::p::>interface .. Create ::p::ifaces::>$iid]
+ #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid
+
+ #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation
+ lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid]
+
+ #---------
+
+ #puts "??> p::>interface .. Create ::p::ifaces::>$iid"
+ #puts "??> [::p::ifaces::>$iid --]"
+ #set [$iface . UsedBy .]
+ }
+ set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod]
+
+ #if {![llength [info commands $child]]} {}
+
+ if {[namespace which $child] eq ""} {
+ #normal case - target/child does not exist
+ set is_new_object 1
+
+ if {[dict exists $target_spec_dict -id]} {
+ set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]]
+ } else {
+ set childmapdata [::p::internals::new_object $child]
+ }
+ lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+
+
+
+ #child initially uses parent's level1 interface as it's level0 interface
+ # child has no level1 interface until PatternMethods or PatternProperties are added
+ # (or applied via clone; or via create with a parent with level2 interface)
+ #set child_IFID $IFID1
+
+ #lset CHILDMAP {1 0} [list $IFID1]
+ #lset CHILDMAP {1 0} $patterns
+
+ set extracted_sub_dict [dict get $CHILDMAP interfaces]
+ dict set extracted_sub_dict level0 $patterns
+ dict set CHILDMAP interfaces $extracted_sub_dict
+
+ #why write back when upvared???
+ #review
+ set ::p::${child_ID}::_meta::map $CHILDMAP
+
+ #::p::predator::remap $CHILDMAP
+
+ #interp alias {} $child {} ::p::internals::predator $CHILDMAP
+
+ #set child_IFID $IFID1
+
+ #upvar ::p::${child_ID}:: child_INFO
+
+ #!todo review
+ #set n ::p::${child_ID}
+ #if {![info exists ${n}::-->PATTERN_ANCHOR]} {
+ # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'"
+ # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack
+ # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset"
+ # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n]
+ #}
+
+ set ifaces_added $patterns
+
+ } else {
+ #overlay/mixin case - target/child already exists
+ set is_new_object 0
+
+ #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1]
+ set childmapdata [$child --]
+
+
+ #puts stderr " *** $cmd .. Create -> target $child already exists!!!"
+ #puts " **** CHILDMAP: $CHILDMAP"
+ #puts " ****"
+
+ #puts stderr " ---> Properties: [$child .. Properties . names]"
+ #puts stderr " ---> Methods: [$child .. Properties . names]"
+
+ lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+
+ #set child_IFID [lindex $CHILDMAP 1 0 end]
+ #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} {
+ # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID]
+ # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP
+ #}
+ ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces
+ #::p::merge_interface $IFID1 $child_IFID
+
+
+ set existing_interfaces [dict get $CHILDMAP interfaces level0]
+ set ifaces_added [list]
+ foreach p $patterns {
+ if {$p ni $existing_interfaces} {
+ lappend ifaces_added $p
+ }
+ }
+
+ if {[llength $ifaces_added]} {
+ #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added]
+ set extracted_sub_dict [dict get $CHILDMAP interfaces]
+ dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added]
+ dict set CHILDMAP interfaces $extracted_sub_dict
+ #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why?
+ #::p::predator::remap $CHILDMAP
+ }
+ }
+
+ #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty
+ if {$parent_patterndefaultmethod ne ""} {
+ set child_defaultmethod $parent_patterndefaultmethod
+ set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata]
+ lset CHILD_INVOCANTDATA 2 $child_defaultmethod
+ dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA
+ #update the child's _ID_
+ interp alias {} $child_alias {} ;#first we must delete it
+ interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}]
+
+ #! object_command was initially created as the renamed alias - so we have to do it again
+ rename $child_alias $child
+ trace add command $child rename [list $child .. Rename]
+ }
+ #!todo - review - dont we already have interp alias entries for every method/prop?
+ #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child"
+
+
+
+
+
+ set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call.
+
+
+
+ #------------------------------------------------------------------------------------
+ #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail.
+ # - All variables under the namespace - not just those declared as Variables or Properties
+ # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces.
+ # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write.
+
+ #NOTE - do not use the objectID as the sole identifier for the snapshot namespace.
+ # - there may be multiple active snapshots for a single object if it overlays itself during a constructor,
+ # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call.
+ # - we will use an ever-increasing snapshotid to form part of ns_snap
+ set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create.
+
+ #!todo - this should look at child namespaces (recursively?)
+ #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces.
+ # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace)
+
+ namespace eval $ns_snap {}
+ foreach vname [info vars ::p::${child_ID}::*] {
+ set shortname [namespace tail $vname]
+ if {[array exists $vname]} {
+ array set ${ns_snap}::${shortname} [array get $vname]
+ } elseif {[info exists $vname]} {
+ set ${ns_snap}::${shortname} [set $vname]
+ } else {
+ #variable exists without value (e.g created by 'variable' command)
+ namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist'
+ }
+ }
+ #------------------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+ #puts "====>>> ifaces_added $ifaces_added"
+ set idx 0
+ set idx_count [llength $ifaces_added]
+ set highest_constructor_IFID ""
+ foreach IFID $ifaces_added {
+ incr idx
+ #puts "--> adding iface $IFID "
+ namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces
+
+ if {[llength $o_varspaces]} {
+ foreach vs $o_varspaces {
+ #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work.
+ if {[string match "::*" $vs]} {
+ namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all.
+ } else {
+ namespace eval ::p::${child_ID}::$vs {}
+ }
+ }
+ }
+
+ if {$IFID != 2} {
+ #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list.
+ if {![info exists o_usedby(i$child_ID)]} {
+ set o_usedby(i$child_ID) $child_alias
+ }
+
+ #compile and close the interface only if it is shared
+ if {$o_open} {
+ ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_
+ set o_open 0
+ }
+ }
+
+
+
+ package require struct::set
+
+ set propcmds [list]
+ foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] {
+ set cmd [namespace tail $cmd]
+ #may contain multiple results for same prop e.g (GET)x.3
+ set cmd [string trimright $cmd 0123456789]
+ set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals
+ lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here.
+ }
+ set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes.
+ #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface.
+ foreach property $propcmds {
+ #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n"
+ interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces
+ interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property
+ }
+
+ set propcmds [list]
+ foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] {
+ set cmd [namespace tail $cmd]
+ #may contain multiple results for same prop e.g (GET)x.3
+ set cmd [string trimright $cmd 0123456789]
+ set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals
+ lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here.
+ }
+ set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes.
+ #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface.
+ foreach property $propcmds {
+ interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces
+ }
+
+
+ foreach method [dict keys $o_methods] {
+ set arglist [dict get $o_methods $method arglist]
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+
+ #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method
+
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #proc calls the method in the interface - which is an interp alias to the head of the implementation chain
+
+
+ proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${IFID}::_iface::$method \$_ID_ $argvals
+ }]
+
+ #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] {
+ # ::p::@ID@::_iface::@m@ $_ID_ @argvals@
+ #}]
+
+
+ }
+
+ #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods]
+
+ #implement property even if interface already compiled because we need to create defaults for each new child obj.
+ # also need to add alias on base interface
+ #make sure we are only implementing properties from the current CREATOR
+ dict for {prop pdef} $o_properties {
+ set varspace [dict get $pdef varspace]
+ if {![string length $varspace]} {
+ set ns ::p::${child_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${child_ID}::$varspace
+ }
+ }
+ if {[dict exists $pdef default]} {
+ if {![info exists ${ns}::o_$prop]} {
+ #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset)
+ set ${ns}::o_$prop [dict get $pdef default]
+ }
+ }
+ #! May be replaced by a method with the same name
+ if {$prop ni [dict keys $o_methods]} {
+ interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop
+ }
+ interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop
+ interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop
+ }
+
+
+
+ #variables
+ #foreach vdef $o_variables {
+ # if {[llength $vdef] == 2} {
+ # #there is a default value defined.
+ # lassign $vdef v default
+ # if {![info exists ::p::${child_ID}::$v]} {
+ # set ::p::${child_ID}::$v $default
+ # }
+ # }
+ #}
+ dict for {vname vdef} $o_variables {
+ if {[dict exists $vdef default]} {
+ #there is a default value defined.
+ set varspace [dict get $vdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${child_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${child_ID}::$varspace
+ }
+ }
+ set ${ns}::$vname [dict get $vdef default]
+ }
+ }
+
+
+ #!todo - review. Write tests for cases of multiple constructors!
+
+ #We don't want to the run constructor for each added interface with the same set of args!
+ #run for last one - rely on constructor authors to use @next@ properly?
+ if {[llength [set ::p::${IFID}::_iface::o_constructor]]} {
+ set highest_constructor_IFID $IFID
+ }
+
+ if {$idx == $idx_count} {
+ #we are processing the last interface that was added - now run the latest constructor found
+ if {$highest_constructor_IFID ne ""} {
+ #at least one interface has a constructor
+ if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} {
+ #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP"
+ if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} {
+ set constructor_failure 1
+ set constructor_errorInfo $::errorInfo ;#cache it immediately.
+ break
+ }
+ }
+ }
+ }
+
+ if {[info exists o_unknown]} {
+ interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown
+ interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown
+
+
+ #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown
+ #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown]
+ #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown]
+ }
+ }
+
+ if {$constructor_failure} {
+ if {$is_new_object} {
+ #is Destroy enough to ensure that no new interfaces or objects were left dangling?
+ $child .. Destroy
+ } else {
+ #object needs to be returned to a sensible state..
+ #attempt to rollback all interface additions and object state changes!
+ puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n"
+ #remove variables from the object's namespace - which don't exist in the snapshot.
+ set snap_vars [info vars ${ns_snap}::*]
+ puts "ns_snap '$ns_snap' vars'${snap_vars}'"
+ foreach vname [info vars ::p::${child_ID}::*] {
+ set shortname [namespace tail $vname]
+ if {"${ns_snap}::$shortname" ni "$snap_vars"} {
+ #puts "--- >>>>> unsetting $shortname "
+ unset -nocomplain $vname
+ }
+ }
+
+ #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces)
+ #values of vars may also have Changed
+ #todo - consider traces? what is the correct behaviour?
+ # - some application traces may have fired before the constructor error occurred.
+ # Should the rollback now also trigger traces?
+ #probably yes.
+
+ #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value
+ foreach vname $snap_vars {
+ #puts stdout "@@@@@@@@@@@ restoring $vname"
+ #flush stdout
+
+
+ set shortname [namespace tail $vname]
+ set target ::p::${child_ID}::$shortname
+ if {$target in [info vars ::p::${child_ID}::*]} {
+ set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only'
+ } else {
+ set present 0
+ }
+
+ if {[array exists $vname]} {
+ #restore 'array' variable
+ if {!$present} {
+ array set $target [array get $vname]
+ } else {
+ if {[array exists $target]} {
+ #unset superfluous elements
+ foreach key [array names $target] {
+ if {$key ni [array names $vname]} {
+ array unset $target $key
+ }
+ }
+ #.. and write only elements that have changed.
+ foreach key [array names $vname] {
+ if {[set ${target}($key)] ne [set ${vname}($key)]} {
+ set ${target}($key) [set ${vname}($key)]
+ }
+ }
+ } else {
+ #target has been changed to a simple variable - unset it and recreate the array.
+ unset $target
+ array set $target [array get $vname]
+ }
+ }
+ } elseif {[info exists $vname]} {
+ #restore 'simple' variable
+ if {!$present} {
+ set $target [set $vname]
+ } else {
+ if {[array exists $target]} {
+ #target has been changed to array - unset it and recreate the simple variable.
+ unset $target
+ set $target [set $vname]
+ } else {
+ if {[set $target] ne [set $vname]} {
+ set $target [set $vname]
+ }
+ }
+ }
+ } else {
+ #restore 'declared' variable
+ if {[array exists $target] || [info exists $target]} {
+ unset -nocomplain $target
+ }
+ namespace eval ::p::${child_ID} [list variable $shortname]
+ }
+ }
+ }
+ namespace delete $ns_snap
+ return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error
+ }
+ namespace delete $ns_snap
+
+ }
+
+
+
+ return $child
+}
+
+dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}}
+#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied*
+# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*)
+# Also: Any 'open' interfaces on the parent become closed on clone!
+proc ::p::-1::Clone {_ID_ clone args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set invocants [dict get $_ID_ i]
+ lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd
+
+ set _cmd [string map {::> ::} $cmd]
+ set tail [namespace tail $_cmd]
+
+
+ #obsolete?
+ ##set IFID0 [lindex $map 1 0 end]
+ #set IFID0 [lindex [dict get $MAP interfaces level0] end]
+ ##set IFID1 [lindex $map 1 1 end]
+ #set IFID1 [lindex [dict get $MAP interfaces level1] end]
+
+
+ if {![string match "::*" $clone]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set clone ::$clone
+ } else {
+ set clone ${ns}::$clone
+ }
+ }
+
+
+ set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >]
+ set _clone [string map {::> ::} $clone]
+
+
+ set cTail [namespace tail $_clone]
+
+ set ns [namespace qualifiers $clone]
+ if {$ns eq ""} {
+ set ns "::"
+ }
+
+ namespace eval $ns {}
+
+
+ #if {![llength [info commands $clone]]} {}
+ if {[namespace which $clone] eq ""} {
+ set clonemapdata [::p::internals::new_object $clone]
+ } else {
+ #overlay/mixin case - target/clone already exists
+ #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1]
+ set clonemapdata [$clone --]
+ }
+ set clone_ID [lindex [dict get $clonemapdata invocantdata] 0]
+
+ upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP
+
+
+ #copy patterndata element of MAP straight across
+ dict set CLONEMAP patterndata [dict get $MAP patterndata]
+ set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata]
+ lset CLONE_INVOCANTDATA 2 $parent_defaultmethod
+ dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA
+ lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone
+
+ #update the clone's _ID_
+ interp alias {} $clone_alias {} ;#first we must delete it
+ interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}]
+
+ #! object_command was initially created as the renamed alias - so we have to do it again
+ rename $clone_alias $clone
+ trace add command $clone rename [list $clone .. Rename]
+
+
+
+
+ #obsolete?
+ #upvar ::p::${clone_ID}:: clone_INFO
+ #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone.
+ #upvar ::p::${OID}:: INFO
+
+
+ array set clone_INFO [array get INFO]
+
+ array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby'
+
+
+ #!review!
+ #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} {
+ #puts "***************"
+ #puts "clone"
+ #parray IFINFO
+ #puts "***************"
+ #}
+
+ #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern
+
+
+ #clone's interface maps must be a superset of original's
+ foreach lev {0 1} {
+ #set parent_ifaces [lindex $map 1 $lev]
+ set parent_ifaces [dict get $MAP interfaces level$lev]
+
+ #set existing_ifaces [lindex $CLONEMAP 1 $lev]
+ set existing_ifaces [dict get $CLONEMAP interfaces level$lev]
+
+ set added_ifaces_$lev [list]
+ foreach ifid $parent_ifaces {
+ if {$ifid ni $existing_ifaces} {
+
+ #interface must not remain extensible after cloning.
+ if {[set ::p::${ifid}::_iface::o_open]} {
+ ::p::predator::compile_interface $ifid $_ID_
+ set ::p::${ifid}::_iface::o_open 0
+ }
+
+
+
+ lappend added_ifaces_$lev $ifid
+ #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list.
+ set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone
+ }
+ }
+ set extracted_sub_dict [dict get $CLONEMAP interfaces]
+ dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]]
+ dict set CLONEMAP interfaces $extracted_sub_dict
+ #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]]
+ }
+
+ #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE)
+
+
+ #foreach *added* level0 interface..
+ foreach ifid $added_ifaces_0 {
+ namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown
+
+
+ dict for {prop pdef} $o_properties {
+ #lassign $pdef prop default
+ if {[dict exists $pdef default]} {
+ set varspace [dict get $pdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${clone_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${clone_ID}::$varspace
+ }
+ }
+
+ if {![info exists ${ns}::o_$prop]} {
+ #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset)
+ set ${ns}::o_$prop [dict get $pdef default]
+ }
+ }
+
+ #! May be replaced by method of same name
+ if {[namespace which ::p::${clone_ID}::$prop] eq ""} {
+ interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop
+ }
+ interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop
+ interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop
+ }
+
+ #variables
+ dict for {vname vdef} $o_variables {
+ if {[dict exists $vdef default]} {
+ set varspace [dict get $vdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${clone_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${clone_ID}::$varspace
+ }
+ }
+ if {![info exists ${ns}::$vname]} {
+ set ::p::${clone_ID}::$vname [dict get $vdef default]
+ }
+ }
+ }
+
+
+ #update the clone object's base interface to reflect the new methods.
+ #upvar 0 ::p::${ifid}:: IFACE
+ #set methods [list]
+ #foreach {key mname} [array get IFACE m-1,name,*] {
+ # set method [lindex [split $key ,] end]
+ # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP
+ # lappend methods $method
+ #}
+ #namespace eval ::p::${clone_ID} [list namespace export {*}$methods]
+
+
+ foreach method [dict keys $o_methods] {
+
+ set arglist [dict get $o_methods $method arglist]
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+ #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method
+
+
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #proc calls the method in the interface - which is an interp alias to the head of the implementation chain
+ proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${ifid}::_iface::$method \$_ID_ $argvals
+ }]
+
+ }
+ #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods]
+
+
+ if {[info exists o_unknown]} {
+ #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown
+ interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown
+ interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown
+
+ #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown]
+ #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown]
+
+ }
+
+
+ #2021
+ #Consider >parent with constructor that sets height
+ #.eg >parent .. Constructor height {
+ # set o_height $height
+ #}
+ #>parent .. Create >child 5
+ # - >child has height 5
+ # now when we peform a clone operation - it is the >parent's constructor that will run.
+ # A clone will get default property and var values - but not other variable values unless the constructor sets them.
+ #>child .. Clone >fakesibling 6
+ # - >sibling has height 6
+ # Consider if >child had it's own constructor created with .. Construct prior to the clone operation.
+ # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead.
+ # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining...
+ # when we now do >sibling .. Create >grandchild
+ # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild
+ # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.)
+ # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild
+ #(though other arguments can be manually passed)
+ # #!review - does this make sense? What if we add
+ #
+ #constructor for each interface called after properties initialised.
+ #run each interface's constructor against child object, using the args passed into this clone method.
+ if {[llength [set constructordef [set o_constructor]]]} {
+ #error
+ puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID"
+ ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args
+
+ }
+
+ }
+
+
+ return $clone
+
+}
+
+
+
+interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?)
+dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}}
+proc ::p::-1::Constructor {_ID_ arglist body} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ #lassign [lindex $invocant 0 ] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ #set iid_top [::p::get_new_object_id]
+
+ #the >interface constructor takes a list of IDs for o_usedby
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+
+ #::p::predator::remap $invocant
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces
+
+
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1
+
+ set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_]
+
+ #set varspaces [::pattern::varspace_list]
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls]
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t runtime_vardecls in Constructor $varDecls"
+ }
+
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #puts stderr ----
+ #puts stderr $body
+ #puts stderr ----
+
+ proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body
+ interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid
+
+
+
+ set o_constructor [list $arglist $body]
+ set o_open 1
+
+ return
+}
+
+
+
+dict set ::p::-1::_iface::o_methods UsedBy {arglist {}}
+proc ::p::-1::UsedBy {_ID_} {
+ return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby]
+}
+
+
+dict set ::p::-1::_iface::o_methods Ready {arglist {}}
+proc ::p::-1::Ready {_ID_} {
+ return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}]
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}}
+
+#'force' 1 indicates object command & variable will also be removed.
+#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var.
+#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4)
+#
+proc ::p::-1::Destroy {_ID_ {force 1}} {
+ #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]"
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+
+ if {$OID eq "null"} {
+ puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_"
+ return
+ }
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+
+ #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout
+
+ #explicit Destroy - remove traces
+ #puts ">>TRACES: [trace info variable $cmd]"
+ #foreach tinfo [trace info variable $cmd] {
+ # trace remove variable $cmd {*}$tinfo
+ #}
+ #foreach tinfo [trace info command $cmd] {
+ # trace remove command $cmd {*}$tinfo
+ #}
+
+
+ set _cmd [string map {::> ::} $cmd]
+
+ #set ifaces [lindex $map 1]
+ set iface_stacks [dict get $MAP interfaces level0]
+ #set patterns [lindex $map 2]
+ set pattern_stacks [dict get $MAP interfaces level1]
+
+
+
+ set ifaces $iface_stacks
+
+
+ set patterns $pattern_stacks
+
+
+ #set i 0
+ #foreach iflist $ifaces {
+ # set IFID$i [lindex $iflist 0]
+ # incr i
+ #}
+
+
+ set IFTOP [lindex $ifaces end]
+
+ set DESTRUCTOR ::p::${IFTOP}::___system___destructor
+ #may be a proc, or may be an alias
+ if {[namespace which $DESTRUCTOR] ne ""} {
+ set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}]
+
+ if {[catch {$DESTRUCTOR $temp_ID_} prob]} {
+ #!todo - ensure correct calling order of interfaces referencing the destructor proc
+
+
+ #!todo - emit destructor errors somewhere - logger?
+ #puts stderr "underlying proc already removed??? ---> $prob"
+ #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------"
+ #puts stderr $::errorInfo
+ #puts stderr "---------------------"
+ }
+ }
+
+
+ #remove ourself from each interfaces list of referencers
+ #puts stderr "--- $ifaces"
+
+ foreach var {ifaces patterns} {
+
+ foreach i [set $var] {
+
+ if {[string length $i]} {
+ if {$i == 2} {
+ #skip the >ifinfo interface which doesn't maintain a usedby list anyway.
+ continue
+ }
+
+ if {[catch {
+
+ upvar #0 ::p::${i}::_iface::o_usedby usedby
+
+ array unset usedby i$OID
+
+
+ #puts "\n***>>***"
+ #puts "IFACE: $i usedby: $usedby"
+ #puts "***>>***\n"
+
+ #remove interface if no more referencers
+ if {![array size usedby]} {
+ #puts " **************** DESTROYING unused interface $i *****"
+ #catch {namespace delete ::p::$i}
+
+ #we happen to know where 'interface' object commands are kept:
+
+ ::p::ifaces::>$i .. Destroy
+
+ }
+
+ } errMsg]} {
+ #warning
+ puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg"
+ }
+ }
+
+ }
+
+ }
+
+ set ns ::p::${OID}
+ #puts "-- destroying objects below namespace:'$ns'"
+ ::p::internals::DestroyObjectsBelowNamespace $ns
+ #puts "--.destroyed objects below '$ns'"
+
+
+ #set ns ::p::${OID}::_sub
+ #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace
+ #( ::p::OBJECT::$OID )
+ #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n"
+ #::p::internals::DestroyObjectsBelowNamespace $ns
+
+ #same for _meta objects (e.g Methods,Properties collections)
+ #set ns ::p::${OID}::_meta
+ #::p::internals::DestroyObjectsBelowNamespace $ns
+
+
+
+ #foreach obj [info commands ${ns}::>*] {
+ # #Assume it's one of ours, and ask it to die.
+ # catch {::p::meta::Destroy $obj}
+ # #catch {$cmd .. Destroy}
+ #}
+ #just in case the user created subnamespaces.. kill objects there too.
+ #foreach sub [namespace children $ns] {
+ # ::p::internals::DestroyObjectsBelowNamespace $sub
+ #}
+
+
+ #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value!
+ #use info commands ::p::${OID}::_ref::* to find all references - including variables never set
+ #remove variable traces on REF vars
+ #foreach rv [info vars ::p::${OID}::_ref::*] {
+ # foreach tinfo [trace info variable $rv] {
+ # #puts "-->removing traces on $rv: $tinfo"
+ # trace remove variable $rv {*}$tinfo
+ # }
+ #}
+
+ #!todo - write tests
+ #refs create aliases and variables at the same place
+ #- but variable may not exist if it was never set e.g if it was only used with info exists
+ foreach rv [info commands ::p::${OID}::_ref::*] {
+ foreach tinfo [trace info variable $rv] {
+ #puts "-->removing traces on $rv: $tinfo"
+ trace remove variable $rv {*}$tinfo
+ }
+ }
+
+
+
+
+
+
+
+ #if {[catch {namespace delete $nsMeta} msg]} {
+ # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg "
+ #} else {
+ # #puts stderr "------ -- -- -- -- deleted $nsMeta "
+ #}
+
+
+ #!todo - remove
+ #temp
+ #catch {interp alias "" ::>$OID ""}
+
+ if {$force} {
+ #rename $cmd {}
+
+ #removing the alias will remove the command - even if it's been renamed
+ interp alias {} $alias {}
+
+ #if {[catch {rename $_cmd {} } why]} {
+ # #!todo - work out why some objects don't have matching command.
+ # #puts stderr "\t rename $_cmd {} failed"
+ #} else {
+ # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!"
+ #}
+
+ }
+
+ set refns ::p::${OID}::_ref
+ #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns"
+ #puts "- children: [llength [namespace children $refns]]"
+ #puts "- vars : [llength [info vars ${refns}::*]]"
+ #puts "- commands: [llength [info commands ${refns}::*]]"
+ #puts "- procs : [llength [info procs ${refns}::*]]"
+ #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]"
+ #puts "- matching command: [llength [info commands ${refns}]]"
+ #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns"
+
+
+ #foreach v [info vars ${refns}::*] {
+ # unset $v
+ #}
+ #foreach p [info procs ${refns}::*] {
+ # rename $p {}
+ #}
+ #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] {
+ # interp alias {} $a {}
+ #}
+
+
+ #set ts1 [clock seconds]
+ #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns."
+ #puts "- children: [llength [namespace children $refns]]"
+ #puts "- vars : [llength [info vars ${refns}::*]]"
+
+ #puts "- commands: [llength [info commands ${refns}::*]]"
+ #puts "- procs : [llength [info procs ${refns}::*]]"
+ #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]"
+ #puts "- exact command: [info commands ${refns}]"
+
+
+
+
+ #puts "--delete ::p::${OID}::_ref"
+ if {[namespace exists ::p::${OID}::_ref]} {
+ #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted.
+ namespace delete ::p::${OID}::_ref::
+ }
+ set ts2 [clock seconds]
+ #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]"
+
+
+ #delete namespace where instance variables reside
+ #catch {namespace delete ::p::$OID}
+ namespace delete ::p::$OID
+
+ #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout
+ return
+}
+
+
+interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility
+
+
+dict set ::p::-1::_iface::o_methods Destructor {arglist {args}}
+#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction?
+#install a Destructor on the invocant's open level1 interface.
+proc ::p::-1::Destructor {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ #lassign [lindex $map 0] OID alias itemCmd cmd
+
+ set patterns [dict get $MAP interfaces level1]
+
+ if {[llength $args] > 2} {
+ error "too many arguments to 'Destructor' - expected at most 2 (arglist body)"
+ }
+
+ set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface.
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ error "NOT TESTED"
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+
+ #::p::predator::remap $invocant
+ }
+
+
+ set ::p::${IID}::_iface::o_destructor_body [lindex $args end]
+
+ if {[llength $args] > 1} {
+ #!todo - allow destructor args(?)
+ set arglist [lindex $args 0]
+ } else {
+ set arglist [list]
+ }
+
+ set ::p::${IID}::_iface::o_destructor_args $arglist
+
+ return
+}
+
+
+
+
+
+interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit)
+
+
+dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}}
+proc ::p::-1::PatternMethod {_ID_ method arglist body} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - get 'open' interface.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+
+ namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces
+
+
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID $method]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME $method.$headid ;#first version will be $method.1
+
+ set next [::p::predator::next_script $IID $method $THISNAME $_ID_]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls"
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls"
+ }
+
+
+ set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist]
+
+ #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n]
+ #puts "\t\t--------------------"
+ #puts "\n"
+ #puts $body
+ #puts "\n"
+ #puts "\t\t--------------------"
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body
+
+
+
+ #pointer from method-name to head of the interface's command-chain
+ interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME
+
+
+
+ if {$method in [dict keys $o_methods]} {
+ #error "patternmethod '$method' already present in interface $IID"
+ set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)"
+ if {[string match "*@next@*" $body]} {
+ append msg "\n EXTRA-WARNING: method contains @next@"
+ }
+
+ puts stdout $msg
+ } else {
+ dict set o_methods $method [list arglist $arglist]
+ }
+
+ #::p::-1::update_invocant_aliases $_ID_
+ return
+}
+
+#MultiMethod
+#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants
+# e.g1 $obj .. MultiMethod add {these 2} $arglist $body
+# e.g2 $obj .. MultiMethod add {these n} $arglist $body
+#
+# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body
+#
+# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature.
+# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature)
+# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces)
+# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter?
+# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed?
+# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code?
+# (and how would we define the call order? - presumably as it appears in the conglomerate)
+# (or could that be done with a more general method-wrapping mechanism?)
+#...should multimethods use some sort of event mechanism, and/or message-passing system?
+#
+dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}}
+proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} {
+ set invocants [dict get $_ID_ i]
+
+ error "not implemented"
+}
+
+dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}}
+# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- )
+#we can create a method named "." by using the argprotect operator --
+# e.g >x .. Method -- . {args} $body
+#It can then be called like so: >x . .
+#This is not guaranteed to work and is not in the test suite
+#for now we'll just use a highly unlikely string to indicate no argument was supplied
+proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } {
+ set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped
+ if {$methodname eq $non_argument_magicstring} {
+ return $default_method
+ } else {
+ set extracted_value [dict get $MAP invocantdata]
+ lset extracted_value 2 $methodname
+ dict set MAP invocantdata $extracted_value ;#write modified value back
+ #update the object's command alias to match
+ interp alias {} $alias {} ;#first we must delete it
+ interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}]
+
+ #! $object_command was initially created as the renamed alias - so we have to do it again
+ rename $alias $object_command
+ trace add command $object_command rename [list $object_command .. Rename]
+ return $methodname
+ }
+}
+
+dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}}
+proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } {
+ set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set extracted_patterndata [dict get $MAP patterndata]
+ set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod]
+ if {$methodname eq $non_argument_magicstring} {
+ return $pattern_default_method
+ } else {
+ dict set extracted_patterndata patterndefaultmethod $methodname
+ dict set MAP patterndata $extracted_patterndata
+ return $methodname
+ }
+}
+
+
+dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}}
+proc ::p::-1::Method {_ID_ method arglist bodydef args} {
+ set invocants [dict get $_ID_ i]
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+ set invocant_signature [list] ;
+ ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway.
+ foreach role [lsort [dict keys $invocants]] {
+ lappend invocant_signature $role [llength [dict get $invocants $role]]
+ }
+ #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this')
+
+
+
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command
+ set interfaces [dict get $MAP interfaces level0]
+
+
+
+ #################################################################################
+ if 0 {
+ set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface
+ set prev_open [set ::p::${iid_top}::_iface::o_open]
+
+ set iface ::p::ifaces::>$iid_top
+
+ set f_new 0
+ if {![string length $iid_top]} {
+ set f_new 1
+ } else {
+ if {[$iface . isClosed]} {
+ set f_new 1
+ }
+ }
+ if {$f_new} {
+ #create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+
+ }
+ set IID $iid_top
+
+ }
+ #################################################################################
+
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+
+ #upvar 0 ::p::${IID}:: IFACE
+
+ namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces
+
+
+ #Interface proc
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID $method]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME $method.$headid ;#first version will be $method.1
+
+ if {$method ni [dict keys $o_methods]} {
+ dict set o_methods $method [list arglist $arglist]
+ }
+
+ #next_script will call to lower interface in iStack if we are $method.1
+ set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_
+ #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<"
+
+
+ #implement
+ #-----------------------------------
+ set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ set varDecls ""
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls\n[dict get $processed body]
+ }
+
+
+ set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist]
+
+
+
+
+
+
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #if {[string length $varDecls]} {
+ # puts stdout "\t---------------------------------------------------------------"
+ # puts stdout "\t----- efficiency warning - implicit var declarations used -----"
+ # puts stdout "\t-------- $object_command .. Method $method $arglist ---------"
+ # puts stdout "\t[string map [list \n \t\t\n] $body]"
+ # puts stdout "\t--------------------------"
+ #}
+ #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role
+ # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position.
+ #(as specified by the @ operator during object conglomeration)
+ #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n]
+
+ #puts stdout "\t\t----------------------------"
+ #puts stdout "$body"
+ #puts stdout "\t\t----------------------------"
+
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body
+
+ #-----------------------------------
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME
+
+
+ #point to the interface command only. The dispatcher will supply the invocant data
+ #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain
+
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${IID}::_iface::$method \$_ID_ $argvals
+ }]
+
+
+ if 0 {
+ if {[llength $argvals]} {
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] {
+ apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@
+ }]
+ } else {
+
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] {
+ apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@
+ }]
+
+ }
+ }
+
+
+ #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst {
+ # ::p::${IID}::_iface::$method \$_ID_ $argvals
+ #}]
+
+ #todo - for o_varspaces
+ #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method
+ #- this should work correctly with the 'uplevel 1' procs in the interfaces
+
+
+ if {[string length $o_varspace]} {
+ if {[string match "::*" $o_varspace]} {
+ namespace eval $o_varspace {}
+ } else {
+ namespace eval ::p::${OID}::$o_varspace {}
+ }
+ }
+
+
+ #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed.
+ set colMethods ::p::${OID}::_meta::>colMethods
+
+ if {[namespace which $colMethods] ne ""} {
+ if {![$colMethods . hasKey $method]} {
+ $colMethods . add [::p::internals::predator $_ID_ . $method .] $method
+ }
+ }
+
+ #::p::-1::update_invocant_aliases $_ID_
+ return
+ #::>pattern .. Create [::>pattern .. Namespace]::>method_???
+ #return $method_object
+}
+
+
+dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}}
+proc ::p::-1::V {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+
+
+ set vlist [list]
+ foreach IID $ifaces {
+ dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] {
+ if {[string match $glob $vname]} {
+ lappend vlist $vname
+ }
+ }
+ }
+
+
+ return $vlist
+}
+
+#experiment from http://wiki.tcl.tk/4884
+proc p::predator::pipeline {args} {
+ set lambda {return -level 0}
+ foreach arg $args {
+ set lambda [list apply [dict get {
+ toupper {{lambda input} {string toupper [{*}$lambda $input]}}
+ tolower {{lambda input} {string tolower [{*}$lambda $input]}}
+ totitle {{lambda input} {string totitle [{*}$lambda $input]}}
+ prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}}
+ suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}}
+ } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]]
+ }
+ return $lambda
+}
+
+proc ::p::predator::get_apply_arg_0_oid {} {
+ set apply_args [lrange [info level 0] 2 end]
+ puts stderr ">>>>> apply_args:'$apply_args'<<<<"
+ set invocant [lindex $apply_args 0]
+ return [lindex [dict get $invocant i this] 0 0]
+}
+proc ::p::predator::get_oid {} {
+ #puts stderr "---->> [info level 1] <<-----"
+ set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2
+ tailcall lindex [dict get $_ID_ i this] 0 0
+}
+
+#todo - make sure this is called for all script installations - e.g propertyread etc etc
+#Add tests to check code runs in correct namespace
+#review - how does 'Varspace' command affect this?
+proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} {
+ #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues)
+ set arglist_apply ""
+ append arglist_apply "\$_ID_ "
+ foreach a $arglist {
+ if {$a eq "args"} {
+ append arglist_apply "{*}\$args"
+ } else {
+ append arglist_apply "\$[lindex $a 0] "
+ }
+ }
+ #!todo - allow fully qualified varspaces
+ if {[string length $varspace]} {
+ if {[string match ::* $varspace]} {
+ return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply"
+ } else {
+ #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n"
+ return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply"
+ }
+ } else {
+ #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n"
+ #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]"
+
+ set script "tailcall apply \[list \{_ID_"
+
+ if {[llength $arglist]} {
+ append script " $arglist"
+ }
+ append script "\} \{"
+ append script $body
+ append script "\} ::p::@OID@\] "
+ append script $arglist_apply
+ #puts stderr "\n88888888888888888888888888\n\t$script\n"
+ #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply"
+ #return $script
+
+
+ #-----------------------------------------------------------------------------
+ # 2018 candidates
+ #
+ #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled
+ #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled
+
+
+ #this has problems with @next@ arguments! (also script variables will possibly interfere with each other)
+ #faster though.
+ #return "uplevel 1 \{$body\}"
+ return "uplevel 1 [list $body]"
+ #-----------------------------------------------------------------------------
+
+
+
+
+ #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply"
+ #return "uplevel 1 \{$script\}"
+
+ #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail
+ #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail
+
+
+
+ #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong
+
+ #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns
+
+
+ #experiment with different dispatch mechanism (interp alias with 'namespace inscope')
+ #-----------
+ #return "apply { {_ID_ $arglist} {$body}} $arglist_apply"
+
+
+ #return "uplevel 1 \{$body\}" ;#do nothing
+
+ #----------
+
+ #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??)
+
+ #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body
+
+ #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker
+
+ #return "tailcall "
+
+
+ }
+}
+
+
+#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies.
+#expand 'var' statements inline in method bodies
+#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements.
+#
+#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces
+#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches!
+# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements.
+#Think of var & varspace statments as a form of compile-time 'macro'
+#
+#caters for 2-element lists as arguments to var statement to allow 'aliasing'
+#e.g var o_thing {o_data mydata}
+# this will upvar o_thing as o_thing & o_data as mydata
+#
+proc ::p::predator::expand_var_statements {rawbody {varspace ""}} {
+ set body {}
+
+ #keep count of any explicit var statments per varspace in 'numDeclared' array
+ # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements.
+
+ #default varspace is ""
+ #varspace should only have leading :: if it is an absolute namespace path.
+
+
+ foreach ln [split $rawbody \n] {
+ set trimline [string trim $ln]
+
+ if {$trimline eq "var"} {
+ #plain var statement alone indicates we don't have any explicit declarations in this branch
+ # and we don't want implicit declarations for the current varspace either.
+ #!todo - implement test
+
+ incr numDeclared($varspace)
+
+ #may be further var statements e.g - in other code branches
+ #return [list body $rawbody varspaces_with_explicit_vars 1]
+ } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} {
+
+ #append body " upvar #0 "
+ #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} "
+ #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} "
+
+ if {$varspace eq ""} {
+ append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] "
+ } else {
+ if {[string match "::*" $varspace]} {
+ append body " namespace upvar $varspace "
+ } else {
+ append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} "
+ }
+ }
+
+ #any whitespace before or betw var names doesn't matter - about to use as list.
+ foreach varspec [string range $trimline 4 end] {
+ lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element.
+ ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias "
+ #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias "
+
+ append body "$var $alias "
+
+ }
+ append body \n
+
+ incr numDeclared($varspace)
+ } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} {
+ #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ???
+ #it is assumed there is a single word following the 'varspace' keyword.
+ set varspace [string trim [string range $trimline 9 end]]
+
+ if {$varspace in [list {{}} {""}]} {
+ set varspace ""
+ }
+ if {[string length $varspace]} {
+ #set varspace ::${varspace}::
+ #no need to initialize numDeclared($varspace) incr will work anyway.
+ #if {![info exists numDeclared($varspace)]} {
+ # set numDeclared($varspace) 0
+ #}
+
+ if {[string match "::*" $varspace]} {
+ append body "namespace eval $varspace {} \n"
+ } else {
+ append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n"
+ }
+
+ #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} "
+ #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n"
+ #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n"
+
+ #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n"
+ }
+ #!review - why? why do we need the magic 'default' name instead of just using the empty string?
+ #if varspace argument was empty string - leave it alone
+ } else {
+ append body $ln\n
+ }
+ }
+
+
+
+ set varspaces [array names numDeclared]
+ return [list body $body varspaces_with_explicit_vars $varspaces]
+}
+
+
+
+
+#Interface Variables
+dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}}
+proc ::p::-1::IV {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+
+ #!todo - test
+ #return [dict keys ::p::${OID}::_iface::o_variables $glob]
+
+ set members [list]
+ foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] {
+ if {[string match $glob $vname]} {
+ lappend members $vname
+ }
+ }
+ return $members
+}
+
+
+dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}}
+proc ::p::-1::Methods {_ID_ {idx ""}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set col ::p::${OID}::_meta::>colMethods
+
+ if {[namespace which $col] eq ""} {
+ patternlib::>collection .. Create $col
+ foreach IID $ifaces {
+ foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] {
+ if {![$col . hasIndex $m]} {
+ #todo - create some sort of lazy-evaluating method object?
+ #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist]
+ $col . add [::p::internals::predator $_ID_ . $m .] $m
+ }
+ }
+ }
+ }
+
+ if {[string length $idx]} {
+ return [$col . item $idx]
+ } else {
+ return $col
+ }
+}
+
+dict set ::p::-1::_iface::o_methods M {arglist {}}
+proc ::p::-1::M {_ID_} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set members [list]
+ foreach IID $ifaces {
+ foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] {
+ lappend members $m
+ }
+ }
+ return $members
+}
+
+
+#review
+#Interface Methods
+dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}}
+proc ::p::-1::IM {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ return [dict keys [set ::p::${OID}::_iface::o_methods] $glob]
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}}
+proc ::p::-1::InterfaceStacks {_ID_} {
+ upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP
+ return [dict get $MAP interfaces level0]
+}
+
+
+dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}}
+proc ::p::-1::PatternStacks {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ return [dict get $MAP interfaces level1]
+}
+
+
+#!todo fix. need to account for references which were never set to a value
+dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}}
+proc ::p::-1::DeletePropertyReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ set cleared_references [list]
+ set refvars [info vars ::p::${OID}::_ref::*]
+ #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st.
+ foreach rv $refvars {
+ foreach tinfo [trace info variable $rv] {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ trace remove variable $rv $ops $cmd
+ }
+ unset $rv
+ lappend cleared_references $rv
+ }
+
+
+ return [list deleted_property_references $cleared_references]
+}
+
+dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}}
+proc ::p::-1::DeleteMethodReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ set cleared_references [list]
+
+ set iflist [dict get $MAP interfaces level0]
+ set iflist_reverse [lreferse $iflist]
+ #set iflist [dict get $MAP interfaces level0]
+
+
+ set refcommands [info commands ::p::${OID}::_ref::*]
+ foreach c $refcommands {
+ set reftail [namespace tail $c]
+ set field [lindex [split $c +] 0]
+ set field_is_a_method 0
+ foreach IFID $iflist_reverse {
+ if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} {
+ set field_is_a_method 1
+ break
+ }
+ }
+ if {$field_is_a_method} {
+ #what if it's also a property?
+ interp alias {} $c {}
+ lappend cleared_references $c
+ }
+ }
+
+
+ return [list deleted_method_references $cleared_references]
+}
+
+
+dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}}
+proc ::p::-1::DeleteReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method this
+
+ set result [dict create]
+ dict set result {*}[$this .. DeletePropertyReferences]
+ dict set result {*}[$this .. DeleteMethodReferences]
+
+ return $result
+}
+
+##
+#Digest
+#
+#!todo - review
+# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!)
+#
+#!todo - write tests - check that digest changes when properties of contained objects change value
+#
+#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method?
+#
+dict set ::p::-1::_iface::o_methods Digest {arglist {args}}
+proc ::p::-1::Digest {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway.
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] _OID alias default_method this
+
+
+ set interface_ids [dict get $MAP interfaces level0]
+ set IFID0 [lindex $interface_ids end]
+
+ set known_flags {-recursive -algorithm -a -indent}
+ set defaults {-recursive 1 -algorithm md5 -indent ""}
+ if {[dict exists $args -a] && ![dict exists $args -algorithm]} {
+ dict set args -algorithm [dict get $args -a]
+ }
+
+ set opts [dict merge $defaults $args]
+ foreach key [dict keys $opts] {
+ if {$key ni $known_flags} {
+ error "unknown option $key. Expected only: $known_flags"
+ }
+ }
+
+
+ set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256}
+ if {[dict get $opts -algorithm] ni $known_algos} {
+ error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos"
+ }
+ set algo [string tolower [dict get $opts -algorithm]]
+
+ # append comma for each var so that all changes in adjacent vars detectable.
+ # i.e set x 34; set y 5
+ # must be distinguishable from:
+ # set x 3; set y 45
+
+ if {[dict get $opts -indent] ne ""} {
+ set state ""
+ set indent "[dict get $opts -indent]"
+ } else {
+ set state "---\n"
+ set indent " "
+ }
+ append state "${indent}object_command: $this\n"
+ set indent "${indent} "
+
+ #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state.
+ append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state.
+
+
+
+
+ #!todo - recurse into 'varspaces'
+ set varspaces_found [list]
+ append state "${indent}interfaces:\n"
+ foreach IID $interface_ids {
+ append state "${indent} - interface: $IID\n"
+ namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces
+ append state "${indent} varspaces:\n"
+ foreach vs $local_o_varspaces {
+ if {$vs ni $varspaces_found} {
+ lappend varspaces_found $vs
+ append state "${indent} - varspace: $vs\n"
+ }
+ }
+ }
+
+ append state "${indent}vars:\n"
+ foreach var [info vars ::p::${OID}::*] {
+ append state "${indent} - [namespace tail $var] : \""
+ if {[catch {append state "[set $var]"}]} {
+ append state "[array get $var]"
+ }
+ append state "\"\n"
+ }
+
+ if {[dict get $opts -recursive]} {
+ append state "${indent}sub-objects:\n"
+ set subargs $args
+ dict set subargs -indent "$indent "
+ foreach obj [info commands ::p::${OID}::>*] {
+ append state "[$obj .. Digest {*}$subargs]\n"
+ }
+
+ append state "${indent}sub-namespaces:\n"
+ set subargs $args
+ dict set subargs -indent "$indent "
+ foreach ns [namespace children ::p::${OID}] {
+ append state "${indent} - namespace: $ns\n"
+ foreach obj [info commands ${ns}::>*] {
+ append state "[$obj .. Digest {*}$subargs]\n"
+ }
+ }
+ }
+
+
+ if {$algo in {"" raw none}} {
+ return $state
+ } else {
+ if {$algo eq "md5"} {
+ package require md5
+ return [::md5::md5 -hex $state]
+ } elseif {$algo eq "sha256"} {
+ package require sha256
+ return [::sha2::sha256 -hex $state]
+ } elseif {$algo eq "blowfish"} {
+ package require patterncipher
+ patterncipher::>blowfish .. Create >b1
+ set [>b1 . key .] 12341234
+ >b1 . encrypt $state -final 1
+ set result [>b1 . ciphertext]
+ >b1 .. Destroy
+
+ } elseif {$algo eq "blowfish-binary"} {
+
+ } else {
+ error "can't get here"
+ }
+
+ }
+}
+
+
+dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}}
+proc ::p::-1::Variable {_ID_ varname args} {
+ set invocants [dict get $_ID_ i]
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ #this interface itself is always a co-invocant
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set interfaces [dict get $MAP interfaces level0]
+
+ #set existing_IID [lindex $map 1 0 end]
+ set existing_IID [lindex $interfaces end]
+
+ set prev_openstate [set ::p::${existing_IID}::_iface::o_open]
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #IID changed
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+
+ #update original object command
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set ::p::${IID}::_iface::o_open $prev_openstate
+ }
+
+ set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface)
+
+ if {[llength $args]} {
+ #!assume var not already present on interface - it is an error to define twice (?)
+ #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]]
+ dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace]
+
+
+ #Implement if there is a default
+ #!todo - correct behaviour when overlaying on existing object with existing var of this name?
+ #if {[string length $varspace]} {
+ # set ::p::${OID}::${varspace}::$varname [lindex $args 0]
+ #} else {
+ set ::p::${OID}::$varname [lindex $args 0]
+ #}
+ } else {
+ #lappend ::p::${IID}::_iface::o_variables [list $varname]
+ dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace]
+ }
+
+ #varspace '_iface'
+
+ return
+}
+
+
+#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility
+
+dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}}
+proc ::p::-1::PatternVariable {_ID_ varname args} {
+ set invocants [dict get $_ID_ i]
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ ##this interface itself is always a co-invocant
+ #lassign [lindex $invocant 0 ] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - get 'open' interface.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+ }
+ set IID $iid_top
+
+ set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified.
+
+
+ if {[llength $args]} {
+ #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]]
+ dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace]
+ } else {
+ dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace]
+ }
+
+ return
+}
+
+dict set ::p::-1::_iface::o_methods Varspaces {arglist args}
+proc ::p::-1::Varspaces {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ if {![llength $args]} {
+ #query
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ set iface ::p::ifaces::>$iid_top
+ if {![string length $iid_top]} {
+ error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] "
+ } elseif {[$iface . isClosed]} {
+ error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] "
+ }
+ return [set ::p::${iid_top}::_iface::o_varspaces]
+ }
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+
+ set varspaces $args
+ foreach vs $varspaces {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ if {[string match ::* $vs} {
+ namespace eval $vs {}
+ } else {
+ namespace eval ::p::${OID}::$vs {}
+ }
+ lappend o_varspaces $vs
+ }
+ }
+ return $o_varspaces
+}
+
+#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface
+dict set ::p::-1::_iface::o_methods Varspace {arglist args}
+# set the default varspace for the interface, so that new methods/properties refer to it.
+# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces.
+proc ::p::-1::Varspace {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ if {![llength $args]} {
+ #query
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ set iface ::p::ifaces::>$iid_top
+ if {![string length $iid_top]} {
+ error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] "
+ } elseif {[$iface . isClosed]} {
+ error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] "
+ }
+ return [set ::p::${iid_top}::_iface::o_varspace]
+ }
+ set varspace [lindex $args 0]
+
+ #set interfaces [dict get $MAP interfaces level0]
+ #set iid_top [lindex $interfaces end]
+
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+
+
+ #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+
+ if {[string length $varspace]} {
+ #ensure namespace exists !? do after list test?
+ if {[string match ::* $varspace]} {
+ namespace eval $varspace {}
+ } else {
+ namespace eval ::p::${OID}::$varspace {}
+ }
+ if {$varspace ni $o_varspaces} {
+ lappend o_varspaces $varspace
+ }
+ }
+ set o_varspace $varspace
+}
+
+
+proc ::p::predator::get_possibly_new_open_interface {OID} {
+ #we need to re-upvar MAP rather than using a parameter - as we need to write back to it
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+
+
+ set iface ::p::ifaces::>$iid_top
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ #puts stderr ">>>>creating new interface $iid_top"
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+
+ return $iid_top
+}
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}}
+# set the default varspace for the interface, so that new methods/properties refer to it.
+# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces.
+proc ::p::-1::PatternVarspace {_ID_ varspace args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end]
+
+ set iface ::p::ifaces::>$iid_top
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+ if {[string length $varspace]} {
+ if {$varspace ni $o_varspaces} {
+ lappend o_varspaces $varspace
+ }
+ }
+ #o_varspace is the currently active varspace
+ set o_varspace $varspace
+
+}
+###################################################################################################################################################
+
+#get varspace and default from highest interface - return all interface ids which define it
+dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}}
+proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0]
+
+ array set propinfo {}
+ set found_property_names [list]
+ #start at the lowest and work up (normal storage order of $interfaces)
+ foreach iid $interfaces {
+ set propinfodict [set ::p::${iid}::_iface::o_properties]
+ set matching_propnames [dict keys $propinfodict $propnamepattern]
+ foreach propname $matching_propnames {
+ if {$propname ni $found_property_names} {
+ lappend found_property_names $propname
+ }
+ lappend propinfo($propname,interfaces) $iid
+ ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one
+ if {[dict exists $propinfodict $propname default]} {
+ set propinfo($propname,default) [dict get $propinfodict $propname default]
+ }
+ set propinfo($propname,varspace) [dict get $propinfodict $propname varspace]
+ }
+ }
+
+ set resultdict [dict create]
+ foreach propname $found_property_names {
+ set fields [list varspace $propinfo($propname,varspace)]
+ if {[array exists propinfo($propname,default)]} {
+ lappend fields default [set propinfo($propname,default)]
+ }
+ lappend fields interfaces $propinfo($propname,interfaces)
+ dict set resultdict $propname $fields
+ }
+ return $resultdict
+}
+
+
+dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args}
+proc ::p::-1::GetTopPattern {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level1]
+ set iid_top [lindex $interfaces end]
+ if {![string length $iid_top]} {
+ lassign [dict get $MAP invocantdata] OID _alias _default_method object_command
+ error "No installed level1 interfaces (patterns) for object $object_command"
+ }
+ return ::p::ifaces::>$iid_top
+}
+
+
+
+dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args}
+proc ::p::-1::GetTopInterface {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ if {![string length $iid_top]} {
+ lassign [dict get $MAP invocantdata] OID _alias _default_method object_command
+ error "No installed level0 interfaces for object $object_command"
+ }
+ return ::p::ifaces::>$iid_top
+}
+
+
+dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args}
+proc ::p::-1::GetExpandableInterface {_ID_ args} {
+
+}
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods Property {arglist {property args}}
+proc ::p::-1::Property {_ID_ property args} {
+ #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args"
+ #set invocants [dict get $_ID_ i]
+ #set invocant_roles [dict keys $invocants]
+ if {[llength $args] > 1} {
+ error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)"
+ }
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+
+ set prev_openstate [set ::p::${iid_top}::_iface::o_open]
+
+ set iface ::p::ifaces::>$iid_top
+
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+
+ namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+
+
+ if {$headid == 1} {
+ #implementation
+ #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property
+
+ #if {$o_varspace eq ""} {
+ # set ns ::p::${OID}
+ #} else {
+ # if {[string match "::*" $o_varspace]} {
+ # set ns $o_varspace
+ # } else {
+ # set ns ::p::${OID}::$o_varspace
+ # }
+ #}
+ #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]]
+
+ proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]]
+
+
+ #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property
+ proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]]
+
+
+ #chainhead pointers
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1
+
+
+ }
+
+ if {($property ni [dict keys $o_methods])} {
+ interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+
+
+
+ #installation on object
+
+ #namespace eval ::p::${OID} [list namespace export $property]
+
+
+
+ #obsolete?
+ #if {$property ni [P $_ID_]} {
+ #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces
+ #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant
+ #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant
+ #}
+
+ #link main (GET)/(SET) to this interface
+ interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property
+ interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property
+
+ #Only install property if no method of same name already installed here.
+ #(Method takes precedence over property because property always accessible via 'set' reference)
+ #convenience pointer to chainhead pointer.
+ if {$property ni [M $_ID_]} {
+ interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property
+ } else {
+ #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed
+
+
+ }
+
+
+ set varspace [set ::p::${IID}::_iface::o_varspace]
+
+
+
+ #Install the matching Variable
+ #!todo - which should take preference if Variable also given a default?
+ #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} {
+ # set o_variables [lreplace $o_variables $posn $posn o_$property]
+ #} else {
+ # lappend o_variables [list o_$property]
+ #}
+ dict set o_variables o_$property [list varspace $varspace]
+
+
+
+
+ if {[llength $args]} {
+ #should store default once only!
+ #set IFINFO(v,default,o_$property) $default
+
+ set default [lindex $args end]
+
+ dict set o_properties $property [list default $default varspace $varspace]
+
+ #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} {
+ # set o_properties [lreplace $o_properties $posn $posn [list $property $default]]
+ #} else {
+ # lappend o_properties [list $property $default]
+ #}
+
+ if {$varspace eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${OID}::$o_varspace
+ }
+ }
+
+ set ${ns}::o_$property $default
+ #set ::p::${OID}::o_$property $default
+ } else {
+
+ #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} {
+ # set o_properties [lreplace $o_properties $posn $posn [list $property]]
+ #} else {
+ # lappend o_properties [list $property]
+ #}
+ dict set o_properties $property [list varspace $varspace]
+
+
+ #variable ::p::${OID}::o_$property
+ }
+
+
+
+
+
+ #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed.
+ #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?)
+ #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property}
+
+ set colProperties ::p::${OID}::_meta::>colProperties
+ if {[namespace which $colProperties] ne ""} {
+ if {![$colProperties . hasKey $property]} {
+ $colProperties . add [::p::internals::predator $_ID_ . $property .] $property
+ }
+ }
+
+ return
+}
+###################################################################################################################################################
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility
+dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}}
+proc ::p::-1::PatternProperty {_ID_ property args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end]
+
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+
+
+
+ if {$headid == 1} {
+ #implementation
+ #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property
+ proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]]
+ #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property
+ proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]]
+
+
+ #chainhead pointers
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1
+
+ }
+
+ if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} {
+ interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+
+ set varspace [set ::p::${IID}::_iface::o_varspace]
+
+ #Install the matching Variable
+ #!todo - which should take preference if Variable also given a default?
+ #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} {
+ # set o_variables [lreplace $o_variables $posn $posn o_$property]
+ #} else {
+ # lappend o_variables [list o_$property]
+ #}
+ dict set o_variables o_$property [list varspace $varspace]
+
+ set argc [llength $args]
+
+ if {$argc} {
+ if {$argc == 1} {
+ set default [lindex $args 0]
+ dict set o_properties $property [list default $default varspace $varspace]
+ } else {
+ #if more than one arg - treat as a dict of options.
+ if {[dict exists $args -default]} {
+ set default [dict get $args -default]
+ dict set o_properties $property [list default $default varspace $varspace]
+ } else {
+ #no default value
+ dict set o_properties $property [list varspace $varspace]
+ }
+ }
+ #! only set default for property... not underlying variable.
+ #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]]
+ } else {
+ dict set o_properties $property [list varspace $varspace]
+ }
+ return
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}}
+proc ::p::-1::PatternPropertyRead {_ID_ property args} {
+ set invocants [dict get $_ID_ i]
+
+ set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this'
+ set OID [lindex $this_invocant 0]
+ #set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias defaut_command cmd
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end]
+
+ set idxlist [::list]
+ if {[llength $args] == 1} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args idxlist body
+ } else {
+ error "wrong # args: should be \"property body\" or \"property idxlist body\""
+ }
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ if {$headid == 1} {
+ set headid 2 ;#reserve 1 for the getprop of the underlying property
+ }
+
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+ set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_
+
+
+ #implement
+ #-----------------------------------
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ #implementation
+ if {![llength $idxlist]} {
+ proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body
+ } else {
+ #what are we trying to achieve here? ..
+ proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body
+ }
+
+
+ #-----------------------------------
+
+
+ #adjust chain-head pointer to point to new head.
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid
+
+ return
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}}
+proc ::p::-1::PropertyRead {_ID_ property args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead)
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end]
+
+
+ set idxlist [::list]
+ if {[llength $args] == 1} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args idxlist body
+ } else {
+ error "wrong # args: should be \"property body\" or \"property idxlist body\""
+ }
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd]
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ if {$headid == 1} {
+ set headid 2
+ }
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself)
+
+ set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_]
+
+ #implement
+ #-----------------------------------
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body
+
+ #-----------------------------------
+
+
+
+ #pointer from prop-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid
+
+
+ interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name.
+ if {$property ni [M $_ID_]} {
+ interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}}
+proc ::p::-1::PropertyWrite {_ID_ property argname body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface.
+
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ #pw short for propertywrite
+ #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd]
+ array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property]
+
+
+ set maxversion [::p::predator::method_chainhead $IID (SET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (SET)$property.$headid
+
+ set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_]
+
+ #implement
+ #-----------------------------------
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body
+
+ #-----------------------------------
+
+
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}}
+proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface.
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set existing_ifaces [lindex $map 1 1]
+ set posn [lsearch $existing_ifaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID]
+
+ #set ::p::${IID}::_iface::o_open 0
+ } else {
+ }
+
+ #pw short for propertywrite
+ array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd]
+
+
+
+
+ return
+
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}}
+proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand.
+
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers
+ #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers
+ dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern]
+
+ set maxversion [::p::predator::method_chainhead $IID (UNSET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (UNSET)$property.$headid
+
+ set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #note $arraykeypattern actually contains the name of the argument
+ if {[string trim $arraykeypattern] eq ""} {
+ set arraykeypattern _dontcare_ ;#
+ }
+ proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body
+
+ #-----------------------------------
+
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid
+
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}}
+proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #set ::p::${IID}::_iface::o_open 0
+ }
+
+
+ upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers
+ dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern]
+
+ return
+}
+###################################################################################################################################################
+
+
+
+#lappend ::p::-1::_iface::o_methods Implements
+#!todo - some way to force overriding of any abstract (empty) methods from the source object
+#e.g leave interface open and raise an error when closing it if there are unoverridden methods?
+
+
+
+
+
+#implementation reuse - sugar for >object .. Clone >target
+dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}}
+proc ::p::-1::Extends {_ID_ pattern} {
+ if {!([string range [namespace tail $pattern] 0 0] eq ">")} {
+ error "'Extends' expected a pattern object"
+ }
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd object_command
+
+
+ tailcall $pattern .. Clone $object_command
+
+}
+#implementation reuse - sugar for >pattern .. Create >target
+dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}}
+proc ::p::-1::PatternExtends {_ID_ pattern} {
+ if {!([string range [namespace tail $pattern] 0 0] eq ">")} {
+ error "'PatternExtends' expected a pattern object"
+ }
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd object_command
+
+
+ tailcall $pattern .. Create $object_command
+}
+
+
+dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}}
+proc ::p::-1::Extend {_ID_ {idx ""}} {
+ puts stderr "Extend is DEPRECATED - use Expand instead"
+ tailcall ::p::-1::Expand $_ID_ $idx
+}
+
+#set the topmost interface on the iStack to be 'open'
+dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}}
+proc ::p::-1::Expand {_ID_ {idx ""}} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set iid_top [lindex $interfaces end]
+ set iface ::p::ifaces::>$iid_top
+
+ if {![string length $iid_top]} {
+ #no existing interface - create a new one
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [list $iid_top]
+ dict set MAP interfaces $extracted_sub_dict ;#write new interface into map
+ $iface . open
+ return $iid_top
+ } else {
+ if {[$iface . isOpen]} {
+ #already open..
+ #assume ready to expand.. shared or not!
+ return $iid_top
+ }
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ if {[$iface . refCount] > 1} {
+ if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} {
+ #!warning! not exercised by test suites!
+
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${iid_top}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ #remove existing interface & add
+ set posn [lsearch $interfaces $iid_top]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+
+ set iid_top $IID
+ set iface ::p::ifaces::>$iid_top
+ }
+ }
+ }
+
+ $iface . open
+ return $iid_top
+}
+
+dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}}
+proc ::p::-1::PatternExtend {_ID_ {idx ""}} {
+ puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead"
+ tailcall ::p::-1::PatternExpand $_ID_ $idx
+}
+
+
+
+#set the topmost interface on the pStack to be 'open' if it's not shared
+# if shared - 'copylink' to new interface before opening for extension
+dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}}
+proc ::p::-1::PatternExpand {_ID_ {idx ""}} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ #puts stderr "no tests written for PatternExpand "
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+ set iid_top [lindex $ifaces end]
+ set iface ::p::ifaces::>$iid_top
+
+ if {![string length $iid_top]} {
+ #no existing interface - create a new one
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [list $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [list $iid_top]
+ $iface . open
+ return $iid_top
+ } else {
+ if {[$iface . isOpen]} {
+ #already open..
+ #assume ready to expand.. shared or not!
+ return $iid_top
+ }
+
+ if {[$iface . refCount] > 1} {
+ if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} {
+ #!WARNING! not exercised by test suite!
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${iid_top}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $ifaces $iid_top]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID]
+
+ set iid_top $IID
+ set iface ::p::ifaces::>$iid_top
+ }
+ }
+ }
+
+ $iface . open
+ return $iid_top
+}
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}}
+proc ::p::-1::Properties {_ID_ {idx ""}} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set col ::p::${OID}::_meta::>colProperties
+
+ if {[namespace which $col] eq ""} {
+ patternlib::>collection .. Create $col
+ foreach IID $ifaces {
+ dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] {
+ if {![$col . hasIndex $prop]} {
+ $col . add [::p::internals::predator $_ID_ . $prop .] $prop
+ }
+ }
+ }
+ }
+
+ if {[string length $idx]} {
+ return [$col . item $idx]
+ } else {
+ return $col
+ }
+}
+
+dict set ::p::-1::_iface::o_methods P {arglist {}}
+proc ::p::-1::P {_ID_} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set members [list]
+ foreach IID $interfaces {
+ foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] {
+ lappend members $prop
+ }
+ }
+ return [lsort $members]
+
+}
+#Interface Properties
+dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}}
+proc ::p::-1::IP {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set members [list]
+
+ foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] {
+ if {[string match $glob [lindex $m 0]]} {
+ lappend members [lindex $m 0]
+ }
+ }
+ return $members
+}
+
+
+#used by rename.test - theoretically should be on a separate interface!
+dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}}
+proc ::p::-1::CheckInvocants {_ID_ args} {
+ #check all invocants in the _ID_ are consistent with data stored in their MAP variable
+ set status "ok" ;#default to optimistic assumption
+ set problems [list]
+
+ set invocant_dict [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocant_dict]
+
+ foreach role $invocant_roles {
+ set invocant_list [dict get $invocant_dict $role]
+ foreach aliased_invocantdata $invocant_list {
+ set OID [lindex $aliased_invocantdata 0]
+ set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata]
+ #we use lrange to make sure the lists are in canonical form
+ if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} {
+ set status "not-ok"
+ lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata]
+ }
+ }
+
+ }
+
+
+ set result [dict create]
+ dict set result status $status
+ dict set result problems $problems
+
+ return $result
+}
+
+
+#get or set t
+dict set ::p::-1::_iface::o_methods Namespace {arglist {args}}
+proc ::p::-1::Namespace {_ID_ args} {
+ #set invocants [dict get $_ID_ i]
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID this_info
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set IID [lindex [dict get $MAP interfaces level0] end]
+
+ namespace upvar ::p::${IID}::_iface o_varspace active_varspace
+
+ if {[string length $active_varspace]} {
+ set ns ::p::${OID}::$active_varspace
+ } else {
+ set ns ::p::${OID}
+ }
+
+ #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object?
+ # - should .. Namespace be usable at all from outside the object?
+
+
+ if {[llength $args]} {
+ #special case some of the namespace subcommands.
+
+ #delete
+ if {[string match "d*" [lindex $args 0]]} {
+ error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object."
+ }
+ #upvar,ensemble,which,code,origin,expor,import,forget
+ if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} {
+ return [namespace eval $ns [list namespace {*}$args]]
+ }
+ #current
+ if {[string match "cu*" [lindex $args 0]]} {
+ return $ns
+ }
+
+ #children,eval,exists,inscope,parent,qualifiers,tail
+ return [namespace {*}[linsert $args 1 $ns]]
+ } else {
+ return $ns
+ }
+}
+
+
+
+
+
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}}
+proc ::p::-1::PatternUnknown {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+ #::p::predator::remap $invocant
+ }
+
+ set handlermethod [lindex $args 0]
+
+
+ if {[llength $args]} {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ return
+ } else {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ }
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Unknown {arglist {args}}
+proc ::p::-1::Unknown {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand.
+
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+
+ set handlermethod [lindex $args 0]
+
+ if {[llength $args]} {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ #set ::p::${IID}::(unknown) $handlermethod
+
+
+ #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod
+ interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod
+ interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod
+
+ #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod]
+ #namespace eval ::p::${OID} [list namespace unknown $handlermethod]
+
+ return
+ } else {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ }
+
+}
+
+
+#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []'
+# should also work for non-object results
+dict set ::p::-1::_iface::o_methods As {arglist {varname}}
+proc ::p::-1::As {_ID_ varname} {
+ set invocants [dict get $_ID_ i]
+ #puts stdout "invocants: $invocants"
+ #!todo - handle multiple invocants with other roles, not just 'this'
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ tailcall set $varname $cmd
+ } else {
+ #puts stdout "info level 1 [info level 1]"
+ set role_members [dict get $_ID_ i this]
+ if {[llength $role_members] == 1} {
+ set member [lindex $role_members 0]
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ tailcall set $varname $stackvalue
+ } else {
+ #multiple invocants - return all results as a list
+ set resultlist [list]
+ foreach member $role_members {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ lappend resultlist $stackvalue
+ }
+ tailcall set $varname $resultlist
+ }
+ }
+}
+
+#!todo - AsFileStream ??
+dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}}
+proc ::p::-1::AsFile {_ID_ filename args} {
+ dict set default -force 0
+ dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object
+ set opts [dict merge $default $args]
+ set force [dict get $opts -force]
+ set dumpmethod [dict get $opts -dumpmethod]
+
+
+ if {[file pathtype $filename] eq "relative"} {
+ set filename [pwd]/$filename
+ }
+ set filedir [file dirname $filename]
+ if {![sf::file_writable $filedir]} {
+ error "(method AsFile) ERROR folder $filedir is not writable"
+ }
+ if {[file exists $filename]} {
+ if {!$force} {
+ error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite"
+ }
+ if {![sf::file_writable $filename]} {
+ error "(method AsFile) ERROR file $filename is not writable - check permissions"
+ }
+ }
+ set fd [open $filename w]
+ fconfigure $fd -translation binary
+
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ #tailcall set $varname $cmd
+ set object_data [$cmd {*}$dumpmethod]
+ puts -nonewline $fd $object_data
+ close $fd
+ return [list status 1 bytes [string length $object_data] filename $filename]
+ } else {
+ #puts stdout "info level 1 [info level 1]"
+ set role_members [dict get $_ID_ i this]
+ if {[llength $role_members] == 1} {
+ set member [lindex $role_members 0]
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ puts -nonewline $fd $stackvalue
+ close $fd
+ #tailcall set $varname $stackvalue
+ return [list status 1 bytes [string length $stackvalue] filename $filename]
+ } else {
+ #multiple invocants - return all results as a list
+ set resultlist [list]
+ foreach member $role_members {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ lappend resultlist $stackvalue
+ }
+ puts -nonewline $fd $resultset
+ close $fd
+ return [list status 1 bytes [string length $resultset] filename $filename]
+ #tailcall set $varname $resultlist
+ }
+ }
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Object {arglist {}}
+proc ::p::-1::Object {_ID_} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ set result [string map [list ::> ::] $cmd]
+ if {![catch {info level -1} prev_level]} {
+ set called_by "(called by: $prev_level)"
+ } else {
+ set called_by "(called by: interp?)"
+
+ }
+
+ puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n"
+ puts stdout " (returning $result)"
+
+ return $result
+}
+
+#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname
+dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}}
+proc ::p::-1::MakeAlias {_ID_cmdname } {
+ set OID [::p::obj_get_this_oid $_ID_]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ error "concept probably won't work - try making dispatcher understand trailing '= cmdname' "
+}
+dict set ::p::-1::_iface::o_methods ID {arglist {}}
+proc ::p::-1::ID {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ return $OID
+}
+
+dict set ::p::-1::_iface::o_methods IFINFO {arglist {}}
+proc ::p::-1::IFINFO {_ID_} {
+ puts stderr "--_ID_: $_ID_--"
+ set OID [::p::obj_get_this_oid $_ID_]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ puts stderr "-- MAP: $MAP--"
+
+ set interfaces [dict get $MAP interfaces level0]
+ set IFID [lindex $interfaces 0]
+
+ if {![llength $interfaces]} {
+ puts stderr "No interfaces present at level 0"
+ } else {
+ foreach IFID $interfaces {
+ set iface ::p::ifaces::>$IFID
+ puts stderr "$iface : [$iface --]"
+ puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]"
+ set variables [set ::p::${IFID}::_iface::o_variables]
+ puts stderr "\tvariables: $variables"
+ }
+ }
+
+}
+
+
+
+
+dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}}
+proc ::p::-1::INVOCANTDATA {_ID_} {
+ #same as a call to: >object ..
+ return $_ID_
+}
+
+#obsolete?
+dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}}
+proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} {
+ set updated_ID_ $_ID_
+ array set updated_roles [list]
+
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants]
+ foreach role $invocant_roles {
+
+ set role_members [dict get $invocants $role]
+ foreach member [dict get $invocants $role] {
+ #each member is a 2-element list consisting of the OID and a dictionary
+ #each member is a 5-element list
+ #set OID [lindex $member 0]
+ #set object_dict [lindex $member 1]
+ lassign $member OID alias itemcmd cmd wrapped
+
+ set MAP [set ::p::${OID}::_meta::map]
+ #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {}
+
+ if {[dict get $MAP invocantdata] eq $member}
+ #same - nothing to do
+
+ } else {
+ package require overtype
+ puts stderr "---------------------------------------------------------"
+ puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version"
+ set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]]
+ puts stderr "[overtype::left $col1 {_ID_ map value}]: $member"
+ puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]"
+ puts stderr "---------------------------------------------------------"
+ #take _meta::map version
+ lappend updated_roles($role) [dict get $MAP invocantdata]
+ }
+
+ }
+
+ #overwrite changed roles only
+ foreach role [array names updated_roles] {
+ dict set updated_ID_ i $role [set updated_roles($role)]
+ }
+
+ return $updated_ID_
+}
+
+
+
+dict set ::p::-1::_iface::o_methods INFO {arglist {}}
+proc ::p::-1::INFO {_ID_} {
+ set result ""
+ append result "_ID_: $_ID_\n"
+
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants]
+ append result "invocant roles: $invocant_roles\n"
+ set total_invocants 0
+ foreach key $invocant_roles {
+ incr total_invocants [llength [dict get $invocants $key]]
+ }
+
+ append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n"
+ foreach key $invocant_roles {
+ append result "\t-------------------------------\n"
+ append result "\trole: $key\n"
+ set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants
+ append result "\t Raw data for this role: $role_members\n"
+ append result "\t Number of invocants in this role: [llength $role_members]\n"
+ foreach member $role_members {
+ #set OID [lindex [dict get $invocants $key] 0 0]
+ set OID [lindex $member 0]
+ append result "\t\tOID: $OID\n"
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ append result "\t\tmap:\n"
+ foreach key [dict keys $MAP] {
+ append result "\t\t\t$key\n"
+ append result "\t\t\t\t [dict get $MAP $key]\n"
+ append result "\t\t\t----\n"
+ }
+ lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped
+ append result "\t\tNamespace: $namespace\n"
+ append result "\t\tDefault method: $default_method\n"
+ append result "\t\tCommand: $cmd\n"
+ append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n"
+ append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n"
+ append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n"
+ } else {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ append result "\t\t last item on the predator stack is a value not an object"
+ append result "\t\t Value is: $stackvalue"
+
+ }
+ }
+ append result "\n"
+ append result "\t-------------------------------\n"
+ }
+
+
+
+ return $result
+}
+
+
+
+
+dict set ::p::-1::_iface::o_methods Rename {arglist {args}}
+proc ::p::-1::Rename {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ if {![llength $args]} {
+ error "Rename expected \$newname argument"
+ }
+
+ #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant?
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ #puts ">>.>> Rename. _ID_: $_ID_"
+
+ if {[catch {
+
+ if {([llength $args] == 3) && [lindex $args 2] eq "rename"} {
+
+ #appears to be a 'trace command rename' firing
+ #puts "\t>>>> rename trace fired $MAP $args <<<"
+
+ lassign $args oldcmd newcmd
+ set extracted_invocantdata [dict get $MAP invocantdata]
+ lset extracted_invocantdata 3 $newcmd
+ dict set MAP invocantdata $extracted_invocantdata
+
+
+ lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped
+
+ #Write the same info into the _ID_ value of the alias
+ interp alias {} $alias {} ;#first we must delete it
+ interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}]
+
+
+
+ #! $object_command was initially created as the renamed alias - so we have to do it again
+ uplevel 1 [list rename $alias $object_command]
+ trace add command $object_command rename [list $object_command .. Rename]
+
+ } elseif {[llength $args] == 1} {
+ #let the rename trace fire and we will be called again to do the remap!
+ uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]]
+ } else {
+ error "Rename expected \$newname argument ."
+ }
+
+ } errM]} {
+ puts stderr "\t@@@@@@ rename error"
+ set ruler "\t[string repeat - 80]"
+ puts stderr $ruler
+ puts stderr $errM
+ puts stderr $ruler
+
+ }
+
+ return
+
+
+}
+
+proc ::p::obj_get_invocants {_ID_} {
+ return [dict get $_ID_ i]
+}
+#The invocant role 'this' is special and should always have only one member.
+# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX
+proc ::p::obj_get_this_oid {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 0]
+}
+proc ::p::obj_get_this_ns {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 1]
+}
+
+proc ::p::obj_get_this_cmd {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 3]
+}
+proc ::p::obj_get_this_data {_ID_} {
+ lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd
+ #set this_invocant_data {*}[dict get $_ID_ i this]
+ return [list oid $OID ns $ns cmd $cmd]
+}
+proc ::p::map {OID varname} {
+ tailcall upvar #0 ::p::${OID}::_meta::map $varname
+}
+
+
+
diff --git a/src/bootsupport/modules_tcl8/metaface-1.2.8.tm b/src/bootsupport/modules_tcl8/metaface-1.2.8.tm
new file mode 100644
index 00000000..39a54c8c
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/metaface-1.2.8.tm
@@ -0,0 +1,6447 @@
+package require dictutils
+package provide metaface [namespace eval metaface {
+ variable version
+ set version 1.2.8
+}]
+
+# 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+
+# 2023-07 - add .. MetaMethods
+
+
+#example datastructure:
+#$_ID_
+#{
+#i
+# {
+# this
+# {
+# {16 ::p::16 item ::>x {}}
+# }
+# role2
+# {
+# {17 ::p::17 item ::>y {}}
+# {18 ::p::18 item ::>z {}}
+# }
+# }
+#context {}
+#}
+
+#$MAP
+#invocantdata {16 ::p::16 item ::>x {}}
+#interfaces {level0
+# {
+# api0 {stack {123 999}}
+# api1 {stack {333}}
+# }
+# level0_default api0
+# level1
+# {
+# }
+# level1_default {}
+# }
+#patterndata {patterndefaultmethod {}}
+
+
+namespace eval ::p::predator {}
+#temporary alternative to ::p::internals namespace.
+# - place predator functions here until ready to replace internals.
+
+
+namespace eval ::p::snap {
+ variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks.
+}
+
+
+
+
+# not called directly. Retrieved using 'info body ::p::predator::getprop_template'
+#review - why use a proc instead of storing it as a string?
+proc ::p::predator::getprop_template {_ID_ args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {"%varspace%" eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" "%varspace%"]} {
+ set ns "%varspace%"
+ } else {
+ set ns ::p::${OID}::%varspace%
+ }
+ }
+
+
+ if {[llength $args]} {
+ #lassign [lindex $invocant 0] OID alias itemCmd cmd
+ if {[array exists ${ns}::o_%prop%]} {
+ #return [set ${ns}::o_%prop%($args)]
+ if {[llength $args] == 1} {
+ return [set ::p::${OID}::o_%prop%([lindex $args 0])]
+ } else {
+ return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]]
+ }
+ } else {
+ set val [set ${ns}::o_%prop%]
+
+ set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}]
+ if {$rType eq "object"} {
+ #return [$val . item {*}$args]
+ return [$val {*}$args]
+ } else {
+ #treat as list?
+ return [lindex $val $args]
+ }
+ }
+ } else {
+ return [set ${ns}::o_%prop%]
+ }
+}
+
+
+proc ::p::predator::getprop_template_immediate {_ID_ args} {
+ if {[llength $args]} {
+ if {[array exists %ns%::o_%prop%]} {
+ return [set %ns%::o_%prop%($args)]
+ } else {
+ set val [set %ns%::o_%prop%]
+ set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}]
+ if {$rType eq "object"} {
+ #return [$val . item {*}$args]
+ #don't assume defaultmethod named 'item'!
+ return [$val {*}$args]
+ } else {
+ #treat as list?
+ return [lindex $val $args]
+ }
+ }
+ } else {
+ return [set %ns%::o_%prop%]
+ }
+}
+
+
+
+
+
+
+
+
+proc ::p::predator::getprop_array {_ID_ prop args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+
+ #upvar 0 ::p::${OID}::o_${prop} prop
+ #1st try: assume array
+ if {[catch {array get ::p::${OID}::o_${prop}} result]} {
+ #treat as list (why?)
+ #!review
+ if {[info exists ::p::${OID}::o_${prop}]} {
+ array set temp [::list]
+ set i 0
+ foreach element ::p::${OID}::o_${prop} {
+ set temp($i) $element
+ incr i
+ }
+ set result [array get temp]
+ } else {
+ error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format"
+ }
+ }
+ return $result
+}
+
+proc ::p::predator::setprop_template {prop _ID_ args} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {"%varspace%" eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" "%varspace%"]} {
+ set ns "%varspace%"
+ } else {
+ set ns ::p::${OID}::%varspace%
+ }
+ }
+
+
+ if {[llength $args] == 1} {
+ #return [set ::p::${OID}::o_%prop% [lindex $args 0]]
+ return [set ${ns}::o_%prop% [lindex $args 0]]
+
+ } else {
+ if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} {
+ #treat attempt to perform indexed write to nonexistant var, same as indexed write to array
+
+ #2 args - single index followed by a value
+ if {[llength $args] == 2} {
+ return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]]
+ } else {
+ #multiple indices
+ #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]]
+ return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ]
+ }
+ } else {
+ #treat as list
+ return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]]
+ }
+ }
+}
+
+#--------------------------------------
+#property read & write traces
+#--------------------------------------
+
+
+proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} {
+
+ #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' "
+
+ #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain.
+
+ if {[llength $idx]} {
+ if {[llength $idx] == 1} {
+ set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx]
+ } else {
+ lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx]
+ }
+ return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value
+ } else {
+ if {![info exists $refname]} {
+ set $refname [$get_cmd $_ID_ {*}$indices]
+ } else {
+ set newval [$get_cmd $_ID_ {*}$indices]
+ if {[set $refname] ne $newval} {
+ set $refname $newval
+ }
+ }
+ return
+ }
+}
+
+
+
+
+proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} {
+ #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname
+ #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'"
+
+
+ #derive the name of the write command from the ref var.
+ set indices [lassign [split [namespace tail $refname] +] prop]
+
+
+ #assert - we will never have both a list in indices and an idx value
+ if {[llength $indices] && ($idx ne "")} {
+ #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x
+ #review - are there any datastructures which would/should allow this?
+ #this assertion is really just here as a sanity check for now
+ error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value"
+ }
+
+ #upvar #0 ::p::${OID}::_meta::map MAP
+ #puts "-->propref_trace_write map: $MAP"
+
+ #temporarily deactivate refsync trace
+ #puts stderr -->1>--removing_trace_o_${field}
+### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop]
+
+ #we need to catch, and re-raise any error that we may receive when writing the property
+ # because we have to reinstate the propvar_write_TraceHandler after the call.
+ #(e.g there may be a propertywrite handler that deliberately raises an error)
+
+ set excludesync_refs $refname
+ set cmd ::p::${OID}::(SET)$prop
+
+
+ set f_error 0
+ if {[catch {
+
+ if {![llength $indices]} {
+ if {[string length $idx]} {
+ $cmd $_ID_ $idx [set ${refname}($idx)]
+ #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx]
+
+ } else {
+ $cmd $_ID_ [set $refname]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list]
+ }
+ } else {
+ #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n"
+ $cmd $_ID_ {*}$indices [set $refname]
+ ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices
+ }
+
+ } result]} {
+ set f_error 1
+ }
+
+
+
+
+ #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write
+ #reactivate refsync trace
+ #puts stderr "****** reactivating refsync trace on o_$field"
+ #puts stderr -->2>--reactivating_trace_o_${field}
+ ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop]
+
+
+ if {$f_error} {
+ #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging.
+ # ? return -code error $errMsg ? -errorinfo
+
+ #!quick n dirty
+ #error $errorMsg
+ return -code error -errorinfo $::errorInfo $result
+ } else {
+ return $result
+ }
+}
+
+
+
+
+
+proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} {
+ #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'"
+ #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array')
+
+ set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set
+
+ #set updated_value [::p::predator::getprop_array $prop $_ID_]
+ #puts stderr "-->array_Trace updated_value:$updated_value"
+ if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} {
+ puts stderr "-->propref_trace_array error $errm"
+ array set $refname {}
+ }
+
+ #return value ignored for
+}
+
+
+#--------------------------------------
+#
+proc ::p::predator::object_array_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+
+
+ #don't rely on variable name passed by trace - may have been 'upvar'ed
+ set refvar ::p::${OID}::_ref::__OBJECT
+
+ #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar"
+
+ set iflist [dict get $MAP interfaces level0]
+
+ set plist [list]
+
+ #!todo - get propertylist from cache on object(?)
+ foreach IFID [lreverse $iflist] {
+ dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] {
+ #lassign $pdef v
+ if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} {
+ if {[array exists ::p::${OID}::o_${prop}]} {
+ lappend plist $prop [array get ::p::${OID}::o_${prop}]
+ } else {
+ #ignore - array only represents properties that have been set.
+ #error "property $v is not set"
+ #!todo - unset corresponding items in $refvar if needed?
+ }
+ }
+ }
+ }
+ array set $refvar $plist
+}
+
+
+proc ::p::predator::object_read_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+ #don't rely on variable name passed by trace.
+ set refvar ::p::${OID}::_ref::__OBJECT
+
+ #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n"
+
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+
+ if {[string length $IID]} {
+ #property
+ if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} {
+ puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg"
+ }
+ } else {
+ #method
+ error "property '$idx' not found"
+ }
+}
+
+
+proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+
+ #!todo - ???
+
+ if {![llength [info commands ::p::${OID}::$idx]]} {
+ error "no such method or property: '$idx'"
+ } else {
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set found 0
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set found 1
+ break
+ }
+ }
+
+ if {$found} {
+ unset ::p::${OID}::o_$idx
+ } else {
+ puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx"
+ }
+ }
+}
+
+
+proc ::p::predator::object_write_trace {OID _ID_ vref idx op} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd
+ #don't rely on variable name passed by trace.
+ set refvar ::p::${OID}::_ref::__OBJECT
+ #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar"
+
+
+ if {![llength [info commands ::p::${OID}::$idx]]} {
+ #!todo - create new property in interface upon attempt to write to non-existant?
+ # - or should we require some different kind of object-reference for that?
+ array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx
+ error "no such method or property: '$idx'"
+ } else {
+ #!todo? - build a list of all interface properties (cache it on object??)
+ set iflist [dict get $MAP interfaces level0]
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+
+ #$IID is now topmost interface in default iStack which has this property
+
+ if {[string length $IID]} {
+ #write to defined property
+
+ ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)]
+ } else {
+ #!todo - allow write of method body back to underlying object?
+ #attempted write to 'method' ..undo(?)
+ array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx
+ error "cannot write to method '$idx'"
+ #for now - disallow
+ }
+ }
+
+}
+
+
+
+proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} {
+ #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname
+
+ set refindices [lassign [split [namespace tail $refname] +] prop]
+ #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop
+ #if there is no PropertyUnset command - we unset the underlying variable directly
+
+ trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop]
+
+
+ if {[catch {
+
+ #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value
+ #i.e
+ if {[llength $refindices] && [string length $idx]} {
+ puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'"
+ error "unexpected call to propref_trace_unset"
+ }
+
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set iflist [dict get $MAP interfaces level0]
+ #find topmost interface containing this $prop
+ set IID ""
+ foreach id [lreverse $iflist] {
+ if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} {
+ set IID $id
+ break
+ }
+ }
+ if {![string length $IID]} {
+ error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])"
+ }
+
+
+
+
+
+
+ if {[string length $idx]} {
+ #eval "$_alias ${unset_}$field $idx"
+ #what happens to $refindices???
+
+
+ #!todo varspace
+
+ if {![llength $refindices]} {
+ #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ unset ::p::${OID}::o_${prop}($idx)
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx
+ }
+
+
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx
+ } else {
+ #assert - won't get here
+ error 1a
+
+ }
+
+ } else {
+ if {[llength $refindices]} {
+ #error 2a
+ #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ #review - what about list-type property?
+ #if {[array exists ::p::${OID}::o_${prop}]} ???
+ unset ::p::${OID}::o_${prop}($refindices)
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices
+ }
+
+
+
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices
+
+
+ } else {
+ #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+
+ #ref is not of form prop+x etc and no idx in the trace - this is a plain unset
+ if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} {
+ unset ::p::${OID}::o_${prop}
+ } else {
+ ::p::${IID}::_iface::(UNSET)$prop $_ID_ ""
+ }
+ #manually call refsync, passing it this refvar as an exclusion
+ ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {}
+
+ }
+ }
+
+
+
+
+ } errM]} {
+ #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]"
+ set ruler [string repeat - 80]
+ puts stderr "\t$ruler"
+ puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+ puts stderr "\t$ruler"
+ puts stderr $errM
+ puts stderr "\t$ruler"
+
+ } else {
+ #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'"
+ #puts stderr "*@*@*@*@ end propref_trace_unset - no error"
+ }
+
+ trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop]
+
+
+}
+
+
+
+
+proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} {
+
+ #Do not use 'info exists' (avoid triggering read trace) - use info vars
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ #puts " **> lappending '::p::REF::${OID}::$prop'"
+ lappend refvars ::p::${OID}::_ref::$prop
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*]
+
+
+
+ if {[string length $triggeringRef]} {
+ set idx [lsearch -exact $refvars $triggeringRef]
+ if {$idx >= 0} {
+ set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}]
+ }
+ }
+ if {![llength $refvars]} {
+ #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx"
+ return
+ }
+
+
+ #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset
+ # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b"
+ if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} {
+ #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???"
+ puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'"
+ }
+
+
+ puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' "
+
+
+
+ upvar $vtraced SYNCVARIABLE
+
+
+ #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars
+ array set traces [::list]
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ if {$ops in {read write unset array}} {
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ }
+ }
+ }
+ }
+
+
+
+
+ if {[array exists SYNCVARIABLE]} {
+
+ #underlying variable is an array - we are presumably unsetting just an element
+ set vtracedIsArray 1
+ } else {
+ #!? maybe the var was an array - but it's been unset?
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+ #some things we don't want to repeat for each refvar in case there are lots of them..
+
+ #set triggeringRefIdx $vidx
+
+ if {[string match "${prop}+*" [namespace tail $triggeringRef]]} {
+ set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end]
+ } else {
+ set triggering_indices [list]
+ }
+
+
+
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "--- unset branch refvar:$refvar"
+
+
+
+ if {[llength $vidx]} {
+ #trace called with an index - must be an array
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #!todo - add test
+ if {$vidx eq [lrange [split $reftail +] 1 end]} {
+ #unset if indices match
+ error "untested, possibly unused branch spuds1"
+ #puts "1111111111111111111111111"
+ unset $refvar
+ }
+ } else {
+ #test exists - #!todo - document which one
+
+ #see if we succeeded in unsetting this element in the underlying variables
+ #(may have been blocked by a PropertyUnset body)
+ set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]]
+ #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists"
+ if {$element_exists} {
+ #do nothing it wasn't actually unset
+ } else {
+ #puts "JJJJJ unsetting ${refvar}($vidx)"
+ unset ${refvar}($vidx)
+ }
+ }
+ }
+
+
+
+
+
+ } else {
+
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #check indices of triggering refvar match this refvars indices
+
+
+ if {$reftail eq [namespace tail $triggeringRef]} {
+ #!todo - add test
+ error "untested, possibly unused branch spuds2"
+ #puts "222222222222222222"
+ unset $refvar
+ } else {
+
+ #error "untested - branch spuds2a"
+
+
+ }
+
+ } else {
+ #!todo -add test
+ #reference is directly to property var
+ error "untested, possibly unused branch spuds3"
+ #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string?
+ puts "\t33333333333333333333"
+
+ if {[string length $triggeringRefIdx]} {
+ unset $refvar($triggeringRefIdx)
+ }
+ }
+ }
+
+ }
+
+
+
+
+ #!todo - understand.
+ #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n"
+ #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?)
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing setGet trace '$ops' on variable $rv"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+
+
+
+
+}
+
+
+proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} {
+
+ upvar $vtraced SYNCVARIABLE
+
+ set refvars [::list]
+ #Do not use 'info exists' (avoid triggering read trace) - use info vars
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ lappend refvars ::p::${OID}::_ref::$prop
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*]
+
+
+
+ #short_circuit breaks unset traces for array elements (why?)
+
+
+ if {![llength $refvars]} {
+ #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'"
+ return
+ } else {
+ puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'"
+ }
+
+ if {[catch {
+
+
+
+ #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars
+ array set traces [::list]
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ if {$ops in {read write unset array}} {
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ }
+ }
+ }
+ }
+
+
+
+
+ if {[array exists SYNCVARIABLE]} {
+
+ #underlying variable is an array - we are presumably unsetting just an element
+ set vtracedIsArray 1
+ } else {
+ #!? maybe the var was an array - but it's been unset?
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+ #some things we don't want to repeat for each refvar in case there are lots of them..
+ set triggeringRefIdx $vidx
+
+
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "--- unset branch refvar:$refvar"
+
+
+
+ if {[llength $vidx]} {
+ #trace called with an index - must be an array
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+
+ if {[string match "${prop}+*" $reftail]} {
+ #!todo - add test
+ if {$vidx eq [lrange [split $reftail +] 1 end]} {
+ #unset if indices match
+ error "untested, possibly unused branch spuds1"
+ #puts "1111111111111111111111111"
+ unset $refvar
+ }
+ } else {
+ #test exists - #!todo - document which one
+
+ #see if we succeeded in unsetting this element in the underlying variables
+ #(may have been blocked by a PropertyUnset body)
+ set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]]
+ #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists"
+ if {$element_exists} {
+ #do nothing it wasn't actually unset
+ } else {
+ #puts "JJJJJ unsetting ${refvar}($vidx)"
+ unset ${refvar}($vidx)
+ }
+ }
+ }
+
+
+
+
+
+ } else {
+
+ foreach refvar $refvars {
+ set reftail [namespace tail $refvar]
+ unset $refvar
+
+ }
+
+ }
+
+
+
+
+ #!todo - understand.
+ #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n"
+ #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?)
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing setGet trace '$ops' on variable $rv"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+ } errM]} {
+ set ruler [string repeat * 80]
+ puts stderr "\t$ruler"
+ puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op"
+ puts stderr "\t$ruler"
+ puts stderr $::errorInfo
+ puts stderr "\t$ruler"
+
+ }
+
+}
+
+proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} {
+ error hmmmmm
+ upvar $vtraced SYNCVARIABLE
+ #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' "
+ set refvars [::list]
+
+ #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace )
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ }
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references
+ #assert triggeringRef is in the list
+ if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} {
+ error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars"
+ }
+ set refposn [lsearch -exact $refvars $triggeringRef]
+ #assert - due to test above, we know $triggeringRef is in the list so refposn > 0
+ set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}]
+ if {![llength $refvars]} {
+ #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop"
+ return [list refs_updates [list]]
+ }
+
+ #suppress the propref_trace_* traces on all refvars
+ array set traces [::list]
+ array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ."
+ #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync
+ #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error?
+ #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref)
+
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+
+
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ } else {
+ #all other traces are 'external'
+ lappend external_traces($rv) $tinfo
+ #trace remove variable $rv $ops $cmd
+ }
+
+ }
+ }
+ #--------------------------------------------------------------------------------------------------------------------------
+ if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} {
+ if {![info exists SYNCVARIABLE]} {
+ error "WARNING: REVIEW why does $vartraced not exist here?"
+ }
+ #either the underlying variable is an array
+ # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern
+ set treat_vtraced_as_array 1
+ } else {
+ set treat_vtraced_as_array 0
+ }
+
+ set refs_updated [list]
+ set refs_deleted [list] ;#unset due to index no longer being relevant
+ if {$treat_vtraced_as_array} {
+ foreach refvar $refvars {
+ #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'"
+ set refvar_tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $refvar_tail]} {
+ #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y
+ set ref_indices [lrange [split $refvar_tail +] 1 end]
+ if {[llength $indices]} {
+ if {[llength $indices] == 1} {
+ if {[lindex $ref_indices 0] eq [lindex $indices 0]} {
+ #error "untested xxx-a"
+ set ${refvar} [set SYNCVARIABLE([lindex $indices 0])]
+ lappend refs_updated $refvar
+ } else {
+ #test exists
+ #error "xxx-ok single index"
+ #updating a different part of the property - nothing to do
+ }
+ } else {
+ #nested index
+ if {[lindex $ref_indices 0] eq [lindex $indices 0]} {
+ if {[llength $ref_indices] == 1} {
+ #error "untested xxx-b1"
+ set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ]
+ } else {
+ #assert llength $ref_indices > 1
+ #NOTE - we cannot test index equivalence reliably/simply just by comparing indices
+ #compare by value
+
+ if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} {
+ #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'"
+ if {[set $refvar] ne $possiblyNewVal} {
+ set $refvar $possiblyNewVal
+ }
+ } else {
+ #fail to retrieve underlying value corrsponding to these $indices
+ unset $refvar
+ }
+ }
+ } else {
+ #test exists
+ #error "untested xxx-ok deepindex"
+ #updating a different part of the property - nothing to do
+ }
+ }
+ } else {
+ error "untested xxx-c"
+
+ }
+
+ } else {
+ #refvar to update is plain e.g ::p::${OID}::_ref::${prop}
+ if {[llength $indices]} {
+ if {[llength $indices] == 1} {
+ set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])]
+ } else {
+ lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]]
+ }
+ lappend refs_updated $refvar
+ } else {
+ error "untested yyy"
+ set $refvar $SYNCVARIABLE
+ }
+ }
+ }
+ } else {
+ #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x)
+ #
+ foreach refvar $refvars {
+ #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'"
+ set refvar_tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $refvar_tail]} {
+ #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y
+ set ref_indices [lrange [split $refvar_tail +] 1 end]
+
+ if {[llength $indices]} {
+ #see if this update would affect this curried ref
+ #1st see if we can short-circuit our comparison based on numeric-indices
+ if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} {
+ #both sets of indices are purely numeric (no end end-1 etc)
+ set rlen [llength $ref_indices]
+ set ilen [llength $indices]
+ set minlen [expr {min($rlen,$ilen)}]
+ set matched_firstfew_indices 1 ;#assume the best
+ for {set i 0} {$i < $minlen} {incr i} {
+ if {[lindex $ref_indices $i] ne [lindex $indices $i]} {
+ break ;#
+ }
+ }
+ if {!$matched_firstfew_indices} {
+ #update of this refvar not required
+ #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices"
+ break ;#break to next refvar in the foreach loop
+ }
+ }
+ #failed to short-circuit
+
+ #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here
+ set newval [lindex $SYNCVARIABLE $ref_indices]
+ if {[set $refvar] ne $newval} {
+ set $refvar $newval
+ lappend refs_updated $refvar
+ }
+
+ } else {
+ #we must be updating the entire variable - so this curried ref will either need to be updated or unset
+ set newval [lindex $SYNCVARIABLE $ref_indices]
+ if {[set ${refvar}] ne $newval} {
+ set ${refvar} $newval
+ lappend refs_updated $refvar
+ }
+ }
+ } else {
+ #refvar to update is plain e.g ::p::${OID}::_ref::${prop}
+ if {[llength $indices]} {
+ #error "untested zzz-a"
+ set newval [lindex $SYNCVARIABLE $indices]
+ if {[lindex [set $refvar] $indices] ne $newval} {
+ lset ${refvar} $indices $newval
+ lappend refs_updated $refvar
+ }
+ } else {
+ if {[set ${refvar}] ne $SYNCVARIABLE} {
+ set ${refvar} $SYNCVARIABLE
+ lappend refs_updated $refvar
+ }
+ }
+
+ }
+
+ }
+ }
+ #--------------------------------------------------------------------------------------------------------------------------
+
+ #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names traces] {
+ if {$rv ni $refs_deleted} {
+ foreach tinfo $traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+ }
+ foreach rv [array names external_traces] {
+ if {$rv ni $refs_deleted} {
+ foreach tinfo $external_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #trace add variable $rv $ops $cmd
+ }
+ }
+ }
+
+
+ return [list updated_refs $refs_updated]
+}
+
+#purpose: update all relevant references when context variable changed directly
+proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} {
+ #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way.
+ #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler
+
+ upvar $vtraced SYNCVARIABLE
+ #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op"
+ set t_info [trace info variable $vtraced]
+ foreach t_spec $t_info {
+ set t_ops [lindex $t_spec 0]
+ if {$op in $t_ops} {
+ puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]"
+ }
+ }
+
+ #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*-
+ #vtype = array | array-item | list | simple
+
+ set refvars [::list]
+
+ ############################
+ #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!!
+ #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs)
+ #The alternative 'info vars' does not trigger traces
+ if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} {
+ #puts " **> lappending '::p::REF::${OID}::$prop'"
+ lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ }
+ ############################
+
+ #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .])
+ lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references
+
+
+ if {![llength $refvars]} {
+ #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop"
+ return
+ }
+
+
+ #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]"
+
+ #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars
+ array set predator_traces [::list]
+ #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace..
+ #ie for something like 'trace add variable someref {write read array} somefunc'
+ # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace
+ array set external_read_traces [::list] ;#pure read traces the library user may have added
+ array set external_readetc_traces [::list] ;#read + something else traces the library user may have added
+ foreach rv $refvars {
+ #puts "--refvar $rv"
+ foreach tinfo [trace info variable $rv] {
+ #puts "##trace $tinfo"
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ #!warning - assumes traces with single operation per handler.
+ #write & unset traces on refvars need to be suppressed
+ #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed.
+ #if {$ops in {read write unset array}} {}
+
+ if {[string match "::p::predator::propref_trace_*" $cmd]} {
+ lappend predator_traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd"
+ } else {
+ #other traces
+ # puts "##trace $tinfo"
+ if {"read" in $ops} {
+ if {[llength $ops] == 1} {
+ #pure read -
+ lappend external_read_traces($rv) $tinfo
+ trace remove variable $rv $ops $cmd
+ } else {
+ #mixed operation trace - remove and reinstall without the 'read'
+ lappend external_readetc_traces($rv) $tinfo
+ set other_ops [lsearch -all -inline -not $ops "read"]
+ trace remove variable $rv $ops $cmd
+ #reinstall trace for non-read operations only
+ trace add variable $rv $other_ops $cmd
+ }
+ }
+ }
+ }
+ }
+
+
+ if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} {
+ #either the underlying variable is an array
+ # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern
+ set vtracedIsArray 1
+ } else {
+ set vtracedIsArray 0
+ }
+
+ #puts stderr "--------------------------------------------------\n\n"
+
+ #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars"
+ #puts stderr ">>> [trace info variable $vtraced]"
+ #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op"
+ #puts "**write*********** refvars: $refvars"
+
+ #!todo? unroll foreach into multiple foreaches within ifs?
+ #foreach refvar $refvars {}
+
+
+ #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar"
+ if {[string length $vidx]} {
+ #indexable
+ if {$vtracedIsArray} {
+
+ foreach refvar $refvars {
+ #puts stderr " - - a refvar $refvar vidx: $vidx"
+ set tail [namespace tail $refvar]
+ if {[string match "${prop}+*" $tail]} {
+ #refvar is curried
+ #only set if vidx matches curried index
+ #!todo -review
+ set idx [lrange [split $tail +] 1 end]
+ if {$idx eq $vidx} {
+ set newval [set SYNCVARIABLE($vidx)]
+ if {[set $refvar] ne $newval} {
+ set ${refvar} $newval
+ }
+ #puts stderr "=a.1=> updated $refvar"
+ }
+ } else {
+ #refvar is simple
+ set newval [set SYNCVARIABLE($vidx)]
+ if {![info exists ${refvar}($vidx)]} {
+ #new key for this array
+ #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' "
+ array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ]
+ } else {
+ set oldval [set ${refvar}($vidx)]
+ if {$oldval ne $newval} {
+ #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' "
+ array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ]
+ }
+ }
+ #puts stderr "=a.2=> updated ${refvar} $vidx"
+ }
+ }
+
+
+
+ } else {
+
+
+ foreach refvar $refvars {
+ upvar $refvar internal_property_reference
+ #puts stderr " - - b vidx: $vidx"
+
+ #!? could be object not list??
+ #!!but what is the difference between an object, and a list of object names which happens to only contain one object??
+ #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations)
+ #There would still be an edge case of an initial write of a list of objects of length 1.
+ if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} {
+ error "untested review!"
+ #the o_prop is object-shaped
+ #assumes object has a defaultmethod which accepts indices
+ set newval [[set $SYNCVARIABLE] {*}$vidx]
+
+ } else {
+ set newval [lindex $SYNCVARIABLE {*}$vidx]
+ #if {[set $refvar] ne $newval} {
+ # set $refvar $newval
+ #}
+ if {$internal_property_reference ne $newval} {
+ set internal_property_reference $newval
+ }
+
+ }
+ #puts stderr "=b=> updated $refvar"
+ }
+
+
+ }
+
+
+
+ } else {
+ #no vidx
+
+ if {$vtracedIsArray} {
+
+
+ foreach refvar $refvars {
+ set targetref_tail [namespace tail $refvar]
+ set targetref_is_indexed [string match "${prop}+*" $targetref_tail]
+
+
+ #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef"
+ if {$targetref_is_indexed} {
+ #curried array item ref of the form ${prop}+x or ${prop}+x+y etc
+
+ #unindexed write on a property that is acting as an array..
+
+ #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok.
+
+ #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index).
+ # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing.
+ puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op"
+ } else {
+ #How do we know what to write to array ref?
+ puts stderr "\tc.2 WARNING: unimplemented/unused?"
+ #error no_tests_for_branch
+
+ #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation
+ #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate
+ array unset ${refvar}
+ array set ${refvar} [array get SYNCVARIABLE]
+ }
+ }
+
+
+
+ } else {
+ foreach refvar $refvars {
+ #puts stderr "\t\t_________________[namespace current]"
+ set targetref_tail [namespace tail $refvar]
+ upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail
+ set targetref_is_indexed [string match "${prop}+*" $targetref_tail]
+
+ if {$targetref_is_indexed} {
+ #puts "XXXXXXXXX vtraced:$vtraced"
+ #reference curried with index(es)
+ #we only set indexed refs if value has changed
+ # - this not required to be consistent with standard list-containing variable traces,
+ # as normally list elements can't be traced seperately anyway.
+ #
+
+
+ #only bother checking a ref if no setVia index
+ # i.e some operation on entire variable so need to test synchronisation for each element-ref
+ set targetref_indices [lrange [split $targetref_tail +] 1 end]
+ set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices]
+ #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal"
+ if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} {
+ set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal
+ #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]"
+ }
+
+
+ } else {
+ #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed!
+
+ #puts stderr "- d2 set"
+ #puts "refvar: [set $refvar]"
+ #puts "SYNCVARIABLE: $SYNCVARIABLE"
+
+ #if {[set $refvar] ne $SYNCVARIABLE} {
+ # set $refvar $SYNCVARIABLE
+ #}
+ if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} {
+ set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE
+ }
+
+ }
+ }
+
+
+ }
+
+ }
+
+
+
+
+ #reinstall the traces we stored at the beginning of this proc.
+ foreach rv [array names predator_traces] {
+ foreach tinfo $predator_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+ foreach rv [array names external_traces] {
+ foreach tinfo $external_traces($rv) {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+
+ #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd"
+ trace add variable $rv $ops $cmd
+ }
+ }
+
+
+
+}
+
+# end propvar_write_TraceHandler
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#
+
+#returns 0 if method implementation not present for interface
+proc ::p::predator::method_chainhead {iid method} {
+ #Interface proc
+ # examine the existing command-chain
+ set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex)
+ set cmdchain [list]
+
+ set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}]
+ set maxversion 0
+ #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob.
+ foreach test [lsort -dictionary $candidates] {
+ set c [namespace tail $test]
+ if {[regexp $re $c _match version]} {
+ lappend cmdchain $c
+ if {$version > $maxversion} {
+ set maxversion $version
+ }
+ }
+ }
+ return $maxversion
+}
+
+
+
+
+
+#this returns a script that upvars vars for all interfaces on the calling object -
+# - must be called at runtime from a method
+proc ::p::predator::upvar_all {_ID_} {
+ #::set OID [lindex $_ID_ 0 0]
+ ::set OID [::lindex [::dict get $_ID_ i this] 0 0]
+ ::set decl {}
+ #[set ::p::${OID}::_meta::map]
+ #[dict get [lindex [dict get $_ID_ i this] 0 1] map]
+
+ ::upvar #0 ::p::${OID}::_meta::map MAP
+ #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n"
+ #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0]
+
+ ::foreach ifid [dict get $MAP interfaces level0] {
+ if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} {
+ ::array unset nsvars
+ ::array set nsvars [::list]
+ ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] {
+ ::set varspace [::dict get $vinfo varspace]
+ ::lappend nsvars($varspace) $vname
+ }
+ #nsvars now contains vars grouped by varspace.
+
+ ::foreach varspace [::array names nsvars] {
+ if {$varspace eq ""} {
+ ::set ns ::p::${OID}
+ } else {
+ if {[::string match "::*" $varspace]} {
+ ::set ns $varspace
+ } else {
+ ::set ns ::p::${OID}::$varspace
+ }
+ }
+
+ ::append decl "namespace upvar $ns "
+ ::foreach vname [::set nsvars($varspace)] {
+ ::append decl "$vname $vname "
+ }
+ ::append decl " ;\n"
+ }
+ ::array unset nsvars
+ }
+ }
+ ::return $decl
+}
+
+#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator)
+proc ::p::predator::runtime_vardecls {} {
+ set result "::eval \[::p::predator::upvar_all \$_ID_\]"
+ #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_"
+
+ #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]"
+ #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]"
+ #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'"
+ return $result
+}
+
+
+
+
+
+
+#OBSOLETE!(?) - todo - move stuff out of here.
+proc ::p::predator::compile_interface {IFID caller_ID_} {
+ upvar 0 ::p::${IFID}:: IFACE
+
+ #namespace eval ::p::${IFID} {
+ # namespace ensemble create
+ #}
+
+ #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables
+
+ namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces
+
+ #set varDecls {}
+ #if {[llength $o_variables]} {
+ # #puts "*********!!!! $vlist"
+ # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] "
+ # foreach vdef $o_variables {
+ # append varDecls "[lindex $vdef 0] [lindex $vdef 0] "
+ # }
+ # append varDecls \n
+ #}
+
+ #runtime gathering of vars from other interfaces.
+ #append varDecls [runtime_vardecls]
+
+ set varDecls [runtime_vardecls]
+
+
+
+ #implement methods
+
+ #!todo - avoid globs on iface array? maintain list of methods in another slot?
+ #foreach {n mname} [array get IFACE m-1,name,*] {}
+
+
+ #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble.
+
+
+
+ #implement property getters/setters/unsetters
+ #'setter' overrides
+ #pw short for propertywrite
+ foreach {n property} [array get IFACE pw,name,*] {
+ if {[string length $property]} {
+ #set property [lindex [split $n ,] end]
+
+ #!todo - next_script
+ #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property]
+
+ set maxversion [::p::predator::method_chainhead $IFID (SET)$property]
+ set chainhead [expr {$maxversion + 1}]
+ set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1
+
+ set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??
+
+ set body $IFACE(pw,body,$property)
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body"
+ }
+
+ #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+
+ set maxversion [::p::predator::method_chainhead $IFID $property]
+ set headid [expr {$maxversion + 1}]
+
+ proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body
+
+ interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid
+
+ #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body
+ }
+ }
+ #'unset' overrides
+
+ dict for {property handler_info} $o_propertyunset_handlers {
+
+ set body [dict get $handler_info body]
+ set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array
+
+ set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (UNSET)$property.$headid
+
+ set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ???
+
+
+
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body"
+
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+
+
+ #implement
+ #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements)
+ if {[string trim $arraykeypattern] eq ""} {
+ set arraykeypattern "_dontcare_"
+ }
+ proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body
+
+
+ #chainhead pointer
+ interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid
+ }
+
+
+
+ interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE)
+
+ #the usual case will have no destructor - so use info exists to check.
+
+ if {[info exists ::p::${IFID}::_iface::o_destructor_body]} {
+ #!todo - chained destructors (support @next@).
+ #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID]
+ set next NEXT
+
+ set body [set ::p::${IFID}::_iface::o_destructor_body]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body"
+ }
+ #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body]
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ proc ::p::${IFID}::___system___destructor _ID_ $body
+ }
+
+
+ if {[info exists o_unknown]} {
+ #use 'apply' somehow?
+ interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown
+
+ #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown]
+ }
+
+
+ return
+}
+
+
+
+
+
+
+
+#'info args' - assuming arbitrary chain of 'interp aliases'
+proc ::p::predator::command_info_args {cmd} {
+ if {[llength [set next [interp alias {} $cmd]]]} {
+ set curriedargs [lrange $next 1 end]
+
+ if {[catch {set arglist [info args [lindex $next 0]]}]} {
+ set arglist [command_info_args [lindex $next 0]]
+ }
+ #trim curriedargs
+ return [lrange $arglist [llength $curriedargs] end]
+ } else {
+ info args $cmd
+ }
+}
+
+
+proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} {
+ if {[llength $args]} {
+ tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args
+ } else {
+ if {[llength $nextArgs] > 1} {
+ set argVals [::list]
+ set i 0
+ foreach arg [lrange $nextArgs 1 end] {
+ upvar 1 $arg $i
+ if {$arg eq "args"} {
+ #need to check if 'args' is actually available in caller
+ if {[info exists $i]} {
+ set argVals [concat $argVals [set $i]]
+ }
+ } else {
+ lappend argVals [set $i]
+ }
+ }
+ tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals
+ } else {
+ tailcall ::p::${IFID}::_iface::$mname $_ID_
+ }
+ }
+}
+
+#----------------------------------------------------------------------------------------------
+proc ::p::predator::next_script {IFID method caller caller_ID_} {
+
+ if {$caller eq "(CONSTRUCTOR).1"} {
+ return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}]
+ } elseif {$caller eq "$method.1"} {
+ #delegate to next interface lower down the stack which has a member named $method
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ } elseif {[string match "(GET)*.2" $caller]} {
+ # .1 is the getprop procedure, .2 is the bottom-most PropertyRead.
+
+ #jmn
+ set prop [string trimright $caller 1234567890]
+ set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing .
+
+ if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} {
+ #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}]
+ return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}]
+ } else {
+ #we can actually have a property read without a property or a method of that name - but it could also match the name of a method.
+ # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something)
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ }
+ } elseif {[string match "(SET)*.2" $caller]} {
+ return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}]
+ } else {
+ #this branch will also handle (SET)*.x and (GET)*.x where x >2
+
+ #puts stdout "............next_script IFID:$IFID method:$method caller:$caller"
+ set callerid [string range $caller [string length "$method."] end]
+ set nextid [expr {$callerid - 1}]
+
+ if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} {
+ #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface.
+ #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid"
+ set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid]
+ }
+
+ return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}]
+ }
+}
+
+proc ::p::predator::do_next_if {_ID_ IFID method args} {
+ #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' ((("
+
+ #set invocants [dict get $_ID_ i]
+ #set this_invocantdata [lindex [dict get $invocants this] 0]
+ #lassign $this_invocantdata OID this_info
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set interfaces [dict get $MAP interfaces level0]
+ set patterninterfaces [dict get $MAP interfaces level1]
+
+ set L0_posn [lsearch $interfaces $IFID]
+ if {$L0_posn == -1} {
+ error "(::p::predator::do_next_if) called with interface not present at level0 for this object"
+ } elseif {$L0_posn > 0} {
+ #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack
+ set lower_interfaces [lrange $interfaces 0 $L0_posn-1]
+
+ foreach if_sub [lreverse $lower_interfaces] {
+ if {[string match "(GET)*" $method]} {
+ #do not test o_properties here! We need to call even if there is no underlying property on this interface
+ #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface)
+ # relevant test: higher_order_propertyread_chaining
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ } elseif {[string match "(SET)*" $method]} {
+ #must be called even if there is no matching $method in o_properties
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ } elseif {[string match "(UNSET)*" $method]} {
+ #review untested
+ #error "do_next_if (UNSET) untested"
+ #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'"
+ return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+
+ } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} {
+ if {[llength $args]} {
+ #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args"
+
+ #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args]
+ #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args
+
+ #!todo - handle case where llength $args is less than number of args for subinterface command
+ #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set)
+
+ #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature)
+ set head [interp alias {} ::p::${if_sub}::_iface::$method]
+ set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc
+ set argx [list]
+ foreach a $nextArgs {
+ lappend argx "\$a"
+ }
+
+ #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared
+
+ if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} {
+ tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args
+ } else {
+ #todo - upvars required for tail end of arglist
+ tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args
+ }
+
+ } else {
+ #auto-set: upvar vars from calling scope
+ #!todo - robustify? alias not necessarily matching command name..
+ set head [interp alias {} ::p::${if_sub}::_iface::$method]
+
+
+ set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc
+ if {[llength $nextArgs] > 1} {
+ set argVals [::list]
+ set i 0
+ foreach arg [lrange $nextArgs 1 end] {
+ upvar 1 $arg $i
+ if {$arg eq "args"} {
+ #need to check if 'args' is actually available in caller
+ if {[info exists $i]} {
+ set argVals [concat $argVals [set $i]]
+ }
+ } else {
+ lappend argVals [set $i]
+ }
+ }
+ #return [$head $_ID_ {*}$argVals]
+ tailcall $head $_ID_ {*}$argVals
+ } else {
+ #return [$head $_ID_]
+ tailcall $head $_ID_
+ }
+ }
+ } elseif {$method eq "(CONSTRUCTOR)"} {
+ #chained constructors will only get args if the @next@ caller explicitly provided them.
+ puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!"
+ #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args]
+ xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args
+ }
+ }
+ #no interfaces in the iStack contained a matching method.
+ return
+ } else {
+ #no further interfaces in this iStack
+ return
+ }
+}
+
+
+#only really makes sense for (CONSTRUCTOR) calls.
+#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class.
+proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} {
+ #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' ((("
+
+ #set invocants [dict get $_ID_ i]
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID this_info
+ #set OID [lindex [dict get $invocants this] 0 0]
+ #upvar #0 ::p::${OID}::_meta::map map
+ #lassign [lindex $map 0] OID alias itemCmd cmd
+
+
+ set caller_OID [lindex [dict get $caller_ID_ i this] 0 0]
+ upvar #0 ::p::${caller_OID}::_meta::map callermap
+
+ #set interfaces [lindex $map 1 0]
+ set patterninterfaces [dict get $callermap interfaces level1]
+
+ set L0_posn [lsearch $patterninterfaces $IFID]
+ if {$L0_posn == -1} {
+ error "do_next_pattern_if called with interface not present at level1 for this object"
+ } elseif {$L0_posn > 0} {
+
+
+ set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1]
+
+ foreach if_sub [lreverse $lower_interfaces] {
+ if {$method eq "(CONSTRUCTOR)"} {
+ #chained constructors will only get args if the @next@ caller explicitly provided them.
+ #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!"
+ tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args
+ }
+ }
+ #no interfaces in the iStack contained a matching method.
+ return
+ } else {
+ #no further interfaces in this iStack
+ return
+ }
+}
+
+
+
+
+
+#------------------------------------------------------------------------------------------------
+
+
+
+
+
+#-------------------------------------------------------------------------------------
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+#######################################################
+
+
+#!todo - can we just call new_object somehow to create this?
+
+ #until we have a version of Tcl that doesn't have 'creative writing' scope issues -
+ # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword.
+ # (see http://mini.net/tcl/1030 'Dangers of creative writing')
+namespace eval ::p::-1 {
+ #namespace ensemble create
+
+ namespace eval _ref {}
+ namespace eval _meta {}
+
+ namespace eval _iface {
+ variable o_usedby
+ variable o_open
+ variable o_constructor
+ variable o_variables
+ variable o_properties
+ variable o_methods
+ variable o_definition
+ variable o_varspace
+ variable o_varspaces
+
+ array set o_usedby [list i0 1] ;#!todo - review
+ #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value?
+
+ set o_open 1
+ set o_constructor [list]
+ set o_variables [list]
+ set o_properties [dict create]
+ set o_methods [dict create]
+ array set o_definition [list]
+ set o_varspace ""
+ set o_varspaces [list]
+ }
+}
+
+
+#
+
+#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}]
+interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}]
+
+
+upvar #0 ::p::-1::_iface::o_definition def
+
+
+#! concatenate -> compose ??
+dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}}
+proc ::p::-1::Concatenate {_ID_ target args} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ if {![string match "::*" $target]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set target ::$target
+ } else {
+ set target ${ns}::$target
+ }
+ }
+ #add > character if not already present
+ set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >]
+ set _target [string map {::> ::} $target]
+
+ set ns [namespace qualifiers $target]
+ if {$ns eq ""} {
+ set ns "::"
+ } else {
+ namespace eval $ns {}
+ }
+
+ if {![llength [info commands $target]]} {
+ #degenerate case - target does not exist
+ #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone'
+ #review - should be 'Copy' so it has object state from namespaces and variables?
+ return [::p::-1::Clone $_ID_ $target {*}$args]
+
+ #set TARGETMAP [::p::predator::new_object $target]
+ #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd
+
+ } else {
+ #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1]
+ set TARGETMAP [$target --]
+
+ lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd
+
+ #Merge lastmodified(?) level0 and level1 interfaces.
+
+ }
+
+ return $target
+}
+
+
+
+#Object's Base-Interface proc with itself as curried invocant.
+#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant
+#namespace eval ::p::-1 {namespace export Create}
+dict set ::p::-1::_iface::o_methods Define {arglist definitions}
+#define objects in one step
+proc ::p::-1::Define {_ID_ definitions} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias default_method cmd
+ set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces
+ set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces
+
+ #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack
+ #set IFID0 [lindex $interfaces 0]
+ #set IFID1 [lindex $patterns 0] ;#1st pattern
+
+ #set IFID_TOP [lindex $interfaces end]
+ set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID]
+
+ #set ns ::p::${OID}
+
+ #set script [string map [list %definitions% $definitions] {
+ # if {[lindex [namespace path] 0] ne "::p::-1"} {
+ # namespace path [list ::p::-1 {*}[namespace path]]
+ # }
+ # %definitions%
+ # namespace path [lrange [namespace path] 1 end]
+ #
+ #}]
+
+ set script [string map [list %id% $_ID_ %definitions% $definitions] {
+ set ::p::-1::temp_unknown [namespace unknown]
+
+ namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}]
+
+
+ #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ]
+
+
+ %definitions%
+
+
+ namespace unknown ${::p::-1::temp_unknown}
+ return
+ }]
+
+
+
+ #uplevel 1 $script ;#this would run the script in the global namespace
+ #run script in the namespace of the open interface, this allows creating of private helper procs
+ #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack
+ #namespace inscope ::p::${OID} $script
+ namespace eval ::p::${OID} $script
+ #return $cmd
+}
+
+
+proc ::p::predator::redirect {func args} {
+
+ #todo - review tailcall - tests?
+ if {![llength [info commands ::p::-1::$func]]} {
+ #error "invalid command name \"$func\""
+ tailcall uplevel 1 [list ::unknown $func {*}$args]
+ } else {
+ tailcall uplevel 1 [list ::p::-1::$func {*}$args]
+ }
+}
+
+
+#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review.
+dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}}
+proc ::p::-1::Construct {_ID_ argpairs body args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+ namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ set ARGSETTER {}
+ foreach {argname argval} $argpairs {
+ append ARGSETTER "set $argname $argval\n"
+ }
+ #$_self (VIOLATE) $ARGSETTER$body
+
+ set body $ARGSETTER\n$body
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls\n[dict get $processed body]
+ # puts stderr "\t runtime_vardecls in Construct $varDecls"
+ }
+
+ set next "\[error {next not implemented}\]"
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ #namespace eval ::p::${iid_top} $body
+
+ #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_]
+ #does this handle Varspace before constructor?
+ return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args]
+}
+
+
+
+
+
+#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects
+namespace eval ::p::3 {}
+proc ::p::3::_create {child {OID "-2"}} {
+ #puts stderr "::p::3::_create $child $OID"
+ set _child [string map {::> ::} $child]
+ if {$OID eq "-2"} {
+ #set childmapdata [::p::internals::new_object $child]
+ #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ]
+ set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0]
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+ } else {
+ set child_ID $OID
+ #set _childmap [::p::internals::new_object $child "" $child_ID]
+ ::p::internals::new_object $child "" $child_ID
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+ }
+
+ #--------------
+
+ set oldinterfaces [dict get $CHILDMAP interfaces]
+ dict set oldinterfaces level0 [list 2]
+ set modifiedinterfaces $oldinterfaces
+ dict set CHILDMAP interfaces $modifiedinterfaces
+
+ #--------------
+
+
+
+
+ #puts stderr ">>>> creating alias for ::p::$child_ID"
+ #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]"
+
+ #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing!
+ #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]]
+ #puts stderr ">>>[interp alias {} ::p::$child_ID]"
+
+
+
+ #---------------
+ namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties
+ foreach method [dict keys $o_methods] {
+ #todo - change from interp alias to context proc
+ interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method
+ }
+ #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods]
+ #implement property even if interface already compiled because we need to create defaults for each new child obj.
+ # also need to add alias on base interface
+ #make sure we are only implementing properties from the current CREATOR
+ dict for {prop pdef} $o_properties {
+ #lassign $pdef prop default
+ interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop
+ interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop
+
+ }
+ ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}]
+ #---------------
+ #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child"
+ return $child
+}
+
+#configure -prop1 val1 -prop2 val2 ...
+dict set ::p::-1::_iface::o_methods Configure {arglist args}
+proc ::p::-1::Configure {_ID_ args} {
+
+ #!todo - add tests.
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd this
+
+ if {![expr {([llength $args] % 2) == 0}]} {
+ error "expected even number of Configure args e.g '-property1 value1 -property2 value2'"
+ }
+
+ #Do a separate loop to check all the arguments before we run the property setting loop
+ set properties_to_configure [list]
+ foreach {argprop val} $args {
+ if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} {
+ error "expected Configure args in the form: '-property1 value1 -property2 value2'"
+ }
+ lappend properties_to_configure [string range $argprop 1 end]
+ }
+
+ #gather all valid property names for all level0 interfaces in the relevant interface stack
+ set valid_property_names [list]
+ set iflist [dict get $MAP interfaces level0]
+ foreach id [lreverse $iflist] {
+ set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]]
+ foreach if_prop $interface_property_names {
+ if {$if_prop ni $valid_property_names} {
+ lappend valid_property_names $if_prop
+ }
+ }
+ }
+
+ foreach argprop $properties_to_configure {
+ if {$argprop ni $valid_property_names} {
+ error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names"
+ }
+ }
+
+ set top_IID [lindex $iflist end]
+ #args ok - go ahead and set all properties
+ foreach {prop val} $args {
+ set property [string range $prop 1 end]
+ #------------
+ #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update
+ #ie don't do this here: set [$this . $property .] $val
+ #-------------
+ ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val]
+ }
+ return
+}
+
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid}
+proc ::p::-1::AddPatternInterface {_ID_ iid} {
+ #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid"
+ if {![string is integer -strict $iid]} {
+ error "adding interface by name not yet supported. Please use integer id"
+ }
+
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ #lassign [lindex $invocant 0] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces
+
+
+
+ #it is theoretically possible to have the same interface present multiple times in an iStack.
+ # #!todo -review why/whether this is useful. should we disallow it and treat as an error?
+
+ lappend existing_ifaces $iid
+ #lset map {1 1} $existing_ifaces
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 $existing_ifaces
+ dict set MAP interfaces $extracted_sub_dict
+
+ #lset invocant {1 1} $existing_ifaces
+
+}
+
+
+#!todo - update usedby ??
+dict set ::p::-1::_iface::o_methods AddInterface {arglist iid}
+proc ::p::-1::AddInterface {_ID_ iid} {
+ #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid"
+ if {![string is integer -strict $iid]} {
+ error "adding interface by name not yet supported. Please use integer id"
+ }
+
+
+ lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list.
+ set this_invocant [lindex $list_of_invocants_for_role_this 0]
+
+ lassign $this_invocant OID _etc
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set existing_ifaces [dict get $MAP interfaces level0]
+
+ lappend existing_ifaces $iid
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 $existing_ifaces
+ dict set MAP interfaces $extracted_sub_dict
+ return [dict get $extracted_sub_dict level0]
+}
+
+
+
+# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module.
+# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist
+# and 'CreateOverlay' for the case where the target/child object already exists.
+# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence,
+# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object.
+# 'CreateNew' will raise an error if the target already exists
+# 'CreateOverlay' will raise an error if the target object does not exist.
+# 'Create' will work in either case. Creating the target if necessary.
+
+
+#simple form:
+# >somepattern .. Create >child
+#simple form with arguments to the constructor:
+# >somepattern .. Create >child arg1 arg2 etc
+#complex form - specify more info about the target (dict keyed on childobject name):
+# >somepattern .. Create {>child {-id 1}}
+#or
+# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}]
+#complex form - with arguments to the contructor:
+# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc
+dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}}
+proc ::p::-1::Create {_ID_ target_spec args} {
+ #$args are passed to constructor
+ if {[llength $target_spec] ==1} {
+ set child $target_spec
+ set targets [list $child {}]
+ } else {
+ set targets $target_spec
+ }
+
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case)
+
+ foreach {child target_spec_dict} $targets {
+ #puts ">>>::p::-1::Create $_ID_ $child $args <<<"
+
+
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+
+
+
+ #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID"
+
+ #child should already be fully ns qualified (?)
+ #ensure it is has a pattern-object marker >
+ #puts stderr ".... $child (nsqual: [namespace qualifiers $child])"
+
+
+ lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd
+ set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces
+ set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces
+ #puts "parent: $OID -> child:$child Patterns $patterns"
+
+ #todo - change to dict of interface stacks
+ set IFID0 [lindex $interfaces 0]
+ set IFID1 [lindex $patterns 0] ;#1st pattern
+
+ #upvar ::p::${OID}:: INFO
+
+ if {![string match {::*} $child]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set child ::$child
+ } else {
+ set child ${ns}::$child
+ }
+ }
+
+
+ #add > character if not already present
+ set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >]
+ set _child [string map {::> ::} $child]
+
+ set ns [namespace qualifiers $child]
+ if {$ns eq ""} {
+ set ns "::"
+ } else {
+ namespace eval $ns {}
+ }
+
+
+ #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls.
+ set new_interfaces [list]
+
+ if {![llength $patterns]} {
+ ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child"
+ #lappend patterns [::p::internals::new_interface $OID]
+
+ #lset invocant {1 1} $patterns
+ ##update our command because we changed the interface list.
+ #set IFID1 [lindex $patterns 0]
+
+ #set patterns [list [::p::internals::new_interface $OID]]
+
+ #set patterns [list [::p::internals::new_interface]]
+
+ #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id
+ #set patterns [list [set iid [incr ::p::ID]]]
+ set patterns [list [set iid [::p::get_new_object_id]]]
+
+ #---------
+ #set iface [::p::>interface .. Create ::p::ifaces::>$iid]
+ #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid
+
+ #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation
+ lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid]
+
+ #---------
+
+ #puts "??> p::>interface .. Create ::p::ifaces::>$iid"
+ #puts "??> [::p::ifaces::>$iid --]"
+ #set [$iface . UsedBy .]
+ }
+ set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod]
+
+ #if {![llength [info commands $child]]} {}
+
+ if {[namespace which $child] eq ""} {
+ #normal case - target/child does not exist
+ set is_new_object 1
+
+ if {[dict exists $target_spec_dict -id]} {
+ set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]]
+ } else {
+ set childmapdata [::p::internals::new_object $child]
+ }
+ lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+
+
+
+ #child initially uses parent's level1 interface as it's level0 interface
+ # child has no level1 interface until PatternMethods or PatternProperties are added
+ # (or applied via clone; or via create with a parent with level2 interface)
+ #set child_IFID $IFID1
+
+ #lset CHILDMAP {1 0} [list $IFID1]
+ #lset CHILDMAP {1 0} $patterns
+
+ set extracted_sub_dict [dict get $CHILDMAP interfaces]
+ dict set extracted_sub_dict level0 $patterns
+ dict set CHILDMAP interfaces $extracted_sub_dict
+
+ #why write back when upvared???
+ #review
+ set ::p::${child_ID}::_meta::map $CHILDMAP
+
+ #::p::predator::remap $CHILDMAP
+
+ #interp alias {} $child {} ::p::internals::predator $CHILDMAP
+
+ #set child_IFID $IFID1
+
+ #upvar ::p::${child_ID}:: child_INFO
+
+ #!todo review
+ #set n ::p::${child_ID}
+ #if {![info exists ${n}::-->PATTERN_ANCHOR]} {
+ # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'"
+ # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack
+ # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset"
+ # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n]
+ #}
+
+ set ifaces_added $patterns
+
+ } else {
+ #overlay/mixin case - target/child already exists
+ set is_new_object 0
+
+ #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1]
+ set childmapdata [$child --]
+
+
+ #puts stderr " *** $cmd .. Create -> target $child already exists!!!"
+ #puts " **** CHILDMAP: $CHILDMAP"
+ #puts " ****"
+
+ #puts stderr " ---> Properties: [$child .. Properties . names]"
+ #puts stderr " ---> Methods: [$child .. Properties . names]"
+
+ lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd
+ upvar #0 ::p::${child_ID}::_meta::map CHILDMAP
+
+ #set child_IFID [lindex $CHILDMAP 1 0 end]
+ #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} {
+ # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID]
+ # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP
+ #}
+ ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces
+ #::p::merge_interface $IFID1 $child_IFID
+
+
+ set existing_interfaces [dict get $CHILDMAP interfaces level0]
+ set ifaces_added [list]
+ foreach p $patterns {
+ if {$p ni $existing_interfaces} {
+ lappend ifaces_added $p
+ }
+ }
+
+ if {[llength $ifaces_added]} {
+ #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added]
+ set extracted_sub_dict [dict get $CHILDMAP interfaces]
+ dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added]
+ dict set CHILDMAP interfaces $extracted_sub_dict
+ #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why?
+ #::p::predator::remap $CHILDMAP
+ }
+ }
+
+ #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty
+ if {$parent_patterndefaultmethod ne ""} {
+ set child_defaultmethod $parent_patterndefaultmethod
+ set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata]
+ lset CHILD_INVOCANTDATA 2 $child_defaultmethod
+ dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA
+ #update the child's _ID_
+ interp alias {} $child_alias {} ;#first we must delete it
+ interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}]
+
+ #! object_command was initially created as the renamed alias - so we have to do it again
+ rename $child_alias $child
+ trace add command $child rename [list $child .. Rename]
+ }
+ #!todo - review - dont we already have interp alias entries for every method/prop?
+ #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child"
+
+
+
+
+
+ set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call.
+
+
+
+ #------------------------------------------------------------------------------------
+ #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail.
+ # - All variables under the namespace - not just those declared as Variables or Properties
+ # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces.
+ # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write.
+
+ #NOTE - do not use the objectID as the sole identifier for the snapshot namespace.
+ # - there may be multiple active snapshots for a single object if it overlays itself during a constructor,
+ # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call.
+ # - we will use an ever-increasing snapshotid to form part of ns_snap
+ set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create.
+
+ #!todo - this should look at child namespaces (recursively?)
+ #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces.
+ # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace)
+
+ namespace eval $ns_snap {}
+ foreach vname [info vars ::p::${child_ID}::*] {
+ set shortname [namespace tail $vname]
+ if {[array exists $vname]} {
+ array set ${ns_snap}::${shortname} [array get $vname]
+ } elseif {[info exists $vname]} {
+ set ${ns_snap}::${shortname} [set $vname]
+ } else {
+ #variable exists without value (e.g created by 'variable' command)
+ namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist'
+ }
+ }
+ #------------------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+ #puts "====>>> ifaces_added $ifaces_added"
+ set idx 0
+ set idx_count [llength $ifaces_added]
+ set highest_constructor_IFID ""
+ foreach IFID $ifaces_added {
+ incr idx
+ #puts "--> adding iface $IFID "
+ namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces
+
+ if {[llength $o_varspaces]} {
+ foreach vs $o_varspaces {
+ #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work.
+ if {[string match "::*" $vs]} {
+ namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all.
+ } else {
+ namespace eval ::p::${child_ID}::$vs {}
+ }
+ }
+ }
+
+ if {$IFID != 2} {
+ #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list.
+ if {![info exists o_usedby(i$child_ID)]} {
+ set o_usedby(i$child_ID) $child_alias
+ }
+
+ #compile and close the interface only if it is shared
+ if {$o_open} {
+ ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_
+ set o_open 0
+ }
+ }
+
+
+
+ package require struct::set
+
+ set propcmds [list]
+ foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] {
+ set cmd [namespace tail $cmd]
+ #may contain multiple results for same prop e.g (GET)x.3
+ set cmd [string trimright $cmd 0123456789]
+ set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals
+ lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here.
+ }
+ set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes.
+ #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface.
+ foreach property $propcmds {
+ #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n"
+ interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces
+ interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property
+ }
+
+ set propcmds [list]
+ foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] {
+ set cmd [namespace tail $cmd]
+ #may contain multiple results for same prop e.g (GET)x.3
+ set cmd [string trimright $cmd 0123456789]
+ set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals
+ lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here.
+ }
+ set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes.
+ #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface.
+ foreach property $propcmds {
+ interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces
+ }
+
+
+ foreach method [dict keys $o_methods] {
+ set arglist [dict get $o_methods $method arglist]
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+
+ #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method
+
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #proc calls the method in the interface - which is an interp alias to the head of the implementation chain
+
+
+ proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${IFID}::_iface::$method \$_ID_ $argvals
+ }]
+
+ #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] {
+ # ::p::@ID@::_iface::@m@ $_ID_ @argvals@
+ #}]
+
+
+ }
+
+ #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods]
+
+ #implement property even if interface already compiled because we need to create defaults for each new child obj.
+ # also need to add alias on base interface
+ #make sure we are only implementing properties from the current CREATOR
+ dict for {prop pdef} $o_properties {
+ set varspace [dict get $pdef varspace]
+ if {![string length $varspace]} {
+ set ns ::p::${child_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${child_ID}::$varspace
+ }
+ }
+ if {[dict exists $pdef default]} {
+ if {![info exists ${ns}::o_$prop]} {
+ #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset)
+ set ${ns}::o_$prop [dict get $pdef default]
+ }
+ }
+ #! May be replaced by a method with the same name
+ if {$prop ni [dict keys $o_methods]} {
+ interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop
+ }
+ interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop
+ interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop
+ }
+
+
+
+ #variables
+ #foreach vdef $o_variables {
+ # if {[llength $vdef] == 2} {
+ # #there is a default value defined.
+ # lassign $vdef v default
+ # if {![info exists ::p::${child_ID}::$v]} {
+ # set ::p::${child_ID}::$v $default
+ # }
+ # }
+ #}
+ dict for {vname vdef} $o_variables {
+ if {[dict exists $vdef default]} {
+ #there is a default value defined.
+ set varspace [dict get $vdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${child_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${child_ID}::$varspace
+ }
+ }
+ set ${ns}::$vname [dict get $vdef default]
+ }
+ }
+
+
+ #!todo - review. Write tests for cases of multiple constructors!
+
+ #We don't want to the run constructor for each added interface with the same set of args!
+ #run for last one - rely on constructor authors to use @next@ properly?
+ if {[llength [set ::p::${IFID}::_iface::o_constructor]]} {
+ set highest_constructor_IFID $IFID
+ }
+
+ if {$idx == $idx_count} {
+ #we are processing the last interface that was added - now run the latest constructor found
+ if {$highest_constructor_IFID ne ""} {
+ #at least one interface has a constructor
+ if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} {
+ #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP"
+ if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} {
+ set constructor_failure 1
+ set constructor_errorInfo $::errorInfo ;#cache it immediately.
+ break
+ }
+ }
+ }
+ }
+
+ if {[info exists o_unknown]} {
+ interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown
+ interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown
+
+
+ #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown
+ #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown]
+ #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown]
+ }
+ }
+
+ if {$constructor_failure} {
+ if {$is_new_object} {
+ #is Destroy enough to ensure that no new interfaces or objects were left dangling?
+ $child .. Destroy
+ } else {
+ #object needs to be returned to a sensible state..
+ #attempt to rollback all interface additions and object state changes!
+ puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n"
+ #remove variables from the object's namespace - which don't exist in the snapshot.
+ set snap_vars [info vars ${ns_snap}::*]
+ puts "ns_snap '$ns_snap' vars'${snap_vars}'"
+ foreach vname [info vars ::p::${child_ID}::*] {
+ set shortname [namespace tail $vname]
+ if {"${ns_snap}::$shortname" ni "$snap_vars"} {
+ #puts "--- >>>>> unsetting $shortname "
+ unset -nocomplain $vname
+ }
+ }
+
+ #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces)
+ #values of vars may also have Changed
+ #todo - consider traces? what is the correct behaviour?
+ # - some application traces may have fired before the constructor error occurred.
+ # Should the rollback now also trigger traces?
+ #probably yes.
+
+ #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value
+ foreach vname $snap_vars {
+ #puts stdout "@@@@@@@@@@@ restoring $vname"
+ #flush stdout
+
+
+ set shortname [namespace tail $vname]
+ set target ::p::${child_ID}::$shortname
+ if {$target in [info vars ::p::${child_ID}::*]} {
+ set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only'
+ } else {
+ set present 0
+ }
+
+ if {[array exists $vname]} {
+ #restore 'array' variable
+ if {!$present} {
+ array set $target [array get $vname]
+ } else {
+ if {[array exists $target]} {
+ #unset superfluous elements
+ foreach key [array names $target] {
+ if {$key ni [array names $vname]} {
+ array unset $target $key
+ }
+ }
+ #.. and write only elements that have changed.
+ foreach key [array names $vname] {
+ if {[set ${target}($key)] ne [set ${vname}($key)]} {
+ set ${target}($key) [set ${vname}($key)]
+ }
+ }
+ } else {
+ #target has been changed to a simple variable - unset it and recreate the array.
+ unset $target
+ array set $target [array get $vname]
+ }
+ }
+ } elseif {[info exists $vname]} {
+ #restore 'simple' variable
+ if {!$present} {
+ set $target [set $vname]
+ } else {
+ if {[array exists $target]} {
+ #target has been changed to array - unset it and recreate the simple variable.
+ unset $target
+ set $target [set $vname]
+ } else {
+ if {[set $target] ne [set $vname]} {
+ set $target [set $vname]
+ }
+ }
+ }
+ } else {
+ #restore 'declared' variable
+ if {[array exists $target] || [info exists $target]} {
+ unset -nocomplain $target
+ }
+ namespace eval ::p::${child_ID} [list variable $shortname]
+ }
+ }
+ }
+ namespace delete $ns_snap
+ return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error
+ }
+ namespace delete $ns_snap
+
+ }
+
+
+
+ return $child
+}
+
+dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}}
+#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied*
+# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*)
+# Also: Any 'open' interfaces on the parent become closed on clone!
+proc ::p::-1::Clone {_ID_ clone args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set invocants [dict get $_ID_ i]
+ lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd
+
+ set _cmd [string map {::> ::} $cmd]
+ set tail [namespace tail $_cmd]
+
+
+ #obsolete?
+ ##set IFID0 [lindex $map 1 0 end]
+ #set IFID0 [lindex [dict get $MAP interfaces level0] end]
+ ##set IFID1 [lindex $map 1 1 end]
+ #set IFID1 [lindex [dict get $MAP interfaces level1] end]
+
+
+ if {![string match "::*" $clone]} {
+ if {[set ns [uplevel 1 {namespace current}]] eq "::"} {
+ set clone ::$clone
+ } else {
+ set clone ${ns}::$clone
+ }
+ }
+
+
+ set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >]
+ set _clone [string map {::> ::} $clone]
+
+
+ set cTail [namespace tail $_clone]
+
+ set ns [namespace qualifiers $clone]
+ if {$ns eq ""} {
+ set ns "::"
+ }
+
+ namespace eval $ns {}
+
+
+ #if {![llength [info commands $clone]]} {}
+ if {[namespace which $clone] eq ""} {
+ set clonemapdata [::p::internals::new_object $clone]
+ } else {
+ #overlay/mixin case - target/clone already exists
+ #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1]
+ set clonemapdata [$clone --]
+ }
+ set clone_ID [lindex [dict get $clonemapdata invocantdata] 0]
+
+ upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP
+
+
+ #copy patterndata element of MAP straight across
+ dict set CLONEMAP patterndata [dict get $MAP patterndata]
+ set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata]
+ lset CLONE_INVOCANTDATA 2 $parent_defaultmethod
+ dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA
+ lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone
+
+ #update the clone's _ID_
+ interp alias {} $clone_alias {} ;#first we must delete it
+ interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}]
+
+ #! object_command was initially created as the renamed alias - so we have to do it again
+ rename $clone_alias $clone
+ trace add command $clone rename [list $clone .. Rename]
+
+
+
+
+ #obsolete?
+ #upvar ::p::${clone_ID}:: clone_INFO
+ #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone.
+ #upvar ::p::${OID}:: INFO
+
+
+ array set clone_INFO [array get INFO]
+
+ array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby'
+
+
+ #!review!
+ #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} {
+ #puts "***************"
+ #puts "clone"
+ #parray IFINFO
+ #puts "***************"
+ #}
+
+ #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern
+
+
+ #clone's interface maps must be a superset of original's
+ foreach lev {0 1} {
+ #set parent_ifaces [lindex $map 1 $lev]
+ set parent_ifaces [dict get $MAP interfaces level$lev]
+
+ #set existing_ifaces [lindex $CLONEMAP 1 $lev]
+ set existing_ifaces [dict get $CLONEMAP interfaces level$lev]
+
+ set added_ifaces_$lev [list]
+ foreach ifid $parent_ifaces {
+ if {$ifid ni $existing_ifaces} {
+
+ #interface must not remain extensible after cloning.
+ if {[set ::p::${ifid}::_iface::o_open]} {
+ ::p::predator::compile_interface $ifid $_ID_
+ set ::p::${ifid}::_iface::o_open 0
+ }
+
+
+
+ lappend added_ifaces_$lev $ifid
+ #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list.
+ set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone
+ }
+ }
+ set extracted_sub_dict [dict get $CLONEMAP interfaces]
+ dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]]
+ dict set CLONEMAP interfaces $extracted_sub_dict
+ #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]]
+ }
+
+ #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE)
+
+
+ #foreach *added* level0 interface..
+ foreach ifid $added_ifaces_0 {
+ namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown
+
+
+ dict for {prop pdef} $o_properties {
+ #lassign $pdef prop default
+ if {[dict exists $pdef default]} {
+ set varspace [dict get $pdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${clone_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${clone_ID}::$varspace
+ }
+ }
+
+ if {![info exists ${ns}::o_$prop]} {
+ #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset)
+ set ${ns}::o_$prop [dict get $pdef default]
+ }
+ }
+
+ #! May be replaced by method of same name
+ if {[namespace which ::p::${clone_ID}::$prop] eq ""} {
+ interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop
+ }
+ interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop
+ interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop
+ }
+
+ #variables
+ dict for {vname vdef} $o_variables {
+ if {[dict exists $vdef default]} {
+ set varspace [dict get $vdef varspace]
+ if {$varspace eq ""} {
+ set ns ::p::${clone_ID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${clone_ID}::$varspace
+ }
+ }
+ if {![info exists ${ns}::$vname]} {
+ set ::p::${clone_ID}::$vname [dict get $vdef default]
+ }
+ }
+ }
+
+
+ #update the clone object's base interface to reflect the new methods.
+ #upvar 0 ::p::${ifid}:: IFACE
+ #set methods [list]
+ #foreach {key mname} [array get IFACE m-1,name,*] {
+ # set method [lindex [split $key ,] end]
+ # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP
+ # lappend methods $method
+ #}
+ #namespace eval ::p::${clone_ID} [list namespace export {*}$methods]
+
+
+ foreach method [dict keys $o_methods] {
+
+ set arglist [dict get $o_methods $method arglist]
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+ #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method
+
+
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #proc calls the method in the interface - which is an interp alias to the head of the implementation chain
+ proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${ifid}::_iface::$method \$_ID_ $argvals
+ }]
+
+ }
+ #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods]
+
+
+ if {[info exists o_unknown]} {
+ #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown
+ interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown
+ interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown
+
+ #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown]
+ #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown]
+
+ }
+
+
+ #2021
+ #Consider >parent with constructor that sets height
+ #.eg >parent .. Constructor height {
+ # set o_height $height
+ #}
+ #>parent .. Create >child 5
+ # - >child has height 5
+ # now when we peform a clone operation - it is the >parent's constructor that will run.
+ # A clone will get default property and var values - but not other variable values unless the constructor sets them.
+ #>child .. Clone >fakesibling 6
+ # - >sibling has height 6
+ # Consider if >child had it's own constructor created with .. Construct prior to the clone operation.
+ # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead.
+ # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining...
+ # when we now do >sibling .. Create >grandchild
+ # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild
+ # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.)
+ # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild
+ #(though other arguments can be manually passed)
+ # #!review - does this make sense? What if we add
+ #
+ #constructor for each interface called after properties initialised.
+ #run each interface's constructor against child object, using the args passed into this clone method.
+ if {[llength [set constructordef [set o_constructor]]]} {
+ #error
+ puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID"
+ ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args
+
+ }
+
+ }
+
+
+ return $clone
+
+}
+
+
+
+interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?)
+dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}}
+proc ::p::-1::Constructor {_ID_ arglist body} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ #lassign [lindex $invocant 0 ] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ #set iid_top [::p::get_new_object_id]
+
+ #the >interface constructor takes a list of IDs for o_usedby
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+
+ #::p::predator::remap $invocant
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces
+
+
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1
+
+ set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_]
+
+ #set varspaces [::pattern::varspace_list]
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls]
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t runtime_vardecls in Constructor $varDecls"
+ }
+
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #puts stderr ----
+ #puts stderr $body
+ #puts stderr ----
+
+ proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body
+ interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid
+
+
+
+ set o_constructor [list $arglist $body]
+ set o_open 1
+
+ return
+}
+
+
+
+dict set ::p::-1::_iface::o_methods UsedBy {arglist {}}
+proc ::p::-1::UsedBy {_ID_} {
+ return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby]
+}
+
+
+dict set ::p::-1::_iface::o_methods Ready {arglist {}}
+proc ::p::-1::Ready {_ID_} {
+ return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}]
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}}
+
+#'force' 1 indicates object command & variable will also be removed.
+#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var.
+#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4)
+#
+proc ::p::-1::Destroy {_ID_ {force 1}} {
+ #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]"
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+
+ if {$OID eq "null"} {
+ puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_"
+ return
+ }
+
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+
+ #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout
+
+ #explicit Destroy - remove traces
+ #puts ">>TRACES: [trace info variable $cmd]"
+ #foreach tinfo [trace info variable $cmd] {
+ # trace remove variable $cmd {*}$tinfo
+ #}
+ #foreach tinfo [trace info command $cmd] {
+ # trace remove command $cmd {*}$tinfo
+ #}
+
+
+ set _cmd [string map {::> ::} $cmd]
+
+ #set ifaces [lindex $map 1]
+ set iface_stacks [dict get $MAP interfaces level0]
+ #set patterns [lindex $map 2]
+ set pattern_stacks [dict get $MAP interfaces level1]
+
+
+
+ set ifaces $iface_stacks
+
+
+ set patterns $pattern_stacks
+
+
+ #set i 0
+ #foreach iflist $ifaces {
+ # set IFID$i [lindex $iflist 0]
+ # incr i
+ #}
+
+
+ set IFTOP [lindex $ifaces end]
+
+ set DESTRUCTOR ::p::${IFTOP}::___system___destructor
+ #may be a proc, or may be an alias
+ if {[namespace which $DESTRUCTOR] ne ""} {
+ set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}]
+
+ if {[catch {$DESTRUCTOR $temp_ID_} prob]} {
+ #!todo - ensure correct calling order of interfaces referencing the destructor proc
+
+
+ #!todo - emit destructor errors somewhere - logger?
+ #puts stderr "underlying proc already removed??? ---> $prob"
+ #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------"
+ #puts stderr $::errorInfo
+ #puts stderr "---------------------"
+ }
+ }
+
+
+ #remove ourself from each interfaces list of referencers
+ #puts stderr "--- $ifaces"
+
+ foreach var {ifaces patterns} {
+
+ foreach i [set $var] {
+
+ if {[string length $i]} {
+ if {$i == 2} {
+ #skip the >ifinfo interface which doesn't maintain a usedby list anyway.
+ continue
+ }
+
+ if {[catch {
+
+ upvar #0 ::p::${i}::_iface::o_usedby usedby
+
+ array unset usedby i$OID
+
+
+ #puts "\n***>>***"
+ #puts "IFACE: $i usedby: $usedby"
+ #puts "***>>***\n"
+
+ #remove interface if no more referencers
+ if {![array size usedby]} {
+ #puts " **************** DESTROYING unused interface $i *****"
+ #catch {namespace delete ::p::$i}
+
+ #we happen to know where 'interface' object commands are kept:
+
+ ::p::ifaces::>$i .. Destroy
+
+ }
+
+ } errMsg]} {
+ #warning
+ puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg"
+ }
+ }
+
+ }
+
+ }
+
+ set ns ::p::${OID}
+ #puts "-- destroying objects below namespace:'$ns'"
+ ::p::internals::DestroyObjectsBelowNamespace $ns
+ #puts "--.destroyed objects below '$ns'"
+
+
+ #set ns ::p::${OID}::_sub
+ #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace
+ #( ::p::OBJECT::$OID )
+ #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n"
+ #::p::internals::DestroyObjectsBelowNamespace $ns
+
+ #same for _meta objects (e.g Methods,Properties collections)
+ #set ns ::p::${OID}::_meta
+ #::p::internals::DestroyObjectsBelowNamespace $ns
+
+
+
+ #foreach obj [info commands ${ns}::>*] {
+ # #Assume it's one of ours, and ask it to die.
+ # catch {::p::meta::Destroy $obj}
+ # #catch {$cmd .. Destroy}
+ #}
+ #just in case the user created subnamespaces.. kill objects there too.
+ #foreach sub [namespace children $ns] {
+ # ::p::internals::DestroyObjectsBelowNamespace $sub
+ #}
+
+
+ #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value!
+ #use info commands ::p::${OID}::_ref::* to find all references - including variables never set
+ #remove variable traces on REF vars
+ #foreach rv [info vars ::p::${OID}::_ref::*] {
+ # foreach tinfo [trace info variable $rv] {
+ # #puts "-->removing traces on $rv: $tinfo"
+ # trace remove variable $rv {*}$tinfo
+ # }
+ #}
+
+ #!todo - write tests
+ #refs create aliases and variables at the same place
+ #- but variable may not exist if it was never set e.g if it was only used with info exists
+ foreach rv [info commands ::p::${OID}::_ref::*] {
+ foreach tinfo [trace info variable $rv] {
+ #puts "-->removing traces on $rv: $tinfo"
+ trace remove variable $rv {*}$tinfo
+ }
+ }
+
+
+
+
+
+
+
+ #if {[catch {namespace delete $nsMeta} msg]} {
+ # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg "
+ #} else {
+ # #puts stderr "------ -- -- -- -- deleted $nsMeta "
+ #}
+
+
+ #!todo - remove
+ #temp
+ #catch {interp alias "" ::>$OID ""}
+
+ if {$force} {
+ #rename $cmd {}
+
+ #removing the alias will remove the command - even if it's been renamed
+ interp alias {} $alias {}
+
+ #if {[catch {rename $_cmd {} } why]} {
+ # #!todo - work out why some objects don't have matching command.
+ # #puts stderr "\t rename $_cmd {} failed"
+ #} else {
+ # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!"
+ #}
+
+ }
+
+ set refns ::p::${OID}::_ref
+ #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns"
+ #puts "- children: [llength [namespace children $refns]]"
+ #puts "- vars : [llength [info vars ${refns}::*]]"
+ #puts "- commands: [llength [info commands ${refns}::*]]"
+ #puts "- procs : [llength [info procs ${refns}::*]]"
+ #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]"
+ #puts "- matching command: [llength [info commands ${refns}]]"
+ #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns"
+
+
+ #foreach v [info vars ${refns}::*] {
+ # unset $v
+ #}
+ #foreach p [info procs ${refns}::*] {
+ # rename $p {}
+ #}
+ #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] {
+ # interp alias {} $a {}
+ #}
+
+
+ #set ts1 [clock seconds]
+ #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns."
+ #puts "- children: [llength [namespace children $refns]]"
+ #puts "- vars : [llength [info vars ${refns}::*]]"
+
+ #puts "- commands: [llength [info commands ${refns}::*]]"
+ #puts "- procs : [llength [info procs ${refns}::*]]"
+ #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]"
+ #puts "- exact command: [info commands ${refns}]"
+
+
+
+
+ #puts "--delete ::p::${OID}::_ref"
+ if {[namespace exists ::p::${OID}::_ref]} {
+ #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted.
+ namespace delete ::p::${OID}::_ref::
+ }
+ set ts2 [clock seconds]
+ #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]"
+
+
+ #delete namespace where instance variables reside
+ #catch {namespace delete ::p::$OID}
+ namespace delete ::p::$OID
+
+ #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout
+ return
+}
+
+
+interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility
+
+
+dict set ::p::-1::_iface::o_methods Destructor {arglist {args}}
+#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction?
+#install a Destructor on the invocant's open level1 interface.
+proc ::p::-1::Destructor {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ #lassign [lindex $map 0] OID alias itemCmd cmd
+
+ set patterns [dict get $MAP interfaces level1]
+
+ if {[llength $args] > 2} {
+ error "too many arguments to 'Destructor' - expected at most 2 (arglist body)"
+ }
+
+ set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface.
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ error "NOT TESTED"
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+
+ #::p::predator::remap $invocant
+ }
+
+
+ set ::p::${IID}::_iface::o_destructor_body [lindex $args end]
+
+ if {[llength $args] > 1} {
+ #!todo - allow destructor args(?)
+ set arglist [lindex $args 0]
+ } else {
+ set arglist [list]
+ }
+
+ set ::p::${IID}::_iface::o_destructor_args $arglist
+
+ return
+}
+
+
+
+
+
+interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit)
+
+
+dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}}
+proc ::p::-1::PatternMethod {_ID_ method arglist body} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - get 'open' interface.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+
+ namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces
+
+
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID $method]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME $method.$headid ;#first version will be $method.1
+
+ set next [::p::predator::next_script $IID $method $THISNAME $_ID_]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls"
+ set body $varDecls\n[dict get $processed body]
+ #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls"
+ }
+
+
+ set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist]
+
+ #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n]
+ #puts "\t\t--------------------"
+ #puts "\n"
+ #puts $body
+ #puts "\n"
+ #puts "\t\t--------------------"
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body
+
+
+
+ #pointer from method-name to head of the interface's command-chain
+ interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME
+
+
+
+ if {$method in [dict keys $o_methods]} {
+ #error "patternmethod '$method' already present in interface $IID"
+ set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)"
+ if {[string match "*@next@*" $body]} {
+ append msg "\n EXTRA-WARNING: method contains @next@"
+ }
+
+ puts stdout $msg
+ } else {
+ dict set o_methods $method [list arglist $arglist]
+ }
+
+ #::p::-1::update_invocant_aliases $_ID_
+ return
+}
+
+#MultiMethod
+#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants
+# e.g1 $obj .. MultiMethod add {these 2} $arglist $body
+# e.g2 $obj .. MultiMethod add {these n} $arglist $body
+#
+# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body
+#
+# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature.
+# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature)
+# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces)
+# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter?
+# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed?
+# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code?
+# (and how would we define the call order? - presumably as it appears in the conglomerate)
+# (or could that be done with a more general method-wrapping mechanism?)
+#...should multimethods use some sort of event mechanism, and/or message-passing system?
+#
+dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}}
+proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} {
+ set invocants [dict get $_ID_ i]
+
+ error "not implemented"
+}
+
+dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}}
+# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- )
+#we can create a method named "." by using the argprotect operator --
+# e.g >x .. Method -- . {args} $body
+#It can then be called like so: >x . .
+#This is not guaranteed to work and is not in the test suite
+#for now we'll just use a highly unlikely string to indicate no argument was supplied
+proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } {
+ set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped
+ if {$methodname eq $non_argument_magicstring} {
+ return $default_method
+ } else {
+ set extracted_value [dict get $MAP invocantdata]
+ lset extracted_value 2 $methodname
+ dict set MAP invocantdata $extracted_value ;#write modified value back
+ #update the object's command alias to match
+ interp alias {} $alias {} ;#first we must delete it
+ interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}]
+
+ #! $object_command was initially created as the renamed alias - so we have to do it again
+ rename $alias $object_command
+ trace add command $object_command rename [list $object_command .. Rename]
+ return $methodname
+ }
+}
+
+dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}}
+proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } {
+ set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set extracted_patterndata [dict get $MAP patterndata]
+ set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod]
+ if {$methodname eq $non_argument_magicstring} {
+ return $pattern_default_method
+ } else {
+ dict set extracted_patterndata patterndefaultmethod $methodname
+ dict set MAP patterndata $extracted_patterndata
+ return $methodname
+ }
+}
+
+
+dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}}
+proc ::p::-1::Method {_ID_ method arglist bodydef args} {
+ set invocants [dict get $_ID_ i]
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+ set invocant_signature [list] ;
+ ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway.
+ foreach role [lsort [dict keys $invocants]] {
+ lappend invocant_signature $role [llength [dict get $invocants $role]]
+ }
+ #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this')
+
+
+
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command
+ set interfaces [dict get $MAP interfaces level0]
+
+
+
+ #################################################################################
+ if 0 {
+ set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface
+ set prev_open [set ::p::${iid_top}::_iface::o_open]
+
+ set iface ::p::ifaces::>$iid_top
+
+ set f_new 0
+ if {![string length $iid_top]} {
+ set f_new 1
+ } else {
+ if {[$iface . isClosed]} {
+ set f_new 1
+ }
+ }
+ if {$f_new} {
+ #create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+
+ }
+ set IID $iid_top
+
+ }
+ #################################################################################
+
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+
+ #upvar 0 ::p::${IID}:: IFACE
+
+ namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces
+
+
+ #Interface proc
+ # examine the existing command-chain
+ set maxversion [::p::predator::method_chainhead $IID $method]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME $method.$headid ;#first version will be $method.1
+
+ if {$method ni [dict keys $o_methods]} {
+ dict set o_methods $method [list arglist $arglist]
+ }
+
+ #next_script will call to lower interface in iStack if we are $method.1
+ set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_
+ #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<"
+
+
+ #implement
+ #-----------------------------------
+ set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ set varDecls ""
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls\n[dict get $processed body]
+ }
+
+
+ set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist]
+
+
+
+
+
+
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #if {[string length $varDecls]} {
+ # puts stdout "\t---------------------------------------------------------------"
+ # puts stdout "\t----- efficiency warning - implicit var declarations used -----"
+ # puts stdout "\t-------- $object_command .. Method $method $arglist ---------"
+ # puts stdout "\t[string map [list \n \t\t\n] $body]"
+ # puts stdout "\t--------------------------"
+ #}
+ #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role
+ # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position.
+ #(as specified by the @ operator during object conglomeration)
+ #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n]
+
+ #puts stdout "\t\t----------------------------"
+ #puts stdout "$body"
+ #puts stdout "\t\t----------------------------"
+
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body
+
+ #-----------------------------------
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME
+
+
+ #point to the interface command only. The dispatcher will supply the invocant data
+ #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method
+ set argvals ""
+ foreach argspec $arglist {
+ if {[llength $argspec] == 2} {
+ set a [lindex $argspec 0]
+ } else {
+ set a $argspec
+ }
+ if {$a eq "args"} {
+ append argvals " \{*\}\$args"
+ } else {
+ append argvals " \$$a"
+ }
+ }
+ set argvals [string trimleft $argvals]
+ #this proc directly on the object is not *just* a forwarding proc
+ # - it provides a context in which the 'uplevel 1' from the running interface proc runs
+ #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?)
+
+ #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain
+
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst {
+ ::p::${IID}::_iface::$method \$_ID_ $argvals
+ }]
+
+
+ if 0 {
+ if {[llength $argvals]} {
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] {
+ apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@
+ }]
+ } else {
+
+ proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] {
+ apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@
+ }]
+
+ }
+ }
+
+
+ #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst {
+ # ::p::${IID}::_iface::$method \$_ID_ $argvals
+ #}]
+
+ #todo - for o_varspaces
+ #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method
+ #- this should work correctly with the 'uplevel 1' procs in the interfaces
+
+
+ if {[string length $o_varspace]} {
+ if {[string match "::*" $o_varspace]} {
+ namespace eval $o_varspace {}
+ } else {
+ namespace eval ::p::${OID}::$o_varspace {}
+ }
+ }
+
+
+ #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed.
+ set colMethods ::p::${OID}::_meta::>colMethods
+
+ if {[namespace which $colMethods] ne ""} {
+ if {![$colMethods . hasKey $method]} {
+ $colMethods . add [::p::internals::predator $_ID_ . $method .] $method
+ }
+ }
+
+ #::p::-1::update_invocant_aliases $_ID_
+ return
+ #::>pattern .. Create [::>pattern .. Namespace]::>method_???
+ #return $method_object
+}
+
+
+dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}}
+proc ::p::-1::V {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+
+
+ set vlist [list]
+ foreach IID $ifaces {
+ dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] {
+ if {[string match $glob $vname]} {
+ lappend vlist $vname
+ }
+ }
+ }
+
+
+ return $vlist
+}
+
+#experiment from http://wiki.tcl.tk/4884
+proc p::predator::pipeline {args} {
+ set lambda {return -level 0}
+ foreach arg $args {
+ set lambda [list apply [dict get {
+ toupper {{lambda input} {string toupper [{*}$lambda $input]}}
+ tolower {{lambda input} {string tolower [{*}$lambda $input]}}
+ totitle {{lambda input} {string totitle [{*}$lambda $input]}}
+ prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}}
+ suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}}
+ } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]]
+ }
+ return $lambda
+}
+
+proc ::p::predator::get_apply_arg_0_oid {} {
+ set apply_args [lrange [info level 0] 2 end]
+ puts stderr ">>>>> apply_args:'$apply_args'<<<<"
+ set invocant [lindex $apply_args 0]
+ return [lindex [dict get $invocant i this] 0 0]
+}
+proc ::p::predator::get_oid {} {
+ #puts stderr "---->> [info level 1] <<-----"
+ set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2
+ tailcall lindex [dict get $_ID_ i this] 0 0
+}
+
+#todo - make sure this is called for all script installations - e.g propertyread etc etc
+#Add tests to check code runs in correct namespace
+#review - how does 'Varspace' command affect this?
+proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} {
+ #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues)
+ set arglist_apply ""
+ append arglist_apply "\$_ID_ "
+ foreach a $arglist {
+ if {$a eq "args"} {
+ append arglist_apply "{*}\$args"
+ } else {
+ append arglist_apply "\$[lindex $a 0] "
+ }
+ }
+ #!todo - allow fully qualified varspaces
+ if {[string length $varspace]} {
+ if {[string match ::* $varspace]} {
+ return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply"
+ } else {
+ #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n"
+ return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply"
+ }
+ } else {
+ #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n"
+ #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]"
+
+ set script "tailcall apply \[list \{_ID_"
+
+ if {[llength $arglist]} {
+ append script " $arglist"
+ }
+ append script "\} \{"
+ append script $body
+ append script "\} ::p::@OID@\] "
+ append script $arglist_apply
+ #puts stderr "\n88888888888888888888888888\n\t$script\n"
+ #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply"
+ #return $script
+
+
+ #-----------------------------------------------------------------------------
+ # 2018 candidates
+ #
+ #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled
+ #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled
+
+
+ #this has problems with @next@ arguments! (also script variables will possibly interfere with each other)
+ #faster though.
+ #return "uplevel 1 \{$body\}"
+ return "uplevel 1 [list $body]"
+ #-----------------------------------------------------------------------------
+
+
+
+
+ #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply"
+ #return "uplevel 1 \{$script\}"
+
+ #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail
+ #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail
+
+
+
+ #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong
+
+ #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns
+
+
+ #experiment with different dispatch mechanism (interp alias with 'namespace inscope')
+ #-----------
+ #return "apply { {_ID_ $arglist} {$body}} $arglist_apply"
+
+
+ #return "uplevel 1 \{$body\}" ;#do nothing
+
+ #----------
+
+ #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??)
+
+ #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body
+
+ #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker
+
+ #return "tailcall "
+
+
+ }
+}
+
+
+#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies.
+#expand 'var' statements inline in method bodies
+#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements.
+#
+#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces
+#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches!
+# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements.
+#Think of var & varspace statments as a form of compile-time 'macro'
+#
+#caters for 2-element lists as arguments to var statement to allow 'aliasing'
+#e.g var o_thing {o_data mydata}
+# this will upvar o_thing as o_thing & o_data as mydata
+#
+proc ::p::predator::expand_var_statements {rawbody {varspace ""}} {
+ set body {}
+
+ #keep count of any explicit var statments per varspace in 'numDeclared' array
+ # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements.
+
+ #default varspace is ""
+ #varspace should only have leading :: if it is an absolute namespace path.
+
+
+ foreach ln [split $rawbody \n] {
+ set trimline [string trim $ln]
+
+ if {$trimline eq "var"} {
+ #plain var statement alone indicates we don't have any explicit declarations in this branch
+ # and we don't want implicit declarations for the current varspace either.
+ #!todo - implement test
+
+ incr numDeclared($varspace)
+
+ #may be further var statements e.g - in other code branches
+ #return [list body $rawbody varspaces_with_explicit_vars 1]
+ } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} {
+
+ #append body " upvar #0 "
+ #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} "
+ #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} "
+
+ if {$varspace eq ""} {
+ append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] "
+ } else {
+ if {[string match "::*" $varspace]} {
+ append body " namespace upvar $varspace "
+ } else {
+ append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} "
+ }
+ }
+
+ #any whitespace before or betw var names doesn't matter - about to use as list.
+ foreach varspec [string range $trimline 4 end] {
+ lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element.
+ ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias "
+ #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias "
+
+ append body "$var $alias "
+
+ }
+ append body \n
+
+ incr numDeclared($varspace)
+ } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} {
+ #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ???
+ #it is assumed there is a single word following the 'varspace' keyword.
+ set varspace [string trim [string range $trimline 9 end]]
+
+ if {$varspace in [list {{}} {""}]} {
+ set varspace ""
+ }
+ if {[string length $varspace]} {
+ #set varspace ::${varspace}::
+ #no need to initialize numDeclared($varspace) incr will work anyway.
+ #if {![info exists numDeclared($varspace)]} {
+ # set numDeclared($varspace) 0
+ #}
+
+ if {[string match "::*" $varspace]} {
+ append body "namespace eval $varspace {} \n"
+ } else {
+ append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n"
+ }
+
+ #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} "
+ #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n"
+ #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n"
+
+ #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n"
+ }
+ #!review - why? why do we need the magic 'default' name instead of just using the empty string?
+ #if varspace argument was empty string - leave it alone
+ } else {
+ append body $ln\n
+ }
+ }
+
+
+
+ set varspaces [array names numDeclared]
+ return [list body $body varspaces_with_explicit_vars $varspaces]
+}
+
+
+
+
+#Interface Variables
+dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}}
+proc ::p::-1::IV {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+
+ #!todo - test
+ #return [dict keys ::p::${OID}::_iface::o_variables $glob]
+
+ set members [list]
+ foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] {
+ if {[string match $glob $vname]} {
+ lappend members $vname
+ }
+ }
+ return $members
+}
+
+dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}}
+proc ::p::-1::MetaMethods {_ID_ {glob *}} {
+ upvar ::p::-1::_iface::o_methods metaface_methods
+ set metamethod_names [lsort [dict keys $metaface_methods]]
+ if {$glob ne "*"} {
+ set metamethod_names [lsearch -all -inline $metamethod_names $glob]
+ }
+ return $metamethod_names
+}
+
+
+dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}}
+proc ::p::-1::Methods {_ID_ {idx ""}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set col ::p::${OID}::_meta::>colMethods
+
+ if {[namespace which $col] eq ""} {
+ patternlib::>collection .. Create $col
+ foreach IID $ifaces {
+ foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] {
+ if {![$col . hasIndex $m]} {
+ #todo - create some sort of lazy-evaluating method object?
+ #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist]
+ $col . add [::p::internals::predator $_ID_ . $m .] $m
+ }
+ }
+ }
+ }
+ if {[string length $idx]} {
+ return [$col . item $idx]
+ } else {
+ return $col
+ }
+}
+
+dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}}
+proc ::p::-1::M {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set members [list]
+ foreach IID $ifaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob]
+ }
+ return $members
+}
+
+#PatternMethods
+dict set ::p::-1::_iface::o_methods PM {arglist {{glob *}}}
+proc ::p::-1::PM {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+ set members [list]
+ foreach IID $ifaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob]
+ }
+ return [lsort $members]
+}
+
+
+#review
+#Interface Methods
+dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}}
+proc ::p::-1::IM {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ #set map [dict get $this_info map]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ return [dict keys [set ::p::${OID}::_iface::o_methods] $glob]
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}}
+proc ::p::-1::InterfaceStacks {_ID_} {
+ upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP
+ return [dict get $MAP interfaces level0]
+}
+
+
+dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}}
+proc ::p::-1::PatternStacks {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ return [dict get $MAP interfaces level1]
+}
+
+
+#!todo fix. need to account for references which were never set to a value
+dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}}
+proc ::p::-1::DeletePropertyReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ set cleared_references [list]
+ set refvars [info vars ::p::${OID}::_ref::*]
+ #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st.
+ foreach rv $refvars {
+ foreach tinfo [trace info variable $rv] {
+ set ops {}; set cmd {}
+ lassign $tinfo ops cmd
+ trace remove variable $rv $ops $cmd
+ }
+ unset $rv
+ lappend cleared_references $rv
+ }
+
+
+ return [list deleted_property_references $cleared_references]
+}
+
+dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}}
+proc ::p::-1::DeleteMethodReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ set cleared_references [list]
+
+ set iflist [dict get $MAP interfaces level0]
+ set iflist_reverse [lreferse $iflist]
+ #set iflist [dict get $MAP interfaces level0]
+
+
+ set refcommands [info commands ::p::${OID}::_ref::*]
+ foreach c $refcommands {
+ set reftail [namespace tail $c]
+ set field [lindex [split $c +] 0]
+ set field_is_a_method 0
+ foreach IFID $iflist_reverse {
+ if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} {
+ set field_is_a_method 1
+ break
+ }
+ }
+ if {$field_is_a_method} {
+ #what if it's also a property?
+ interp alias {} $c {}
+ lappend cleared_references $c
+ }
+ }
+
+
+ return [list deleted_method_references $cleared_references]
+}
+
+
+dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}}
+proc ::p::-1::DeleteReferences {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method this
+
+ set result [dict create]
+ dict set result {*}[$this .. DeletePropertyReferences]
+ dict set result {*}[$this .. DeleteMethodReferences]
+
+ return $result
+}
+
+##
+#Digest
+#
+#!todo - review
+# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!)
+#
+#!todo - write tests - check that digest changes when properties of contained objects change value
+#
+#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method?
+#
+dict set ::p::-1::_iface::o_methods Digest {arglist {args}}
+proc ::p::-1::Digest {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway.
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] _OID alias default_method this
+
+
+ set interface_ids [dict get $MAP interfaces level0]
+ set IFID0 [lindex $interface_ids end]
+
+ set known_flags {-recursive -algorithm -a -indent}
+ set defaults {-recursive 1 -algorithm md5 -indent ""}
+ if {[dict exists $args -a] && ![dict exists $args -algorithm]} {
+ dict set args -algorithm [dict get $args -a]
+ }
+
+ set opts [dict merge $defaults $args]
+ foreach key [dict keys $opts] {
+ if {$key ni $known_flags} {
+ error "unknown option $key. Expected only: $known_flags"
+ }
+ }
+
+
+ set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256}
+ if {[dict get $opts -algorithm] ni $known_algos} {
+ error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos"
+ }
+ set algo [string tolower [dict get $opts -algorithm]]
+
+ # append comma for each var so that all changes in adjacent vars detectable.
+ # i.e set x 34; set y 5
+ # must be distinguishable from:
+ # set x 3; set y 45
+
+ if {[dict get $opts -indent] ne ""} {
+ set state ""
+ set indent "[dict get $opts -indent]"
+ } else {
+ set state "---\n"
+ set indent " "
+ }
+ append state "${indent}object_command: $this\n"
+ set indent "${indent} "
+
+ #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state.
+ append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state.
+
+
+
+
+ #!todo - recurse into 'varspaces'
+ set varspaces_found [list]
+ append state "${indent}interfaces:\n"
+ foreach IID $interface_ids {
+ append state "${indent} - interface: $IID\n"
+ namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces
+ append state "${indent} varspaces:\n"
+ foreach vs $local_o_varspaces {
+ if {$vs ni $varspaces_found} {
+ lappend varspaces_found $vs
+ append state "${indent} - varspace: $vs\n"
+ }
+ }
+ }
+
+ append state "${indent}vars:\n"
+ foreach var [info vars ::p::${OID}::*] {
+ append state "${indent} - [namespace tail $var] : \""
+ if {[catch {append state "[set $var]"}]} {
+ append state "[array get $var]"
+ }
+ append state "\"\n"
+ }
+
+ if {[dict get $opts -recursive]} {
+ append state "${indent}sub-objects:\n"
+ set subargs $args
+ dict set subargs -indent "$indent "
+ foreach obj [info commands ::p::${OID}::>*] {
+ append state "[$obj .. Digest {*}$subargs]\n"
+ }
+
+ append state "${indent}sub-namespaces:\n"
+ set subargs $args
+ dict set subargs -indent "$indent "
+ foreach ns [namespace children ::p::${OID}] {
+ append state "${indent} - namespace: $ns\n"
+ foreach obj [info commands ${ns}::>*] {
+ append state "[$obj .. Digest {*}$subargs]\n"
+ }
+ }
+ }
+
+
+ if {$algo in {"" raw none}} {
+ return $state
+ } else {
+ if {$algo eq "md5"} {
+ package require md5
+ return [::md5::md5 -hex $state]
+ } elseif {$algo eq "sha256"} {
+ package require sha256
+ return [::sha2::sha256 -hex $state]
+ } elseif {$algo eq "blowfish"} {
+ package require patterncipher
+ patterncipher::>blowfish .. Create >b1
+ set [>b1 . key .] 12341234
+ >b1 . encrypt $state -final 1
+ set result [>b1 . ciphertext]
+ >b1 .. Destroy
+
+ } elseif {$algo eq "blowfish-binary"} {
+
+ } else {
+ error "can't get here"
+ }
+
+ }
+}
+
+
+dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}}
+proc ::p::-1::Variable {_ID_ varname args} {
+ set invocants [dict get $_ID_ i]
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ #this interface itself is always a co-invocant
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set interfaces [dict get $MAP interfaces level0]
+
+ #set existing_IID [lindex $map 1 0 end]
+ set existing_IID [lindex $interfaces end]
+
+ set prev_openstate [set ::p::${existing_IID}::_iface::o_open]
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #IID changed
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+
+ #update original object command
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set ::p::${IID}::_iface::o_open $prev_openstate
+ }
+
+ set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface)
+
+ if {[llength $args]} {
+ #!assume var not already present on interface - it is an error to define twice (?)
+ #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]]
+ dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace]
+
+
+ #Implement if there is a default
+ #!todo - correct behaviour when overlaying on existing object with existing var of this name?
+ #if {[string length $varspace]} {
+ # set ::p::${OID}::${varspace}::$varname [lindex $args 0]
+ #} else {
+ set ::p::${OID}::$varname [lindex $args 0]
+ #}
+ } else {
+ #lappend ::p::${IID}::_iface::o_variables [list $varname]
+ dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace]
+ }
+
+ #varspace '_iface'
+
+ return
+}
+
+
+#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility
+
+dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}}
+proc ::p::-1::PatternVariable {_ID_ varname args} {
+ set invocants [dict get $_ID_ i]
+
+ #set invocant_alias [lindex [dict get $invocants this] 0]
+ #set invocant [lindex [interp alias {} $invocant_alias] 1]
+ ##this interface itself is always a co-invocant
+ #lassign [lindex $invocant 0 ] OID alias itemCmd cmd
+
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end] ;#!todo - get 'open' interface.
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+ }
+ set IID $iid_top
+
+ set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified.
+
+
+ if {[llength $args]} {
+ #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]]
+ dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace]
+ } else {
+ dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace]
+ }
+
+ return
+}
+
+dict set ::p::-1::_iface::o_methods Varspaces {arglist args}
+proc ::p::-1::Varspaces {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ if {![llength $args]} {
+ #query
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ set iface ::p::ifaces::>$iid_top
+ if {![string length $iid_top]} {
+ error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] "
+ } elseif {[$iface . isClosed]} {
+ error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] "
+ }
+ return [set ::p::${iid_top}::_iface::o_varspaces]
+ }
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+
+ set varspaces $args
+ foreach vs $varspaces {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ if {[string match ::* $vs} {
+ namespace eval $vs {}
+ } else {
+ namespace eval ::p::${OID}::$vs {}
+ }
+ lappend o_varspaces $vs
+ }
+ }
+ return $o_varspaces
+}
+
+#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface
+dict set ::p::-1::_iface::o_methods Varspace {arglist args}
+# set the default varspace for the interface, so that new methods/properties refer to it.
+# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces.
+proc ::p::-1::Varspace {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ if {![llength $args]} {
+ #query
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ set iface ::p::ifaces::>$iid_top
+ if {![string length $iid_top]} {
+ error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] "
+ } elseif {[$iface . isClosed]} {
+ error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] "
+ }
+ return [set ::p::${iid_top}::_iface::o_varspace]
+ }
+ set varspace [lindex $args 0]
+
+ #set interfaces [dict get $MAP interfaces level0]
+ #set iid_top [lindex $interfaces end]
+
+ set IID [::p::predator::get_possibly_new_open_interface $OID]
+
+
+ #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+
+ if {[string length $varspace]} {
+ #ensure namespace exists !? do after list test?
+ if {[string match ::* $varspace]} {
+ namespace eval $varspace {}
+ } else {
+ namespace eval ::p::${OID}::$varspace {}
+ }
+ if {$varspace ni $o_varspaces} {
+ lappend o_varspaces $varspace
+ }
+ }
+ set o_varspace $varspace
+}
+
+
+proc ::p::predator::get_possibly_new_open_interface {OID} {
+ #we need to re-upvar MAP rather than using a parameter - as we need to write back to it
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+
+
+ set iface ::p::ifaces::>$iid_top
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ #puts stderr ">>>>creating new interface $iid_top"
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+
+ return $iid_top
+}
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}}
+# set the default varspace for the interface, so that new methods/properties refer to it.
+# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces.
+proc ::p::-1::PatternVarspace {_ID_ varspace args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end]
+
+ set iface ::p::ifaces::>$iid_top
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #no existing pattern - create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces
+ if {[string length $varspace]} {
+ if {$varspace ni $o_varspaces} {
+ lappend o_varspaces $varspace
+ }
+ }
+ #o_varspace is the currently active varspace
+ set o_varspace $varspace
+
+}
+###################################################################################################################################################
+
+#get varspace and default from highest interface - return all interface ids which define it
+dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}}
+proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0]
+
+ array set propinfo {}
+ set found_property_names [list]
+ #start at the lowest and work up (normal storage order of $interfaces)
+ foreach iid $interfaces {
+ set propinfodict [set ::p::${iid}::_iface::o_properties]
+ set matching_propnames [dict keys $propinfodict $propnamepattern]
+ foreach propname $matching_propnames {
+ if {$propname ni $found_property_names} {
+ lappend found_property_names $propname
+ }
+ lappend propinfo($propname,interfaces) $iid
+ ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one
+ if {[dict exists $propinfodict $propname default]} {
+ set propinfo($propname,default) [dict get $propinfodict $propname default]
+ }
+ set propinfo($propname,varspace) [dict get $propinfodict $propname varspace]
+ }
+ }
+
+ set resultdict [dict create]
+ foreach propname $found_property_names {
+ set fields [list varspace $propinfo($propname,varspace)]
+ if {[array exists propinfo($propname,default)]} {
+ lappend fields default [set propinfo($propname,default)]
+ }
+ lappend fields interfaces $propinfo($propname,interfaces)
+ dict set resultdict $propname $fields
+ }
+ return $resultdict
+}
+
+
+dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args}
+proc ::p::-1::GetTopPattern {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level1]
+ set iid_top [lindex $interfaces end]
+ if {![string length $iid_top]} {
+ lassign [dict get $MAP invocantdata] OID _alias _default_method object_command
+ error "No installed level1 interfaces (patterns) for object $object_command"
+ }
+ return ::p::ifaces::>$iid_top
+}
+
+
+
+dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args}
+proc ::p::-1::GetTopInterface {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set iid_top [lindex [dict get $MAP interfaces level0] end]
+ if {![string length $iid_top]} {
+ lassign [dict get $MAP invocantdata] OID _alias _default_method object_command
+ error "No installed level0 interfaces for object $object_command"
+ }
+ return ::p::ifaces::>$iid_top
+}
+
+
+dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args}
+proc ::p::-1::GetExpandableInterface {_ID_ args} {
+
+}
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods Property {arglist {property args}}
+proc ::p::-1::Property {_ID_ property args} {
+ #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args"
+ #set invocants [dict get $_ID_ i]
+ #set invocant_roles [dict keys $invocants]
+ if {[llength $args] > 1} {
+ error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)"
+ }
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set iid_top [lindex $interfaces end]
+
+ set prev_openstate [set ::p::${iid_top}::_iface::o_open]
+
+ set iface ::p::ifaces::>$iid_top
+
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ #create a new interface
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat $interfaces $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ }
+ set IID $iid_top
+
+
+ namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+
+
+ if {$headid == 1} {
+ #implementation
+ #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property
+
+ #if {$o_varspace eq ""} {
+ # set ns ::p::${OID}
+ #} else {
+ # if {[string match "::*" $o_varspace]} {
+ # set ns $o_varspace
+ # } else {
+ # set ns ::p::${OID}::$o_varspace
+ # }
+ #}
+ #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]]
+
+ proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]]
+
+
+ #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property
+ proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]]
+
+
+ #chainhead pointers
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1
+
+
+ }
+
+ if {($property ni [dict keys $o_methods])} {
+ interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+
+
+
+ #installation on object
+
+ #namespace eval ::p::${OID} [list namespace export $property]
+
+
+
+ #obsolete?
+ #if {$property ni [P $_ID_]} {
+ #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces
+ #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant
+ #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant
+ #}
+
+ #link main (GET)/(SET) to this interface
+ interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property
+ interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property
+
+ #Only install property if no method of same name already installed here.
+ #(Method takes precedence over property because property always accessible via 'set' reference)
+ #convenience pointer to chainhead pointer.
+ if {$property ni [M $_ID_]} {
+ interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property
+ } else {
+ #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed
+
+
+ }
+
+
+ set varspace [set ::p::${IID}::_iface::o_varspace]
+
+
+
+ #Install the matching Variable
+ #!todo - which should take preference if Variable also given a default?
+ #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} {
+ # set o_variables [lreplace $o_variables $posn $posn o_$property]
+ #} else {
+ # lappend o_variables [list o_$property]
+ #}
+ dict set o_variables o_$property [list varspace $varspace]
+
+
+
+
+ if {[llength $args]} {
+ #should store default once only!
+ #set IFINFO(v,default,o_$property) $default
+
+ set default [lindex $args end]
+
+ dict set o_properties $property [list default $default varspace $varspace]
+
+ #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} {
+ # set o_properties [lreplace $o_properties $posn $posn [list $property $default]]
+ #} else {
+ # lappend o_properties [list $property $default]
+ #}
+
+ if {$varspace eq ""} {
+ set ns ::p::${OID}
+ } else {
+ if {[string match "::*" $varspace]} {
+ set ns $varspace
+ } else {
+ set ns ::p::${OID}::$o_varspace
+ }
+ }
+
+ set ${ns}::o_$property $default
+ #set ::p::${OID}::o_$property $default
+ } else {
+
+ #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} {
+ # set o_properties [lreplace $o_properties $posn $posn [list $property]]
+ #} else {
+ # lappend o_properties [list $property]
+ #}
+ dict set o_properties $property [list varspace $varspace]
+
+
+ #variable ::p::${OID}::o_$property
+ }
+
+
+
+
+
+ #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed.
+ #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?)
+ #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property}
+
+ set colProperties ::p::${OID}::_meta::>colProperties
+ if {[namespace which $colProperties] ne ""} {
+ if {![$colProperties . hasKey $property]} {
+ $colProperties . add [::p::internals::predator $_ID_ . $property .] $property
+ }
+ }
+
+ return
+}
+###################################################################################################################################################
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility
+dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}}
+proc ::p::-1::PatternProperty {_ID_ property args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ set patterns [dict get $MAP interfaces level1]
+ set iid_top [lindex $patterns end]
+
+ set iface ::p::ifaces::>$iid_top
+
+ if {(![string length $iid_top]) || ([$iface . isClosed])} {
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat $patterns $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat $patterns $iid_top]
+ }
+ set IID $iid_top
+
+ namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+
+
+
+ if {$headid == 1} {
+ #implementation
+ #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property
+ proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]]
+ #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property
+ proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]]
+
+
+ #chainhead pointers
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1
+
+ }
+
+ if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} {
+ interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+
+ set varspace [set ::p::${IID}::_iface::o_varspace]
+
+ #Install the matching Variable
+ #!todo - which should take preference if Variable also given a default?
+ #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} {
+ # set o_variables [lreplace $o_variables $posn $posn o_$property]
+ #} else {
+ # lappend o_variables [list o_$property]
+ #}
+ dict set o_variables o_$property [list varspace $varspace]
+
+ set argc [llength $args]
+
+ if {$argc} {
+ if {$argc == 1} {
+ set default [lindex $args 0]
+ dict set o_properties $property [list default $default varspace $varspace]
+ } else {
+ #if more than one arg - treat as a dict of options.
+ if {[dict exists $args -default]} {
+ set default [dict get $args -default]
+ dict set o_properties $property [list default $default varspace $varspace]
+ } else {
+ #no default value
+ dict set o_properties $property [list varspace $varspace]
+ }
+ }
+ #! only set default for property... not underlying variable.
+ #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]]
+ } else {
+ dict set o_properties $property [list varspace $varspace]
+ }
+ return
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}}
+proc ::p::-1::PatternPropertyRead {_ID_ property args} {
+ set invocants [dict get $_ID_ i]
+
+ set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this'
+ set OID [lindex $this_invocant 0]
+ #set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias defaut_command cmd
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end]
+
+ set idxlist [::list]
+ if {[llength $args] == 1} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args idxlist body
+ } else {
+ error "wrong # args: should be \"property body\" or \"property idxlist body\""
+ }
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ if {$headid == 1} {
+ set headid 2 ;#reserve 1 for the getprop of the underlying property
+ }
+
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1
+ set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_
+
+
+ #implement
+ #-----------------------------------
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ #implementation
+ if {![llength $idxlist]} {
+ proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body
+ } else {
+ #what are we trying to achieve here? ..
+ proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body
+ }
+
+
+ #-----------------------------------
+
+
+ #adjust chain-head pointer to point to new head.
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid
+
+ return
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}}
+proc ::p::-1::PropertyRead {_ID_ property args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+
+ #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead)
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end]
+
+
+ set idxlist [::list]
+ if {[llength $args] == 1} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args idxlist body
+ } else {
+ error "wrong # args: should be \"property body\" or \"property idxlist body\""
+ }
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd]
+
+
+ set maxversion [::p::predator::method_chainhead $IID (GET)$property]
+ set headid [expr {$maxversion + 1}]
+ if {$headid == 1} {
+ set headid 2
+ }
+ set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself)
+
+ set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_]
+
+ #implement
+ #-----------------------------------
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body
+
+ #-----------------------------------
+
+
+
+ #pointer from prop-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid
+
+
+ interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name.
+ if {$property ni [M $_ID_]} {
+ interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property
+ }
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}}
+proc ::p::-1::PropertyWrite {_ID_ property argname body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface.
+
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace
+
+ #pw short for propertywrite
+ #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd]
+ array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property]
+
+
+ set maxversion [::p::predator::method_chainhead $IID (SET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (SET)$property.$headid
+
+ set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_]
+
+ #implement
+ #-----------------------------------
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+
+ proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body
+
+ #-----------------------------------
+
+
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}}
+proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface.
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set existing_ifaces [lindex $map 1 1]
+ set posn [lsearch $existing_ifaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID]
+
+ #set ::p::${IID}::_iface::o_open 0
+ } else {
+ }
+
+ #pw short for propertywrite
+ array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd]
+
+
+
+
+ return
+
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}}
+proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_command cmd
+
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand.
+
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ } else {
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+ namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers
+ #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers
+ dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern]
+
+ set maxversion [::p::predator::method_chainhead $IID (UNSET)$property]
+ set headid [expr {$maxversion + 1}]
+
+ set THISNAME (UNSET)$property.$headid
+
+ set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_]
+
+
+ set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]]
+ if {[llength [dict get $processed varspaces_with_explicit_vars]]} {
+ foreach vs [dict get $processed varspaces_with_explicit_vars] {
+ if {[string length $vs] && ($vs ni $o_varspaces)} {
+ lappend o_varspaces $vs
+ }
+ }
+ set body [dict get $processed body]
+ } else {
+ set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object.
+ set body $varDecls[dict get $processed body]
+ }
+ #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n]
+ set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n]
+
+ #note $arraykeypattern actually contains the name of the argument
+ if {[string trim $arraykeypattern] eq ""} {
+ set arraykeypattern _dontcare_ ;#
+ }
+ proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body
+
+ #-----------------------------------
+
+
+ #pointer from method-name to head of override-chain
+ interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid
+
+}
+###################################################################################################################################################
+
+
+
+
+
+
+
+
+###################################################################################################################################################
+
+###################################################################################################################################################
+dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}}
+proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #set ::p::${IID}::_iface::o_open 0
+ }
+
+
+ upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers
+ dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern]
+
+ return
+}
+###################################################################################################################################################
+
+
+
+#lappend ::p::-1::_iface::o_methods Implements
+#!todo - some way to force overriding of any abstract (empty) methods from the source object
+#e.g leave interface open and raise an error when closing it if there are unoverridden methods?
+
+
+
+
+
+#implementation reuse - sugar for >object .. Clone >target
+dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}}
+proc ::p::-1::Extends {_ID_ pattern} {
+ if {!([string range [namespace tail $pattern] 0 0] eq ">")} {
+ error "'Extends' expected a pattern object"
+ }
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd object_command
+
+
+ tailcall $pattern .. Clone $object_command
+
+}
+#implementation reuse - sugar for >pattern .. Create >target
+dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}}
+proc ::p::-1::PatternExtends {_ID_ pattern} {
+ if {!([string range [namespace tail $pattern] 0 0] eq ">")} {
+ error "'PatternExtends' expected a pattern object"
+ }
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd object_command
+
+
+ tailcall $pattern .. Create $object_command
+}
+
+
+dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}}
+proc ::p::-1::Extend {_ID_ {idx ""}} {
+ puts stderr "Extend is DEPRECATED - use Expand instead"
+ tailcall ::p::-1::Expand $_ID_ $idx
+}
+
+#set the topmost interface on the iStack to be 'open'
+dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}}
+proc ::p::-1::Expand {_ID_ {idx ""}} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set iid_top [lindex $interfaces end]
+ set iface ::p::ifaces::>$iid_top
+
+ if {![string length $iid_top]} {
+ #no existing interface - create a new one
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [list $iid_top]
+ dict set MAP interfaces $extracted_sub_dict ;#write new interface into map
+ $iface . open
+ return $iid_top
+ } else {
+ if {[$iface . isOpen]} {
+ #already open..
+ #assume ready to expand.. shared or not!
+ return $iid_top
+ }
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ if {[$iface . refCount] > 1} {
+ if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} {
+ #!warning! not exercised by test suites!
+
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${iid_top}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ #remove existing interface & add
+ set posn [lsearch $interfaces $iid_top]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+
+ set iid_top $IID
+ set iface ::p::ifaces::>$iid_top
+ }
+ }
+ }
+
+ $iface . open
+ return $iid_top
+}
+
+dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}}
+proc ::p::-1::PatternExtend {_ID_ {idx ""}} {
+ puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead"
+ tailcall ::p::-1::PatternExpand $_ID_ $idx
+}
+
+
+
+#set the topmost interface on the pStack to be 'open' if it's not shared
+# if shared - 'copylink' to new interface before opening for extension
+dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}}
+proc ::p::-1::PatternExpand {_ID_ {idx ""}} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ ::p::map $OID MAP
+ #puts stderr "no tests written for PatternExpand "
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+ set iid_top [lindex $ifaces end]
+ set iface ::p::ifaces::>$iid_top
+
+ if {![string length $iid_top]} {
+ #no existing interface - create a new one
+ set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id
+ set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [list $iid_top]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [list $iid_top]
+ $iface . open
+ return $iid_top
+ } else {
+ if {[$iface . isOpen]} {
+ #already open..
+ #assume ready to expand.. shared or not!
+ return $iid_top
+ }
+
+ if {[$iface . refCount] > 1} {
+ if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} {
+ #!WARNING! not exercised by test suite!
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${iid_top}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $ifaces $iid_top]
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID]
+
+ set iid_top $IID
+ set iface ::p::ifaces::>$iid_top
+ }
+ }
+ }
+
+ $iface . open
+ return $iid_top
+}
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}}
+proc ::p::-1::Properties {_ID_ {idx ""}} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set col ::p::${OID}::_meta::>colProperties
+
+ if {[namespace which $col] eq ""} {
+ patternlib::>collection .. Create $col
+ foreach IID $ifaces {
+ dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] {
+ if {![$col . hasIndex $prop]} {
+ $col . add [::p::internals::predator $_ID_ . $prop .] $prop
+ }
+ }
+ }
+ }
+
+ if {[string length $idx]} {
+ return [$col . item $idx]
+ } else {
+ return $col
+ }
+}
+
+dict set ::p::-1::_iface::o_methods P {arglist {{glob *}}}
+proc ::p::-1::P {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+
+ set members [list]
+ foreach IID $interfaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob]
+ }
+ return [lsort $members]
+}
+
+#PatternProperties
+dict set ::p::-1::_iface::o_methods PP {arglist {{glob *}}}
+proc ::p::-1::PP {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set this_invocant [lindex [dict get $invocants this] 0]
+ lassign $this_invocant OID _etc
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces
+
+ set members [list]
+ foreach IID $interfaces {
+ lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob]
+ }
+ return [lsort $members]
+}
+
+
+
+#Interface Properties
+dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}}
+proc ::p::-1::IP {_ID_ {glob *}} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces
+ set members [list]
+
+ foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] {
+ if {[string match $glob [lindex $m 0]]} {
+ lappend members [lindex $m 0]
+ }
+ }
+ return $members
+}
+
+
+#used by rename.test - theoretically should be on a separate interface!
+dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}}
+proc ::p::-1::CheckInvocants {_ID_ args} {
+ #check all invocants in the _ID_ are consistent with data stored in their MAP variable
+ set status "ok" ;#default to optimistic assumption
+ set problems [list]
+
+ set invocant_dict [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocant_dict]
+
+ foreach role $invocant_roles {
+ set invocant_list [dict get $invocant_dict $role]
+ foreach aliased_invocantdata $invocant_list {
+ set OID [lindex $aliased_invocantdata 0]
+ set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata]
+ #we use lrange to make sure the lists are in canonical form
+ if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} {
+ set status "not-ok"
+ lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata]
+ }
+ }
+
+ }
+
+
+ set result [dict create]
+ dict set result status $status
+ dict set result problems $problems
+
+ return $result
+}
+
+
+#get or set t
+dict set ::p::-1::_iface::o_methods Namespace {arglist {args}}
+proc ::p::-1::Namespace {_ID_ args} {
+ #set invocants [dict get $_ID_ i]
+ #set this_invocant [lindex [dict get $invocants this] 0]
+ #lassign $this_invocant OID this_info
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ set IID [lindex [dict get $MAP interfaces level0] end]
+
+ namespace upvar ::p::${IID}::_iface o_varspace active_varspace
+
+ if {[string length $active_varspace]} {
+ set ns ::p::${OID}::$active_varspace
+ } else {
+ set ns ::p::${OID}
+ }
+
+ #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object?
+ # - should .. Namespace be usable at all from outside the object?
+
+
+ if {[llength $args]} {
+ #special case some of the namespace subcommands.
+
+ #delete
+ if {[string match "d*" [lindex $args 0]]} {
+ error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object."
+ }
+ #upvar,ensemble,which,code,origin,expor,import,forget
+ if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} {
+ return [namespace eval $ns [list namespace {*}$args]]
+ }
+ #current
+ if {[string match "cu*" [lindex $args 0]]} {
+ return $ns
+ }
+
+ #children,eval,exists,inscope,parent,qualifiers,tail
+ return [namespace {*}[linsert $args 1 $ns]]
+ } else {
+ return $ns
+ }
+}
+
+
+
+
+
+
+
+
+
+
+dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}}
+proc ::p::-1::PatternUnknown {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ set patterns [dict get $MAP interfaces level1]
+ set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand.
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $patterns $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID]
+ #::p::predator::remap $invocant
+ }
+
+ set handlermethod [lindex $args 0]
+
+
+ if {[llength $args]} {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ return
+ } else {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ }
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Unknown {arglist {args}}
+proc ::p::-1::Unknown {_ID_ args} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ set interfaces [dict get $MAP interfaces level0]
+ set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand.
+
+ set prev_open [set ::p::${existing_IID}::_iface::o_open]
+
+ if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} {
+ #remove ourself from the usedby list of the previous interface
+ array unset ::p::${existing_IID}::_iface::o_usedby i$OID
+ set ::p::${IID}::_iface::o_usedby(i$OID) $cmd
+
+ set posn [lsearch $interfaces $existing_IID]
+
+ set extracted_sub_dict [dict get $MAP interfaces]
+ dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID]
+ dict set MAP interfaces $extracted_sub_dict
+ #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID]
+
+ set ::p::${IID}::_iface::o_open 0
+ } else {
+ set ::p::${IID}::_iface::o_open $prev_open
+ }
+
+ set handlermethod [lindex $args 0]
+
+ if {[llength $args]} {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ #set ::p::${IID}::(unknown) $handlermethod
+
+
+ #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod
+ interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod
+ interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod
+
+ #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod]
+ #namespace eval ::p::${OID} [list namespace unknown $handlermethod]
+
+ return
+ } else {
+ set ::p::${IID}::_iface::o_unknown $handlermethod
+ }
+
+}
+
+
+#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []'
+# should also work for non-object results
+dict set ::p::-1::_iface::o_methods As {arglist {varname}}
+proc ::p::-1::As {_ID_ varname} {
+ set invocants [dict get $_ID_ i]
+ #puts stdout "invocants: $invocants"
+ #!todo - handle multiple invocants with other roles, not just 'this'
+
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ tailcall set $varname $cmd
+ } else {
+ #puts stdout "info level 1 [info level 1]"
+ set role_members [dict get $_ID_ i this]
+ if {[llength $role_members] == 1} {
+ set member [lindex $role_members 0]
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ tailcall set $varname $stackvalue
+ } else {
+ #multiple invocants - return all results as a list
+ set resultlist [list]
+ foreach member $role_members {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ lappend resultlist $stackvalue
+ }
+ tailcall set $varname $resultlist
+ }
+ }
+}
+
+#!todo - AsFileStream ??
+dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}}
+proc ::p::-1::AsFile {_ID_ filename args} {
+ dict set default -force 0
+ dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object
+ set opts [dict merge $default $args]
+ set force [dict get $opts -force]
+ set dumpmethod [dict get $opts -dumpmethod]
+
+
+ if {[file pathtype $filename] eq "relative"} {
+ set filename [pwd]/$filename
+ }
+ set filedir [file dirname $filename]
+ if {![sf::file_writable $filedir]} {
+ error "(method AsFile) ERROR folder $filedir is not writable"
+ }
+ if {[file exists $filename]} {
+ if {!$force} {
+ error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite"
+ }
+ if {![sf::file_writable $filename]} {
+ error "(method AsFile) ERROR file $filename is not writable - check permissions"
+ }
+ }
+ set fd [open $filename w]
+ fconfigure $fd -translation binary
+
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+ #tailcall set $varname $cmd
+ set object_data [$cmd {*}$dumpmethod]
+ puts -nonewline $fd $object_data
+ close $fd
+ return [list status 1 bytes [string length $object_data] filename $filename]
+ } else {
+ #puts stdout "info level 1 [info level 1]"
+ set role_members [dict get $_ID_ i this]
+ if {[llength $role_members] == 1} {
+ set member [lindex $role_members 0]
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ puts -nonewline $fd $stackvalue
+ close $fd
+ #tailcall set $varname $stackvalue
+ return [list status 1 bytes [string length $stackvalue] filename $filename]
+ } else {
+ #multiple invocants - return all results as a list
+ set resultlist [list]
+ foreach member $role_members {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ lappend resultlist $stackvalue
+ }
+ puts -nonewline $fd $resultset
+ close $fd
+ return [list status 1 bytes [string length $resultset] filename $filename]
+ #tailcall set $varname $resultlist
+ }
+ }
+
+}
+
+
+
+dict set ::p::-1::_iface::o_methods Object {arglist {}}
+proc ::p::-1::Object {_ID_} {
+ set invocants [dict get $_ID_ i]
+ set OID [lindex [dict get $invocants this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ set result [string map [list ::> ::] $cmd]
+ if {![catch {info level -1} prev_level]} {
+ set called_by "(called by: $prev_level)"
+ } else {
+ set called_by "(called by: interp?)"
+
+ }
+
+ puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n"
+ puts stdout " (returning $result)"
+
+ return $result
+}
+
+#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname
+dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}}
+proc ::p::-1::MakeAlias {_ID_cmdname } {
+ set OID [::p::obj_get_this_oid $_ID_]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias itemCmd cmd
+
+ error "concept probably won't work - try making dispatcher understand trailing '= cmdname' "
+}
+dict set ::p::-1::_iface::o_methods ID {arglist {}}
+proc ::p::-1::ID {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ return $OID
+}
+
+dict set ::p::-1::_iface::o_methods IFINFO {arglist {}}
+proc ::p::-1::IFINFO {_ID_} {
+ puts stderr "--_ID_: $_ID_--"
+ set OID [::p::obj_get_this_oid $_ID_]
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+ puts stderr "-- MAP: $MAP--"
+
+ set interfaces [dict get $MAP interfaces level0]
+ set IFID [lindex $interfaces 0]
+
+ if {![llength $interfaces]} {
+ puts stderr "No interfaces present at level 0"
+ } else {
+ foreach IFID $interfaces {
+ set iface ::p::ifaces::>$IFID
+ puts stderr "$iface : [$iface --]"
+ puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]"
+ set variables [set ::p::${IFID}::_iface::o_variables]
+ puts stderr "\tvariables: $variables"
+ }
+ }
+
+}
+
+
+
+
+dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}}
+proc ::p::-1::INVOCANTDATA {_ID_} {
+ #same as a call to: >object ..
+ return $_ID_
+}
+
+#obsolete?
+dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}}
+proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} {
+ set updated_ID_ $_ID_
+ array set updated_roles [list]
+
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants]
+ foreach role $invocant_roles {
+
+ set role_members [dict get $invocants $role]
+ foreach member [dict get $invocants $role] {
+ #each member is a 2-element list consisting of the OID and a dictionary
+ #each member is a 5-element list
+ #set OID [lindex $member 0]
+ #set object_dict [lindex $member 1]
+ lassign $member OID alias itemcmd cmd wrapped
+
+ set MAP [set ::p::${OID}::_meta::map]
+ #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {}
+
+ if {[dict get $MAP invocantdata] eq $member}
+ #same - nothing to do
+
+ } else {
+ package require overtype
+ puts stderr "---------------------------------------------------------"
+ puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version"
+ set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]]
+ puts stderr "[overtype::left $col1 {_ID_ map value}]: $member"
+ puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]"
+ puts stderr "---------------------------------------------------------"
+ #take _meta::map version
+ lappend updated_roles($role) [dict get $MAP invocantdata]
+ }
+
+ }
+
+ #overwrite changed roles only
+ foreach role [array names updated_roles] {
+ dict set updated_ID_ i $role [set updated_roles($role)]
+ }
+
+ return $updated_ID_
+}
+
+
+
+dict set ::p::-1::_iface::o_methods INFO {arglist {}}
+proc ::p::-1::INFO {_ID_} {
+ set result ""
+ append result "_ID_: $_ID_\n"
+
+ set invocants [dict get $_ID_ i]
+ set invocant_roles [dict keys $invocants]
+ append result "invocant roles: $invocant_roles\n"
+ set total_invocants 0
+ foreach key $invocant_roles {
+ incr total_invocants [llength [dict get $invocants $key]]
+ }
+
+ append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n"
+ foreach key $invocant_roles {
+ append result "\t-------------------------------\n"
+ append result "\trole: $key\n"
+ set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants
+ append result "\t Raw data for this role: $role_members\n"
+ append result "\t Number of invocants in this role: [llength $role_members]\n"
+ foreach member $role_members {
+ #set OID [lindex [dict get $invocants $key] 0 0]
+ set OID [lindex $member 0]
+ append result "\t\tOID: $OID\n"
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ append result "\t\tmap:\n"
+ foreach key [dict keys $MAP] {
+ append result "\t\t\t$key\n"
+ append result "\t\t\t\t [dict get $MAP $key]\n"
+ append result "\t\t\t----\n"
+ }
+ lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped
+ append result "\t\tNamespace: $namespace\n"
+ append result "\t\tDefault method: $default_method\n"
+ append result "\t\tCommand: $cmd\n"
+ append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n"
+ append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n"
+ append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n"
+ } else {
+ lassign $member _OID namespace default_method stackvalue _wrapped
+ append result "\t\t last item on the predator stack is a value not an object"
+ append result "\t\t Value is: $stackvalue"
+
+ }
+ }
+ append result "\n"
+ append result "\t-------------------------------\n"
+ }
+
+
+
+ return $result
+}
+
+
+
+
+dict set ::p::-1::_iface::o_methods Rename {arglist {args}}
+proc ::p::-1::Rename {_ID_ args} {
+ set OID [::p::obj_get_this_oid $_ID_]
+ if {![llength $args]} {
+ error "Rename expected \$newname argument"
+ }
+
+ #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant?
+ upvar #0 ::p::${OID}::_meta::map MAP
+
+
+
+ #puts ">>.>> Rename. _ID_: $_ID_"
+
+ if {[catch {
+
+ if {([llength $args] == 3) && [lindex $args 2] eq "rename"} {
+
+ #appears to be a 'trace command rename' firing
+ #puts "\t>>>> rename trace fired $MAP $args <<<"
+
+ lassign $args oldcmd newcmd
+ set extracted_invocantdata [dict get $MAP invocantdata]
+ lset extracted_invocantdata 3 $newcmd
+ dict set MAP invocantdata $extracted_invocantdata
+
+
+ lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped
+
+ #Write the same info into the _ID_ value of the alias
+ interp alias {} $alias {} ;#first we must delete it
+ interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}]
+
+
+
+ #! $object_command was initially created as the renamed alias - so we have to do it again
+ uplevel 1 [list rename $alias $object_command]
+ trace add command $object_command rename [list $object_command .. Rename]
+
+ } elseif {[llength $args] == 1} {
+ #let the rename trace fire and we will be called again to do the remap!
+ uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]]
+ } else {
+ error "Rename expected \$newname argument ."
+ }
+
+ } errM]} {
+ puts stderr "\t@@@@@@ rename error"
+ set ruler "\t[string repeat - 80]"
+ puts stderr $ruler
+ puts stderr $errM
+ puts stderr $ruler
+
+ }
+
+ return
+
+
+}
+
+proc ::p::obj_get_invocants {_ID_} {
+ return [dict get $_ID_ i]
+}
+#The invocant role 'this' is special and should always have only one member.
+# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX
+proc ::p::obj_get_this_oid {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 0]
+}
+proc ::p::obj_get_this_ns {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 1]
+}
+
+proc ::p::obj_get_this_cmd {_ID_} {
+ return [lindex [dict get $_ID_ i this] 0 3]
+}
+proc ::p::obj_get_this_data {_ID_} {
+ lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd
+ #set this_invocant_data {*}[dict get $_ID_ i this]
+ return [list oid $OID ns $ns cmd $cmd]
+}
+proc ::p::map {OID varname} {
+ tailcall upvar #0 ::p::${OID}::_meta::map $varname
+}
+
+
+
diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm b/src/bootsupport/modules_tcl8/modpod-0.1.3.tm
similarity index 97%
rename from src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm
rename to src/bootsupport/modules_tcl8/modpod-0.1.3.tm
index aa27ebce..540a1696 100644
--- a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm
+++ b/src/bootsupport/modules_tcl8/modpod-0.1.3.tm
@@ -7,7 +7,7 @@
# (C) 2024
#
# @@ Meta Begin
-# Application modpod 0.1.2
+# Application modpod 0.1.3
# Meta platform tcl
# Meta license
# @@ Meta End
@@ -17,7 +17,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
-#[manpage_begin modpod_module_modpod 0 0.1.2]
+#[manpage_begin modpod_module_modpod 0 0.1.3]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@@ -134,12 +134,12 @@ namespace eval modpod {
#old tar connect mechanism - review - not needed?
proc connect {args} {
puts stderr "modpod::connect--->>$args"
- set argd [punk::args::get_dict {
+ set argd [punk::args::parse $args withdef {
@id -id ::modpod::connect
-type -default ""
@values -min 1 -max 1
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)"
- } $args]
+ }]
catch {
punk::lib::showdict $argd ;#heavy dependencies
}
@@ -168,7 +168,7 @@ namespace eval modpod {
} else {
#connect to .tm but may still be unwrapped version available
- lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
+ lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there
@@ -225,11 +225,15 @@ namespace eval modpod {
if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header
- if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} {
+ if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh]
} else {
#error "cannot verify tar header"
+ #try zipfs
+ if {[info commands tcl::zipfs::mount] ne ""} {
+
+ }
}
}
lpop connected(to) end
@@ -262,11 +266,12 @@ namespace eval modpod {
return 1
}
proc get {args} {
- set argd [punk::args::get_dict {
+ set argd [punk::args::parse $args withdef {
+ @id -id ::modpod::get
-from -default "" -help "path to pod"
- *values -min 1 -max 1
+ @values -min 1 -max 1
filename
- } $args]
+ }]
set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename]
@@ -329,7 +334,7 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
- set argd [punk::args::get_dict {
+ set argd [punk::args::parse $args withdef {
@id -id ::modpod::lib::make_zip_modpod
-offsettype -default "archive" -choices {archive file} -help\
"Whether zip offsets are relative to start of file or start of zip-data within the file.
@@ -340,7 +345,7 @@ namespace eval modpod::lib {
@values -min 2 -max 2
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
- } $args]
+ }]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
set opt_offsettype [dict get $argd opts -offsettype]
@@ -483,13 +488,15 @@ namespace eval modpod::system {
close $inzip
set size [tell $out]
+ lappend report "modpod::system::make_mountable_zip"
lappend report "tmfile : [file tail $outfile]"
lappend report "output size : $size"
lappend report "offsettype : $offsettype"
if {$offsettype eq "file"} {
#make zip offsets relative to start of whole file including prepended script.
- #same offset structure as Tcl's 'zipfs mkimg' as at 2024-10
+ #same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10
+ #2025 - zipfs mkimg fixed to use 'archive' offset.
#not editable by 7z,nanazip,peazip
#we aren't adding any new files/folders so we can edit the offsets in place
@@ -693,7 +700,7 @@ namespace eval modpod::system {
package provide modpod [namespace eval modpod {
variable pkg modpod
variable version
- set version 0.1.2
+ set version 0.1.3
}]
return
diff --git a/src/bootsupport/modules_tcl8/natsort-0.1.1.6.tm b/src/bootsupport/modules_tcl8/natsort-0.1.1.6.tm
new file mode 100644
index 00000000..07c29895
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/natsort-0.1.1.6.tm
@@ -0,0 +1,1962 @@
+#! /usr/bin/env tclsh
+
+
+#todo - remove flagfilter - use punk::args?
+package require flagfilter
+namespace import ::flagfilter::check_flags
+
+namespace eval natsort {
+ #REVIEW - determine and document the purpose of scriptdir being added to tm path
+ proc scriptdir {} {
+ set possibly_linked_script [file dirname [file normalize [file join [info script] __dummy__]]]
+ if {[file isdirectory $possibly_linked_script]} {
+ return $possibly_linked_script
+ } else {
+ return [file dirname $possibly_linked_script]
+ }
+ }
+ if {![interp issafe]} {
+ set sdir [scriptdir]
+ #puts stderr "natsort tcl::tm::add $sdir"
+ if {$sdir ni [tcl::tm::list]} {
+ catch {tcl::tm::add $sdir}
+ }
+ }
+}
+
+
+namespace eval natsort {
+ variable stacktrace_on 0
+
+ proc do_error {msg {then error}} {
+ #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call
+ #this is not just a 'logging' call even though it has log-like descriptors
+ lassign $then type code
+ if {$code eq ""} {
+ set code 1
+ }
+ set type [string tolower $type]
+ set levels [list debug info notice warn error critical]
+ if {$type in [concat $levels exit]} {
+ puts stderr "|$type> $msg"
+ } else {
+ puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '"
+ }
+ flush stderr
+ if {$::tcl_interactive} {
+ #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging
+ if {[string tolower $type] eq "exit"} {
+ puts stderr " (exit suppressed due to tcl_interactive - raising error instead)"
+ if {![string is digit -strict $code]} {
+ puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '"
+ }
+ flush stderr
+ }
+ return -code error $msg
+ } else {
+ if {$type ne "exit"} {
+ return -code error $msg
+ } else {
+ if {[string is digit -strict $code]} {
+ exit $code
+ } else {
+ puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '"
+ return -code error $msg
+ }
+ }
+ }
+ }
+
+
+
+
+
+
+ variable debug 0
+ variable testlist
+ set testlist {
+ 00.test-firstposition.txt
+ 0001.blah.txt
+ 1.test-sorts-after-all-leadingzero-number-one-equivs.txt
+ 1010.thousand-and-ten.second.txt
+ 01010.thousand-and-ten.first.txt
+ 0001.aaa.txt
+ 001.zzz.txt
+ 08.octal.txt-last-octal
+ 008.another-octal-first-octal.txt
+ 08.again-second-octal.txt
+ 001.a.txt
+ 0010.reconfig.txt
+ 010.etc.txt
+ 005.etc.01.txt
+ 005.Etc.02.txt
+ 005.123.abc.txt
+ 200.somewhere.txt
+ 2zzzz.before-somewhere.txt
+ 00222-after-somewhere.txt
+ 005.00010.abc.txt
+ 005.a3423bc.00010.abc.txt
+ 005.001.abc.txt
+ 005.etc.1010.txt
+ 005.etc.010.txt
+ 005.etc.10.txt
+ " 005.etc.10.txt"
+ 005.etc.001.txt
+ 20.somewhere.txt
+ 4611686018427387904999999999-bignum.txt
+ 4611686018427387903-bigishnum.txt
+ 9223372036854775807-bigint.txt
+ etca-a
+ etc-a
+ etc2-a
+ a0001blah.txt
+ a010.txt
+ winlike-sort-difference-0.1.txt
+ winlike-sort-difference-0.1.1.txt
+ a1.txt
+ b1-a0001blah.txt
+ b1-a010.txt
+ b1-a1.txt
+ -a1.txt
+ --a1.txt
+ --a10.txt
+ 2.high-two.yml
+ 02.higher-two.yml
+ reconfig.txt
+ _common.stuff.txt
+ CASETEST.txt
+ casetest.txt
+ something.txt
+ some~thing.txt
+ someathing.txt
+ someThing.txt
+ thing.txt
+ thing_revised.txt
+ thing-revised.txt
+ "thing revised.txt"
+ "spacetest.txt"
+ " spacetest.txt"
+ " spacetest.txt"
+ "spacetest2.txt"
+ "spacetest 2.txt"
+ "spacetest02.txt"
+ name.txt
+ name2.txt
+ "name .txt"
+ "name2 .txt"
+ blah.txt
+ combined.txt
+ a001.txt
+ .test
+ .ssh
+ "Feb 10.txt"
+ "Feb 8.txt"
+ 1ab23v23v3r89ad8a8a8a9d.txt
+ "Folder (10)/file.tar.gz"
+ "Folder/file.tar.gz"
+ "Folder (1)/file (1).tar.gz"
+ "Folder (1)/file.tar.gz"
+ "Folder (01)/file.tar.gz"
+ "Folder1/file.tar.gz"
+ "Folder(1)/file.tar.gz"
+
+ }
+ lappend testlist "Some file.txt"
+ lappend testlist " Some extra file1.txt"
+ lappend testlist " Some extra file01.txt"
+ lappend testlist " some extra file1.txt"
+ lappend testlist " Some extra file003.txt"
+ lappend testlist " Some file.txt"
+ lappend testlist "Some extra file02.txt"
+ lappend testlist "Program Files (x86)"
+ lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt"
+ lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt"
+ lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt"
+ lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt"
+ lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt"
+ lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt"
+ lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt"
+ lappend testlist "b1b1b1b1.txt"
+ lappend testlist "b1b01z1z1.txt"
+ lappend testlist "c1c111c1.txt"
+ lappend testlist "c1c1c1c1.txt"
+
+ namespace eval overtype {
+ proc right {args} {
+ # @d !todo - implement overflow, length checks etc
+
+ if {[llength $args] < 2} {
+ error {usage: ?-overflow [1|0]? undertext overtext}
+ }
+ foreach {undertext overtext} [lrange $args end-1 end] break
+
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+
+ set olen [string length $overtext]
+ set ulen [string length $undertext]
+
+ if {$opt(-overflow)} {
+ return [string range $undertext 0 end-$olen]$overtext
+ } else {
+ if {$olen > $ulen} {
+ set diff [expr {$olen - $ulen}]
+ return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff]
+ } else {
+ return [string range $undertext 0 end-$olen]$overtext
+ }
+ }
+ }
+ proc left {args} {
+ # @c overtype starting at left (overstrike)
+ # @c can/should we use something like this?: 'format "%-*s" $len $overtext
+
+ if {[llength $args] < 2} {
+ error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
+ }
+ foreach {undertext overtext} [lrange $args end-1 end] break
+
+ set opt(-ellipsis) 0
+ set opt(-ellipsistext) {...}
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+
+ set len [string length $undertext]
+ set overlen [string length $overtext]
+ set diff [expr {$overlen - $len}]
+
+ #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff"
+ #puts stdout "====================>overtype: data: $overtext"
+ if {$diff > 0} {
+ if {$opt(-overflow)} {
+ return $overtext
+ } else {
+ if {$opt(-ellipsis)} {
+ return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)]
+ } else {
+ return [string range $overtext 0 [expr {$len -1}]]
+ }
+ }
+ } else {
+ return "$overtext[string range $undertext $overlen end]"
+ }
+ }
+
+ }
+
+ #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps.
+ proc hex2dec {largeHex} {
+ #todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly)
+ set res 0
+ set largeHex [string map {_ {}} $largeHex]
+ if {[string length $largeHex] <=7} {
+ #scan can process up to FFFFFFF and does so quickly
+ return [scan $largeHex %x]
+ }
+ foreach hexDigit [split $largeHex {}] {
+ set new 0x$hexDigit
+ set res [expr {16*$res + $new}]
+ }
+ return $res
+ }
+ proc dec2hex {decimalNumber} {
+ format %4.4llX $decimalNumber
+ }
+
+ #punk::lib::trimzero
+ proc trimzero {number} {
+ set trimmed [string trimleft $number 0]
+ if {[string length $trimmed] == 0} {
+ set trimmed 0
+ }
+ return $trimmed
+ }
+ #todo - consider human numeric split
+ #e.g consider SI suffixes k|KMGTPEZY in that order
+
+ #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc.
+ #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization?
+ proc split_numeric_segments {name} {
+ set segments [list]
+ while {[string length $name]} {
+ if {[scan $name {%[0-9]%n} chunk len] == 2} {
+ lappend segments $chunk
+ set name [string range $name $len end]
+ }
+ if {[scan $name {%[^0-9]%n} chunk len] == 2} {
+ lappend segments $chunk
+ set name [string range $name $len end]
+ }
+ }
+ return $segments
+ }
+
+ proc padleft {str count {ch " "}} {
+ set val [string repeat $ch $count]
+ append val $str
+ set diff [expr {max(0,$count - [string length $str])}]
+ set offset [expr {max(0,$count - $diff)}]
+ set val [string range $val $offset end]
+ }
+
+
+ # Sqlite may have limited collation sequences available in default builds.
+ # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331
+ # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim
+ # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite
+ # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');"
+ proc sort_sqlite {stringlist args} {
+ package require sqlite3
+
+
+ set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args]
+ set db [string trim [dict get $args -db]]
+ set collate [string trim [dict get $args -collate]]
+ set debug [string trim [dict get $args -debug]]
+ set topchars [string trim [dict get $args -topchars]]
+
+ set topdot [expr {"." in $topchars}]
+ set topunderscore [expr {"_" in $topchars}]
+
+
+ sqlite3 db_sort_basic $db
+ set orderedlist [list]
+ db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}]
+ foreach nm $stringlist {
+ set segments [split_numeric_segments $nm]
+ set index ""
+ set s 0
+ foreach seg $segments {
+ if {($s == 0) && ![string length [string trim $seg]]} {
+ #don't index leading space
+ } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} {
+ append index "[padleft "0" 5]-d -100 topunderscore "
+ append index [string trim $seg]
+ } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} {
+ append index "[padleft "0" 5]-d -50 topdot "
+ append index [string trim $seg]
+ } else {
+ if {[string is digit [string trim $seg]]} {
+ set basenum [trimzero [string trim $seg]]
+ set lengthindex "[padleft [string length $basenum] 5]-d"
+ append index "$lengthindex "
+ #append index [padleft $basenum 40]
+ append index $basenum
+ } else {
+ append index [string trim $seg]
+ }
+ }
+ incr s
+ }
+ puts stdout ">>$index"
+ db_sort_basic eval {insert into sqlitesort values($index,$nm)}
+ }
+ db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] {
+ lappend orderedlist $name
+ }
+ db_sort_basic close
+ return $orderedlist
+ }
+
+ proc get_leading_char_count {str char} {
+ #todo - something more elegant? regex?
+ set count 0
+ foreach c [split $str "" ] {
+ if {$c eq $char} {
+ incr count
+ } else {
+ break
+ }
+ }
+ return $count
+ }
+ proc stacktrace {} {
+ set stack "Stack trace:\n"
+ for {set i 1} {$i < [info level]} {incr i} {
+ set lvl [info level -$i]
+ set pname [lindex $lvl 0]
+ append stack [string repeat " " $i]$pname
+
+ if {![catch {info args $pname} pargs]} {
+ foreach value [lrange $lvl 1 end] arg $pargs {
+
+ if {$value eq ""} {
+ if {$arg != 0} {
+ info default $pname $arg value
+ }
+ }
+ append stack " $arg='$value'"
+ }
+ } else {
+ append stack " !unknown vars for $pname"
+ }
+
+ append stack \n
+ }
+ return $stack
+ }
+
+ proc get_char_count {str char} {
+ #faster than lsearch on split for str of a few K
+ expr {[tcl::string::length $str]-[tcl::string::length [tcl::string::map "$char {}" $str]]}
+ }
+
+ proc build_key {chunk splitchars topdict tagconfig debug} {
+ variable stacktrace_on
+ if {$stacktrace_on} {
+ puts stderr "+++>[stacktrace]"
+ }
+
+ set index_map [list - "" _ ""]
+ #e.g - need to maintain the order
+ #a b.txt
+ #a book.txt
+ #ab.txt
+ #abacus.txt
+
+
+ set original_splitchars [dict get $tagconfig original_splitchars]
+
+ # tag_dashes test moved from loop - review
+ set tag_dashes 0
+ if {![string length [dict get $tagconfig last_part_text_tag]]} {
+ #winlike
+ set tag_dashes 1
+ }
+ if {("-" ni $original_splitchars)} {
+ set tag_dashes 1
+ }
+ if {$debug >= 3} {
+ puts stdout "START build_key chunk : $chunk"
+ puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes"
+ }
+
+
+ ## index_map will have no effect if we've already split on the char anyway(?)
+ #foreach m [dict keys $index_map] {
+ # if {$m in $original_splitchars} {
+ # dict unset index_map $m
+ # }
+ #}
+
+ #if {![string length $chunk]} return
+
+ set result ""
+ if {![llength $splitchars]} {
+ #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level.
+ # we are at a leaf in the recursive split hierarchy
+
+ set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be)
+ set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost
+
+
+ } else {
+ set s [lindex $splitchars 0]
+ if {"spudbucket$s" in "[split $chunk {}]"} {
+ error "dead-branch spudbucket"
+ set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug]
+ if {[dict get $tagconfig showsplits]} {
+ set pfx "(1${s}=)" ;# = sorts before _
+ set partindex ${pfx}$partindex
+ }
+
+ return $partindex
+ } else {
+ set parts_below_index ""
+
+ if {$s ni [split $chunk ""]} {
+ #$s can be an empty string
+ set parts [list $chunk]
+ } else {
+ set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string.
+ }
+ #assert - we have a splitchar $s that is in the chunk - so at least one part
+ if {(![string length $s] || [llength $parts] == 0)} {
+ error "buld_key assertion false empty split char and/or no parts"
+ }
+
+ set pnum 1 ;# 1 based for clarity of reading index in debug output
+ set subpart_count [llength $parts]
+
+ set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart
+ foreach p $parts {
+ set partindex [build_key $p $sub_splits $topdict $tagconfig $debug]
+ set lastpart [expr {$pnum == $subpart_count}]
+
+
+ #######################
+ set showsplits [dict get $tagconfig showsplits]
+ #split prefixing experiment - maybe not suitable for general use - as it affects sort order
+ #note that pfx must be consistent until last one, no matter how many partnumbers there are in total.
+ # we don't want to influence sort order before reaching end.
+ #e.g for:
+ #(1.=)...
+ #(1._)...(2._)...(3.=)
+ #(1._)...(2.=)
+ #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural.
+ if {$showsplits} {
+ if {$lastpart} {
+ set pfx "(${pnum}${s}_"
+ #set pfx "(${pnum}${s}=)" ;# = sorts before _
+ } else {
+ set pfx "(${pnum}${s}_"
+ }
+ append parts_below_index $pfx
+ }
+ #######################
+
+ if {$lastpart} {
+ if {[string length $p] && [string is digit $p]} {
+ set last_part_tag "<22${s}>"
+ } else {
+ set last_part_tag "<33${s}>"
+ }
+
+ set last_part_text_tag [dict get $tagconfig last_part_text_tag]
+ #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order:
+ # module-0.1.1.tm
+ # module-0.1.1.2.tm
+ # module-0.1.tm
+ # arguably -winlike 0 is more natural/human
+ # module-0.1.tm
+ # module-0.1.1.tm
+ # module-0.1.1.2.tm
+
+ if {[string length $last_part_text_tag]} {
+ #replace only the first text-tag (<30>) from the subpart_index
+ if {[string match "<30?>*" $partindex]} {
+ #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers
+ set partindex "<130>[string range $partindex 5 end]"
+ }
+ #append parts_below_index $last_part_tag
+ }
+ #set partindex $last_part_tag$partindex
+
+
+ }
+ append parts_below_index $partindex
+
+
+
+ if {$showsplits} {
+ if {$lastpart} {
+ set suffix "${pnum}${s}=)" ;# = sorts before _
+ } else {
+ set suffix "${pnum}${s}_)"
+ }
+ append parts_below_index $suffix
+ }
+
+
+ incr pnum
+ }
+ append parts_below_index "" ;# don't add anything at the tail that may perturb sort order
+
+ if {$debug >= 3} {
+ set pad [string repeat " " 20]
+ puts stdout "END build_key chunk : $chunk "
+ puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes"
+ puts stdout "END build_key ret below_index: $parts_below_index"
+ }
+ return $parts_below_index
+
+
+ }
+ }
+
+
+
+ #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict"
+
+
+
+
+
+ #if {$chunk eq ""} {
+ # puts "___________________________________________!!!____"
+ #}
+ #puts stdout "-->chunk:$chunk $s parts:$parts"
+
+ #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'"
+
+
+
+
+ set segments [split_numeric_segments $chunk] ;#!
+ set stringindex ""
+ set segnum 0
+ foreach seg $segments {
+ #puts stdout "=================---->seg:$seg segments:$segments"
+ #-strict ?
+ if {[string length $seg] && [string is digit $seg]} {
+ set basenum [trimzero [string trim $seg]]
+ set lengthindex "[padleft [string length $basenum] 4]d"
+ #append stringindex "<20>$lengthindex $basenum $seg"
+ } else {
+ set c1 [string range $seg 0 0]
+ #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex"
+
+ if {$c1 in [dict keys $topdict]} {
+ set tag [dict get $topdict $c1]
+ #append stringindex "${tag}$c1"
+ #set seg [string range $seg 1 end]
+ }
+ #textindex
+ set leader "<30>"
+ set idx $seg
+ set idx [string trim $idx]
+ set idx [string tolower $idx]
+ set idx [string map $index_map $idx]
+
+
+
+
+
+ #set the X-c count to match the length of the index - not the raw data
+ set lengthindex "[padleft [string length $idx] 4]c"
+
+ #append stringindex "${leader}$idx $lengthindex $texttail"
+ }
+ }
+
+ if {[llength $parts] != 1} {
+ error "build_key assertion fail llength parts != 1 parts:$parts"
+ }
+
+ set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits
+ set segtail $segtail_clearance_buffer
+ append segtail "\["
+ set grouping ""
+ set pnum 0
+ foreach p $parts {
+ set sublen_list [list]
+ set subsegments [split_numeric_segments $p]
+ set i 0
+
+ set partsorter ""
+ foreach sub $subsegments {
+ ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2"
+ #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions.
+ set test_trim [string trim $sub]
+ set str $sub
+ set str [string tolower $str]
+ set str [string map $index_map $str]
+ if {[string length $test_trim] && [string is digit $test_trim]} {
+ append partsorter [trimzero $str]
+ } else {
+ append partsorter "$str"
+ }
+ append partsorter
+ }
+
+
+ foreach sub $subsegments {
+
+ if {[string length $sub] && [string is digit $sub]} {
+ set basenum [trimzero [string trim $sub]]
+ set subequivs $basenum
+ set lengthindex "[padleft [string length $subequivs] 4]d "
+ set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest
+ set tail [overtype::left [string repeat " " 10] $sub]
+ #set tail ""
+ } else {
+ set idx ""
+
+
+ set lookahead [lindex $subsegments $i+1]
+ if {![string length $lookahead]} {
+ set zeronum "[padleft 0 4]d0"
+ } else {
+ set zeronum ""
+ }
+ set subequivs $sub
+ #set subequivs [string trim $subequivs]
+ set subequivs [string tolower $subequivs]
+ set subequivs [string map $index_map $subequivs]
+
+ append idx $subequivs
+ append idx $zeronum
+
+ set idx $subequivs
+
+
+ #
+
+ set ch "-"
+ if {$tag_dashes} {
+ #puts stdout "____TAG DASHES"
+ #winlike
+ set numleading [get_leading_char_count $seg $ch]
+ if {$numleading > 0} {
+ set texttail "<31-leading[padleft $numleading 4]$ch>"
+ } else {
+ set texttail "<30>"
+ }
+ set numothers [expr {[get_char_count $seg $ch] - $numleading}]
+ if {$debug >= 2} {
+ puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers"
+ }
+ if {$numothers > 0} {
+ append texttail "<31-others[padleft $numothers 4]$ch>"
+ } else {
+ append textail "<30>"
+ }
+ } else {
+ set texttail "<30>"
+ }
+
+
+
+
+ #set idx $partsorter
+ set tail ""
+ #set tail [string tolower $sub] ;#raw
+ #set tail $partsorter
+ #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting
+ }
+
+ append grouping "$idx $tail|$s"
+ incr i
+ }
+
+
+
+
+
+ if {$p eq ""} {
+ # no subsegments..
+ set zeronum "[padleft 0 4]d0"
+ #append grouping "\u000$zerotail"
+ append grouping ".$zeronum"
+ }
+
+ #append grouping |
+ #append grouping $s
+ #foreach len $sublen_list {
+ # append segtail "<[padleft $len 3]>"
+ #}
+ incr pnum
+ }
+ set grouping [string trimright $grouping $s]
+ append grouping "[padleft [llength $parts] 4]"
+ append segtail $grouping
+
+
+ #append segtail " <[padleft [llength $parts] 4]>"
+
+ append segtail "\]"
+
+
+ #if {[string length $seg] && [string is digit $seg]} {
+ # append segtail "<20>"
+ #} else {
+ # append segtail "<30>"
+ #}
+ append stringindex $segtail
+
+ incr segnum
+
+
+
+
+ lappend indices $stringindex
+
+ if {[llength $indices] > 1} {
+ puts stderr "INDICES [llength $indices]: $stringindex"
+ error "build_key assertion error deadconcept indices"
+ }
+
+ #topchar handling on splitter characters
+ #set c1 [string range $chunk 0 0]
+ if {$s in [dict keys $topdict]} {
+ set tag [dict get $topdict $s]
+ set joiner [string map [list ">" "$s>"] ${tag}]
+ #we have split on this character $s so if the first part is empty string then $s was a leading character
+ # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag
+ # (since the empty string produces no tag of it's own - ?)
+ if {[string length [lindex $parts 0]] == 0} {
+ set prefix ${joiner}
+ } else {
+ set prefix ""
+ }
+ } else {
+ #use standard character-data positioning tag if no override from topdict
+ set joiner "<30J>$s"
+ set prefix ""
+ }
+
+
+ set contentindex $prefix[join $indices $joiner]
+ if {[string length $s]} {
+ set split_indicator ""
+ } else {
+ set split_indicator ""
+
+ }
+ if {![string length $s]} {
+ set s ~
+ }
+
+ #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]"
+ #return $contentindex$split_indicator
+ #return [overtype::left [string repeat - 40] $contentindex]
+
+ if {$debug >= 3} {
+ puts stdout "END build_key chunk : $chunk"
+ puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes"
+ puts stdout "END build_key ret contentidx : $contentindex"
+ }
+ return $contentindex
+ }
+
+ #----------------------------------------
+ #line-processors - data always last argument - opts can be empty string
+ #all processor should accept empty opts and ignore opts if they don't use them
+ proc _lineinput_as_tcl1 {opts line} {
+ set out ""
+ foreach i $line {
+ append out "$i "
+ }
+ set out [string range $out 0 end-1]
+ return $out
+ }
+ #should be equivalent to above
+ proc _lineinput_as_tcl {opts line} {
+ return [concat {*}$line]
+ }
+ #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"}
+ proc _lineoutput_as_tcl {opts line} {
+ return [regexp -inline -all {\S+} $line]
+ }
+
+ proc _lineinput_as_raw {opts line} {
+ return $line
+ }
+ proc _lineoutput_as_raw {opts line} {
+ return $line
+ }
+
+ #words is opposite of tcl
+ proc _lineinput_as_words {opts line} {
+ #wordlike_parts
+ return [regexp -inline -all {\S+} $line]
+ }
+ proc _lineoutput_as_words {opts line} {
+ return [concat {*}$line]
+ }
+
+ #opts same as tcllib csv::split - except without the 'line' element
+ #?-alternate? ?sepChar? ?delChar?
+ proc _lineinput_as_csv {opts line} {
+ package require csv
+ if {[lindex $opts 0] eq "-alternate"} {
+ return [csv::split -alternate $line {*}[lrange $opts 1 end]]
+ } else {
+ return [csv::split $line {*}$opts]
+ }
+ }
+ #opts same as tcllib csv::join
+ #?sepChar? ?delChar? ?delMode?
+ proc _lineoutput_as_csv {opts line} {
+ package require csv
+ return [csv::join $line {*}$opts]
+ }
+ #----------------------------------------
+ variable sort_flagspecs
+ set sort_flagspecs [dict create\
+ -caller natsort::sort \
+ -return supplied|defaults \
+ -defaults [list -collate nocase \
+ -winlike 0 \
+ -splits "\uFFFF" \
+ -topchars {. _} \
+ -showsplits 1 \
+ -sortmethod ascii \
+ -collate "\uFFFF" \
+ -inputformat raw \
+ -inputformatapply {index data} \
+ -inputformatoptions "" \
+ -outputformat raw \
+ -outputformatoptions "" \
+ -cols "\uFFFF" \
+ -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \
+ -required {all} \
+ -extras {none} \
+ -commandprocessors {}\
+ ]
+
+ proc sort {stringlist args} {
+ #puts stdout "natsort::sort args: $args"
+ variable debug
+ variable sort_flagspecs
+ if {![llength $stringlist]} return
+ if {[llength $stringlist] == 1} {
+ if {"-inputformat" ni $args && "-outputformat" ni $args} {
+ return $stringlist
+ }
+ }
+
+ #allow pass through of the check_flags flag -debugargs so it can be set by the caller
+ set debugargs 0
+ if {[set posn [lsearch $args -debugargs]] >=0} {
+ if {$posn == [llength $args]-1} {
+ #-debugargs at tail of list
+ set debugargs 1
+ } else {
+ set debugargs [lindex $args $posn+1]
+ }
+ }
+
+ #-return flagged|defaults doesn't work Review.
+ #flagfilter global processor/allocator not working 2023-08
+
+ set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args]
+
+ #we can only shortcircuit input list of single element at this point if there aren't non-default -inputformat or -outputformat transformations
+ if {[llength $stringlist] == 1} {
+ set is_basic 1
+ foreach fname [list -inputformat -outputformat] {
+ if {[dict get $sort_flagspecs -defaults $fname] ne [dict get $opts $fname]} {
+ set is_basic 0
+ break
+ }
+ }
+ if {$is_basic} {
+ return $stringlist
+ }
+ }
+
+
+ set winlike [dict get $opts -winlike]
+ set topchars [dict get $opts -topchars]
+ set cols [dict get $opts -cols]
+ set debug [dict get $opts -debug]
+ set stacktrace [dict get $opts -stacktrace]
+ set showsplits [dict get $opts -showsplits]
+ set splits [dict get $opts -splits]
+ set sortmethod [dict get $opts -sortmethod]
+ set opt_collate [dict get $opts -collate]
+ set opt_inputformat [dict get $opts -inputformat]
+ set opt_inputformatapply [dict get $opts -inputformatapply]
+ set opt_inputformatoptions [dict get $opts -inputformatoptions]
+ set opt_outputformat [dict get $opts -outputformat]
+ set opt_outputformatoptions [dict get $opts -outputformatoptions]
+
+ if {$debug} {
+ #dict unset opts -showsplits
+ #dict unset opts -splits
+ puts stdout "natsort::sort processed_args: $opts"
+ if {$debug == 1} {
+ puts stdout "natsort::sort - try also -debug 2, -debug 3"
+ }
+ }
+
+ #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about
+ switch -- $sortmethod {
+ dictionary - ascii {
+ set sortmethod "-$sortmethod"
+ # -ascii is default for tcl lsort.
+ }
+ default {
+ set sortmethod "-ascii"
+ }
+ }
+
+ set allowed_collations [list nocase]
+ if {$opt_collate ne "\uFFFF"} {
+ if {$opt_collate ni $allowed_collations} {
+ error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations"
+ }
+ set nocaseopt "-$opt_collate"
+ } else {
+ set nocaseopt ""
+ }
+ set allowed_inputformats [list tcl raw csv words]
+ switch -- $opt_inputformat {
+ tcl - raw - csv - words {}
+ default {
+ error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats"
+ }
+ }
+ set allowed_outputformats [list tcl raw csv words]
+ switch -- $opt_outputformat {
+ tcl - raw - csv - words {}
+ default {
+ error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats"
+ }
+ }
+
+ #
+ set winsplits [list / . _]
+ set commonsplits [list / . _ -]
+ #set commonsplits [list]
+
+ set tagconfig [dict create]
+ dict set tagconfig last_part_text_tag "<19>"
+ if {$winlike} {
+ set splitchars $winsplits
+ #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway.
+ set wintop [list "(" ")" { } {.} {_}] ;#windows specific order
+ foreach t $topchars {
+ if {$t ni $wintop} {
+ lappend wintop $t
+ }
+ }
+ set topchars $wintop
+ dict set tagconfig last_part_text_tag ""
+ } else {
+ set splitchars $commonsplits
+ }
+ if {$splits ne "\uFFFF"} {
+ set splitchars $splits
+ }
+ dict set tagconfig original_splitchars $splitchars
+ dict set tagconfig showsplits $showsplits
+
+ #create topdict
+ set i 0
+ set topdict [dict create]
+ foreach c $topchars {
+ incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting)
+ dict set topdict $c "<0$i>"
+ }
+ set keylist [list]
+
+ switch -- $opt_inputformat {
+ tcl {
+ set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions]
+ }
+ csv {
+ set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions]
+ }
+ raw {
+ set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions]
+ }
+ words {
+ set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions]
+ }
+ }
+ switch -- $opt_outputformat {
+ tcl {
+ set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions]
+ }
+ csv {
+ set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions]
+ }
+ raw {
+ set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions]
+ }
+ words {
+ set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions]
+ }
+ }
+
+ if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} {
+ if {$opt_inputformat eq "raw"} {
+ set tf_stringlist $stringlist
+ } else {
+ set tf_stringlist [list]
+ foreach v $stringlist {
+ lappend tf_stringlist [{*}$lineinput_transform $v]
+ }
+ }
+ if {"data" in $opt_inputformatapply} {
+ set tf_data_stringlist $tf_stringlist
+ } else {
+ set tf_data_stringlist $stringlist
+ }
+ if {"index" in $opt_inputformatapply} {
+ set tf_index_stringlist $tf_stringlist
+ } else {
+ set tf_index_stringlist $stringlist
+ }
+ } else {
+ set tf_data_stringlist $stringlist
+ set tf_index_stringlist $stringlist
+ }
+
+
+
+ if {$stacktrace} {
+ puts stdout [natsort::stacktrace]
+ set natsort::stacktrace_on 1
+ }
+ if {$cols eq "\uFFFF"} {
+ set colkeys [lmap v $stringlist {}]
+ } else {
+ set colkeys [list]
+ foreach v $tf_index_stringlist {
+ set lineparts $v
+ set k [list]
+ foreach c $cols {
+ lappend k [lindex $lineparts $c]
+ }
+ lappend colkeys [join $k "_"] ;#use a common-split char - Review
+ }
+ }
+ #puts stdout "colkeys: $colkeys"
+
+ if {$opt_inputformat eq "raw"} {
+ #no inputformat was applied - can just use stringlist
+ foreach value $stringlist ck $colkeys {
+ set contentindex [build_key $value $splitchars $topdict $tagconfig $debug]
+ set colindex [build_key $ck $splitchars $topdict $tagconfig $debug]
+ lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing)
+ }
+ } else {
+ foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys {
+ #data may or may not have been transformed
+ #column index may or may not have been built with transformed data
+
+ set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug]
+ set colindex [build_key $ck $splitchars $topdict $tagconfig $debug]
+ lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing)
+ }
+ }
+ #puts stderr "keylist: $keylist"
+
+ ###################################################################################################
+ # Use the generated keylist to do the actual sorting
+ # select either the transformed or raw data as the corresponding output
+ ###################################################################################################
+ if {[string length $nocaseopt]} {
+ set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist]
+ } else {
+ set sortcommand [list lsort $sortmethod -indices $keylist]
+ }
+ if {$opt_outputformat eq "raw"} {
+ #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side
+ #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data.
+ #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply)
+ foreach idx [{*}$sortcommand] {
+ lappend result [lindex $tf_data_stringlist $idx]
+ }
+ } else {
+ #we need to apply an output format
+ #The data may or may not have been transformed at input
+ foreach idx [{*}$sortcommand] {
+ lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]]
+ }
+ }
+ ###################################################################################################
+
+
+
+
+
+ if {$debug >= 2} {
+ set screen_width 250
+ set max_val 0
+ set max_idx 0
+ ##### calculate colum widths
+ foreach i [{*}$sortcommand] {
+ set len_val [string length [lindex $stringlist $i]]
+ if {$len_val > $max_val} {
+ set max_val $len_val
+ }
+ set len_idx [string length [lindex $keylist $i]]
+ if {$len_idx > $max_idx} {
+ set max_idx $len_idx
+ }
+ }
+ ####
+ set l_width [expr {$max_val + 1}]
+ set leftcol [string repeat " " $l_width]
+ set r_width [expr {$screen_width - $l_width - 1}]
+ set rightcol [string repeat " " $r_width]
+ set str [overtype::left $leftcol RAW]
+ puts stdout " $str Index with possibly transformed data at tail"
+ foreach i [{*}$sortcommand] {
+ #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]"
+ set index [lindex $keylist $i]
+ set len_idx [string length $index]
+ set rowcount [expr {$len_idx / $r_width}]
+ if {($len_idx % $r_width) > 0} {
+ incr rowcount
+ }
+ set rows [list]
+ for {set r 0} {$r < $rowcount} {incr r} {
+ lappend rows [string range $index 0 $r_width-$r]
+ set index [string range $index $r_width end]
+ }
+
+ set r 0
+ foreach idxpart $rows {
+ if {$r == 0} {
+ #use the untransformed stringlist
+ set str [overtype::left $leftcol [lindex $stringlist $i]]
+ } else {
+ set str [overtype::left $leftcol ...]]
+ }
+ puts stdout " $str $idxpart"
+ incr r
+ }
+ #puts stdout "|> '[lindex $stringlist $i]'"
+ #puts stdout "|> [lindex $keylist $i]"
+ }
+
+ puts stdout "|debug> topdict: $topdict"
+ puts stdout "|debug> splitchars: $splitchars"
+ }
+ return $result
+ }
+
+
+
+ #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly.
+ proc sort_experiment {stringlist args} {
+ package require sqlite3
+
+ variable debug
+ set args [check_flags -caller natsort::sort \
+ -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \
+ -extras {all} \
+ -values $args]
+ set db [string trim [dict get $args -db]]
+ set collate [string trim [dict get $args -collate]]
+ set winlike [string trim [dict get $args -winlike]]
+ set debug [string trim [dict get $args -debug]]
+ set nullvalue [string trim [dict get $args -nullvalue]]
+
+
+ set topchars [string trim [dict get $args -topchars]]
+
+ set topdot [expr {"." in $topchars}]
+ set topunderscore [expr {"_" in $topchars}]
+
+
+ sqlite3 db_natsort2 $db
+ #--
+ #our table must handle the name with the greatest number of numeric/non-numeric splits.
+ #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance.
+ #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger.
+ # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that.
+ set maxsegments 0
+ #--
+ set prefix "idx"
+
+ #note - there will be more columns in the sorting table than segments.
+ # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements')
+ #---------------------------
+ # consider
+ # a123b.v1.2.txt
+ # a123b.v1.3beta1.txt
+ # these have the following segments:
+ # a 123 b.v 1 . 2 .txt
+ # a 123 b.v 1 . 3 beta 1 .txt
+ #---------------------------
+ # The first string has 7 segments (numbered 0 to 6)
+ # the second string has 9 segments
+ #
+ # for example when the data has any elements in a segment position that are numeric (e.g 0001 123)
+ # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support)
+ #
+ # when a segment
+
+ #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent.
+ array set segmentinfo {}
+ foreach nm $stringlist {
+ set segments [split_numeric_segments $nm]
+ if {![string length [string trim [lindex $segments 0]]]} {
+ if {[string is digit [string trim [lindex $segments 1]]]} {
+ #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though)
+ set segments [lrange $segments 1 end]
+ }
+ }
+
+
+ set c 0 ;#start of index columns
+ if {[llength $segments] > $maxsegments} {
+ set maxsegments [llength $segments]
+ }
+ foreach seg $segments {
+ set seg [string trim $seg]
+ set column_exists [info exists segmentinfo($c,type)]
+ if {[string is digit $seg]} {
+ if {$column_exists} {
+ #override it (may currently be text or int)
+ set segmentinfo($c,type) "int"
+ } else {
+ #new column
+ set segmentinfo($c,name) ${prefix}$c
+ set segmentinfo($c,type) "int"
+ }
+ } else {
+ #text never overrides int
+ if {!$column_exists} {
+ set segmentinfo($c,name) ${prefix}$c
+ set segmentinfo($c,type) "text"
+ }
+ }
+ incr c
+ }
+ }
+ if {$debug} {
+ puts stdout "Largest number of num/non-num segments in data: $maxsegments"
+ #parray segmentinfo
+ }
+
+ #
+ set tabledef ""
+ set ordered_column_names [list]
+ set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]]
+ foreach k $ordered_segmentinfo_tags {
+ lassign [split $k ,] c tag
+ if {$tag eq "type"} {
+ set type [set segmentinfo($k)]
+ if {$type eq "int"} {
+ append tabledef "$segmentinfo($c,name) int,"
+ } else {
+ append tabledef "$segmentinfo($c,name) text COLLATE $collate,"
+ }
+ append tabledef "raw$c text COLLATE $collate,"
+ lappend ordered_column_names $segmentinfo($c,name)
+ lappend ordered_column_names raw$c ;#additional index column not in segmentinfo
+ }
+ if {$tag eq "name"} {
+ #lappend ordered_column_names $segmentinfo($k)
+ }
+ }
+ append tabledef "name text"
+
+ #puts stdout "tabledef:$tabledef"
+
+
+ db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}]
+
+
+ foreach nm $stringlist {
+ array unset intdata
+ array set intdata {}
+ array set rawdata {}
+ #init array and build sql values string
+ set sql_insert "insert into natsort values("
+ for {set i 0} {$i < $maxsegments} {incr i} {
+ set intdata($i) ""
+ set rawdata($i) ""
+ append sql_insert "\$intdata($i),\$rawdata($i),"
+ }
+ append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list.
+ append sql_insert ")"
+
+ set segments [split_numeric_segments $nm]
+ if {![string length [string trim [lindex $segments 0]]]} {
+ if {[string is digit [string trim [lindex $segments 1]]]} {
+ #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though)
+ set segments [lrange $segments 1 end]
+ }
+ }
+ set values ""
+ set c 0
+ foreach seg $segments {
+ if {[set segmentinfo($c,type)] eq "int"} {
+ if {[string is digit [string trim $seg]]} {
+ set intdata($c) [trimzero [string trim $seg]]
+ } else {
+ catch {unset intdata($c)} ;#set NULL - sorts last
+ if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} {
+ set intdata($c) -100
+ }
+ if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} {
+ set intdata($c) -50
+ }
+ }
+ set rawdata($c) [string trim $seg]
+ } else {
+ #pure text column
+ #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index
+ #catch {unset indata($c)}
+ set indata($c) [string trim $seg]
+ set rawdata($c) $seg
+ }
+ #set rawdata($c) [string trim $seg]#
+ #set rawdata($c) $seg
+ incr c
+ }
+ db_natsort2 eval $sql_insert
+ }
+
+ set orderedlist [list]
+
+ if {$debug} {
+ db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata {
+ parray rowdata
+ }
+ }
+ set orderby "order by "
+
+ foreach cname $ordered_column_names {
+ if {[string match "idx*" $cname]} {
+ append orderby "$cname ASC NULLS LAST,"
+ } else {
+ append orderby "$cname ASC,"
+ }
+ }
+ append orderby " name ASC"
+ #append orderby " NULLS LAST" ;#??
+
+ #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC"
+ if {$debug} {
+ puts stdout "orderby clause: $orderby"
+ }
+ db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata {
+ set line "- "
+ #parray rowdata
+ set columnnames $rowdata(*)
+ #puts stdout "columnnames: $columnnames"
+ #[lsort -dictionary [array names rowdata]
+ append line "$rowdata(name) \n"
+ foreach nm $columnnames {
+ if {$nm ne "name"} {
+ append line "$nm: $rowdata($nm) "
+ }
+ }
+ #puts stdout $line
+ #puts stdout "$rowdata(name)"
+ lappend orderedlist $rowdata(name)
+ }
+
+ db_natsort2 close
+ return $orderedlist
+ }
+}
+
+
+#application section e.g this file might be linked from /usr/local/bin/natsort
+namespace eval natsort {
+ namespace import ::flagfilter::check_flags
+
+ proc called_directly_namematch {} {
+ global argv0
+ if {[info script] eq ""} {
+ return 0
+ }
+ #see https://wiki.tcl-lang.org/page/main+script
+ #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem)
+ if {[info exists argv0]
+ &&
+ [file dirname [file normalize [file join [info script] ...]]]
+ eq
+ [file dirname [file normalize [file join $argv0 ...]]]
+ } {
+ return 1
+ } else {
+ #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]"
+ #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]"
+ return 0
+ }
+ }
+ #Review issues around comparing names vs using inodes (esp with respect to samba shares)
+ proc called_directly_inodematch {} {
+ global argv0
+
+ if {[info exists argv0]
+ && [file exists [info script]] && [file exists $argv0]} {
+ file stat $argv0 argv0Info
+ file stat [info script] scriptInfo
+ if {$argv0Info(ino) == 0 || $scriptInfo(ino) == 0 || $argv0Info(dev) == 0 || $scriptInfo(dev) == 0} {
+ #vfs?
+ #e.g //zipfs:/
+ return 0
+ }
+ return [expr {$argv0Info(dev) == $scriptInfo(dev)
+ && $argv0Info(ino) == $scriptInfo(ino)}]
+ } else {
+ return 0
+ }
+ }
+
+ if {![interp issafe]} {
+ set is_namematch [called_directly_namematch]
+ set is_inodematch [called_directly_inodematch]
+ ####
+ #review - reliability of mechanisms to determine direct calls
+ # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc
+ #-- choose a policy and leave the others commented.
+ #set is_called_directly $is_namematch
+ #set is_called_directly $is_inodematch
+
+ #puts "NATSORT: called_directly_namematch - $is_namematch"
+ #puts "NATSORT: called_directly_inodematch - $is_inodematch"
+ #flush stdout
+
+ set is_called_directly [expr {$is_namematch || $is_inodematch}]
+ #set is_called_directly [expr {$is_namematch && $is_inodematch}]
+ ###
+
+
+ #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]"
+ } else {
+ #safe interp
+ set is_called_directly 0
+ }
+
+
+
+ proc test_pass_fail_message {pass {additional ""}} {
+ variable test_fail_msg
+ variable test_pass_msg
+ if {$pass} {
+ puts stderr $test_pass_msg
+ } else {
+ puts stderr $test_fail_msg
+ }
+ puts stderr $additional
+ }
+
+ variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX"
+ variable test_pass_msg "------------ PASS -------------"
+ proc test_sort_1 {args} {
+ package require struct::list
+ puts stderr "---$args"
+ set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args]
+
+ puts stderr "test_sort_1 got args: $args"
+
+ set unsorted_input {
+ 2.2.2
+ 2.2.2.2
+ 1a.1.1
+ 1a.2.1.1
+ 1.12.1
+ 1.2.1.1
+ 1.02.1.1
+ 1.002b.1.1
+ 1.1.1.2
+ 1.1.1.1
+ }
+ set input {
+1.1.1
+1.1.1.2
+1.002b.1.1
+1.02.1.1
+1.2.1.1
+1.12.1
+1a.1.1
+1a.2.1.1
+2.2.2
+2.2.2.2
+ }
+
+ set sorted [natsort::sort $input {*}$args]
+ set is_match [struct::list equal $input $sorted]
+
+ set msg "windows-explorer order"
+
+ test_pass_fail_message $is_match $msg
+ puts stdout [string repeat - 40]
+ puts stdout INPUT
+ puts stdout [string repeat - 40]
+ foreach item $input {
+ puts stdout $item
+ }
+ puts stdout [string repeat - 40]
+ puts stdout OUTPUT
+ puts stdout [string repeat - 40]
+ foreach item $sorted {
+ puts stdout $item
+ }
+ test_pass_fail_message $is_match $msg
+ return [expr {!$is_match}]
+ }
+ proc test_sort_showsplits {args} {
+ package require struct::list
+
+ set args [check_flags -caller natsort:test_sort_1 \
+ -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \
+ -extras {all} \
+ -values $args]
+
+ set input1 {
+ a-b.txt
+ a.b.c.txt
+ b.c-txt
+ }
+
+
+ set input2 {
+ a.b.c.txt
+ a-b.txt
+ b.c-text
+ }
+
+ foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] {
+ set sorted [natsort::sort $testlist {*}$args]
+ set is_match [struct::list equal $testlist $sorted]
+
+ test_pass_fail_message $is_match $msg
+ puts stderr "INPUT"
+ puts stderr "[string repeat - 40]"
+ foreach item $testlist {
+ puts stdout $item
+ }
+ puts stderr "[string repeat - 40]"
+ puts stderr "OUTPUT"
+ puts stderr "[string repeat - 40]"
+ foreach item $sorted {
+ puts stdout $item
+ }
+
+ test_pass_fail_message $is_match $msg
+ }
+
+ #return [expr {!$is_match}]
+
+ }
+
+ #tcl proc dispatch order - non flag items up front
+ #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1
+ proc commandline_ls {args} {
+ set operands [list]
+ set posn 0
+ foreach a $args {
+ if {![string match -* $a]} {
+ lappend operands $a
+ } else {
+ set flag1_posn $posn
+ break
+ }
+ incr posn
+ }
+ set args [lrange $args $flag1_posn end]
+
+
+ set debug 0
+ set posn [lsearch $args -debug]
+ if {$posn > 0} {
+ if {[lindex $args $posn+1]} {
+ set debug [lindex $args $posn+1]
+ }
+ }
+ if {$debug} {
+ puts stderr "|debug>commandline_ls got $args"
+ }
+
+ #if first operand not supplied - replace it with current working dir
+ if {[lindex $operands 0] eq "\uFFFF"} {
+ lset operands 0 [pwd]
+ }
+
+ set targets [list]
+ foreach op $operands {
+ if {$op ne "\uFFFF"} {
+ set opchars [split [file tail $op] ""]
+ if {"?" in $opchars || "*" in $opchars} {
+ lappend targets $op
+ } else {
+ #actual file or dir
+ set targetitem $op
+ set targetitem [file normalize $op]
+ if {![file exists $targetitem]} {
+ if {$debug} {
+ puts stderr "|debug>commandline_ls Unable to access path '$targetitem'"
+ }
+ }
+ lappend targets $targetitem
+ if {$debug} {
+ puts stderr "|debug>commandline_ls listing for $targetitem"
+ }
+ }
+ }
+ }
+ set args [check_flags -caller commandline_ls \
+ -return flagged|defaults \
+ -debugargs 0 \
+ -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \
+ -required {all} \
+ -extras {all} \
+ -soloflags {-v -l} \
+ -commandprocessors {} \
+ -values $args ]
+ if {$debug} {
+ puts stderr "|debug>args: $args"
+ }
+
+
+ set algorithm [dict get $args -algorithm]
+ dict unset args -algorithm
+
+ set allfolders [list]
+ set allfiles [list]
+ foreach item $targets {
+ if {[file exists $item]} {
+ if {[file type $item] eq "directory"} {
+ set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*]
+ set folders [glob -nocomplain -directory $item -type {d} -tail *]
+ set allfolders [concat $allfolders $dotfolders $folders]
+
+ set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*]
+ set files [glob -nocomplain -directory $item -type {f} -tail *]
+ set allfiles [concat $allfiles $dotfiles $files]
+ } else {
+ #file (or link?)
+ set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]]
+ set allfiles [concat $allfiles $files]
+ }
+ } else {
+ set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]]
+ set allfolders [concat $allfolders $folders]
+ set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]]
+ set allfiles [concat $allfiles $files]
+ }
+ }
+
+
+ set sorted_folders [natsort::sort $allfolders {*}$args]
+ set sorted_files [natsort::sort $allfiles {*}$args]
+
+ foreach fold $sorted_folders {
+ puts stdout $fold
+ }
+ foreach file $sorted_files {
+ puts stdout $file
+ }
+
+ return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --"
+ }
+
+ package require argp
+ argp::registerArgs commandline_test {
+ { -showsplits boolean 0}
+ { -stacktrace boolean 0}
+ { -debug boolean 0}
+ { -winlike boolean 0}
+ { -db string ":memory:"}
+ { -collate string "nocase"}
+ { -algorithm string "sort"}
+ { -topchars string "\uFFFF"}
+ { -testlist string {10 1 30 3}}
+ }
+ argp::setArgsNeeded commandline_test {-stacktrace}
+ proc commandline_test {test args} {
+ variable testlist
+ puts stdout "commandline_test got $args"
+ argp::parseArgs opts
+ puts stdout "commandline_test got [array get opts]"
+ set args [check_flags -caller natsort_commandline \
+ -return flagged|defaults \
+ -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \
+ -values $args]
+
+ if {[string tolower $test] in [list "1" "true"]} {
+ set test "sort"
+ } else {
+ if {![llength [info commands $test]]} {
+ error "test $test not found"
+ }
+ }
+ dict unset args -test
+ set stacktrace [dict get $args -stacktrace]
+ # dict unset args -stacktrace
+
+ set argtestlist [dict get $args -testlist]
+ dict unset args -testlist
+
+
+ set debug [dict get $args -debug]
+
+ set collate [dict get $args -collate]
+ set db [dict get $args -db]
+ set winlike [dict get $args -winlike]
+ set topchars [dict get $args -topchars]
+
+
+ puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]"
+ #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike]
+ set resultlist [$test $argtestlist {*}$args]
+ foreach nm $resultlist {
+ puts stdout $nm
+ }
+ puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]"
+ return "test end"
+ }
+ proc commandline_runtests {runtests args} {
+ set argvals [check_flags -caller commandline_runtests \
+ -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \
+ -values $args]
+
+ puts stderr "runtests args: $argvals"
+
+ #set runtests [dict get $argvals -runtests]
+ dict unset argvals -runtests
+ dict unset argvals -algorithm
+
+ puts stderr "runtests args: $argvals"
+ #exit 0
+
+ set test_prefix "::natsort::test_sort_"
+
+ if {$runtests eq "1"} {
+ set runtests "*"
+ }
+
+
+ set testcommands [info commands ${test_prefix}${runtests}]
+ if {![llength $testcommands]} {
+ puts stderr "No test commands matched -runtests argument '$runtests'"
+ puts stderr "Use 1 to run all tests"
+ set alltests [info commands ${test_prefix}*]
+ puts stderr "Valid tests are:"
+
+ set prefixlen [string length $test_prefix]
+ foreach t $alltests {
+ set shortname [string range $t $prefixlen end]
+ puts stderr "$t = -runtests $shortname"
+ }
+
+ } else {
+ foreach cmd $testcommands {
+ puts stderr [string repeat - 40]
+ puts stderr "calling $cmd with args: '$argvals'"
+ puts stderr [string repeat - 40]
+ $cmd {*}$argvals
+ }
+ }
+ exit 0
+ }
+ proc help {args} {
+ puts stdout "natsort::help got '$args'"
+ return "Help not implemented"
+ }
+ proc natsort_pipe {args} {
+ #PIPELINE to take input list on stdin and write sorted list to stdout
+ #strip - from arglist
+ #set args [check_flags -caller natsort_pipeline \
+ # -return all \
+ # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \
+ # -values $args]
+
+
+ set debug [dict get $args -debug]
+ if {$debug} {
+ puts stderr "|debug> natsort_pipe got args:'$args'"
+ }
+ set algorithm [dict get $args -algorithm]
+ dict unset args -algorithm
+
+ set proclist [info commands ::natsort::sort*]
+ set algos [list]
+ foreach p $proclist {
+ lappend algos [namespace tail $p]
+ }
+ if {$algorithm ni [list {*}$proclist {*}$algos]} {
+ do_error "valid sort mechanisms: $algos" 2
+ }
+
+
+ set input_list [list]
+ while {![eof stdin]} {
+ if {[gets stdin line] > 0} {
+ lappend input_list $line
+ } else {
+ if {[eof stdin]} {
+
+ } else {
+ after 10
+ }
+ }
+ }
+
+ if {$debug} {
+ puts stderr "|debug> received [llength $input_list] list elements"
+ }
+
+ set resultlist [$algorithm $input_list {*}$args]
+ if {$debug} {
+ puts stderr "|debug> returning [llength $resultlist] list elements"
+ }
+ foreach r $resultlist {
+ puts stdout $r
+ }
+ #exit 0
+
+ }
+ if {($is_called_directly)} {
+ set cmdprocessors {
+ {helpfinal {match "^help$" dispatch natsort::help}}
+ {helpfinal {sub -topic default "NONE"}}
+ }
+ #set args [check_flags \
+ # -caller test1 \
+ # -debugargs 2 \
+ # -return arglist \
+ # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \
+ # -required {none} \
+ # -extras {all} \
+ # -commandprocessors $cmdprocessors \
+ # -values $::argv ]
+ interp alias {} do_filter {} ::flagfilter::check_flags
+
+ #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld
+ set cmdprocessors {
+ {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}}
+ {helpcmd {sub -operand default \uFFFF singleopts {-l}}}
+ {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}}
+ {lscmd {sub dir default "\uFFFF"}}
+ {lscmd {sub dir2 default "\uFFFF"}}
+ {lscmd {sub dir3 default "\uFFFF"}}
+ {lscmd {sub dir4 default "\uFFFF"}}
+ {lscmd {sub dir5 default "\uFFFF"}}
+ {lscmd {sub dir6 default "\uFFFF"}}
+ {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}}
+ {runtests {sub testname default "1" singleopts {-l}}}
+ {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}}
+ }
+ set arglist [do_filter \
+ -debugargs 0 \
+ -debugargsonerror 2 \
+ -caller cline_dispatch1 \
+ -return all \
+ -soloflags {-v -x} \
+ -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \
+ -required {all} \
+ -extras {all} \
+ -commandprocessors $cmdprocessors \
+ -values $::argv ]
+
+
+ #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld
+ set cmdprocessors {
+ {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}}
+ {testcmd {sub testname default "1" singleopts {-l}}}
+ }
+ set arglist [check_flags \
+ -debugargs 0 \
+ -caller cline_dispatch2 \
+ -return all \
+ -soloflags {-v -l} \
+ -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \
+ -required {all} \
+ -extras {all} \
+ -commandprocessors $cmdprocessors \
+ -values $::argv ]
+
+
+
+
+ #set cmdprocessors [list]
+ #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ]
+
+ #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ]
+ #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ]
+ #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ]
+
+ puts stderr "natsort directcall exit"
+ flush stderr
+ exit 0
+
+ if {$::argc} {
+
+ }
+ }
+}
+
+
+package provide natsort [namespace eval natsort {
+ variable version
+ set version 0.1.1.6
+}]
+
+
diff --git a/src/vfs/_vfscommon.vfs/modules/oolib-0.1.tm b/src/bootsupport/modules_tcl8/oolib-0.1.2.tm
similarity index 72%
rename from src/vfs/_vfscommon.vfs/modules/oolib-0.1.tm
rename to src/bootsupport/modules_tcl8/oolib-0.1.2.tm
index 3756fceb..858c61cd 100644
--- a/src/vfs/_vfscommon.vfs/modules/oolib-0.1.tm
+++ b/src/bootsupport/modules_tcl8/oolib-0.1.2.tm
@@ -2,13 +2,13 @@
#
package provide oolib [namespace eval oolib {
variable version
- set version 0.1
+ set version 0.1.2
}]
namespace eval oolib {
oo::class create collection {
variable o_data ;#dict
- variable o_alias
+ #variable o_alias
constructor {} {
set o_data [dict create]
}
@@ -24,6 +24,7 @@ namespace eval oolib {
method names {{globOrIdx {}}} {
if {[llength $globOrIdx]} {
if {[string is integer -strict $globOrIdx]} {
+ set idx $globOrIdx
if {$idx < 0} {
set idx "end-[expr {abs($idx + 1)}]"
}
@@ -65,12 +66,13 @@ namespace eval oolib {
}
method item {key} {
if {[string is integer -strict $key]} {
- if {$key > 0} {
+ if {$key >= 0} {
set valposn [expr {(2*$key) +1}]
return [lindex $o_data $valposn]
} else {
set key "end-[expr {abs($key + 1)}]"
- return [lindex [dict keys $o_data] $key]
+ return [lindex $o_data $key]
+ #return [lindex [dict keys $o_data] $key]
}
}
if {[dict exists $o_data $key]} {
@@ -101,37 +103,38 @@ namespace eval oolib {
}
}
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists?
- method alias {newAlias existingKeyOrAlias} {
- if {[string is integer -strict $newAlias]} {
- error "[self object] collection key alias cannot be integer"
- }
- if {[string length $existingKeyOrAlias]} {
- set o_alias($newAlias) $existingKeyOrAlias
- } else {
- unset o_alias($newAlias)
- }
- }
- method aliases {{key ""}} {
- if {[string length $key]} {
- set result [list]
- foreach {n v} [array get o_alias] {
- if {$v eq $key} {
- lappend result $n $v
- }
- }
- return $result
- } else {
- return [array get o_alias]
- }
- }
- #if the supplied index is an alias, return the underlying key; else return the index supplied.
- method realKey {idx} {
- if {[catch {set o_alias($idx)} key]} {
- return $idx
- } else {
- return $key
- }
- }
+ #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well?
+ #method alias {newAlias existingKeyOrAlias} {
+ # if {[string is integer -strict $newAlias]} {
+ # error "[self object] collection key alias cannot be integer"
+ # }
+ # if {[string length $existingKeyOrAlias]} {
+ # set o_alias($newAlias) $existingKeyOrAlias
+ # } else {
+ # unset o_alias($newAlias)
+ # }
+ #}
+ #method aliases {{key ""}} {
+ # if {[string length $key]} {
+ # set result [list]
+ # foreach {n v} [array get o_alias] {
+ # if {$v eq $key} {
+ # lappend result $n $v
+ # }
+ # }
+ # return $result
+ # } else {
+ # return [array get o_alias]
+ # }
+ #}
+ ##if the supplied index is an alias, return the underlying key; else return the index supplied.
+ #method realKey {idx} {
+ # if {[catch {set o_alias($idx)} key]} {
+ # return $idx
+ # } else {
+ # return $key
+ # }
+ #}
method add {value key} {
if {[string is integer -strict $key]} {
error "[self object] collection key must not be an integer. Use another structure if integer keys required"
@@ -166,7 +169,10 @@ namespace eval oolib {
set o_data [dict create]
return
}
- method reverse {} {
+ method reverse_the_collection {} {
+ #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs
+ #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy.
+ #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations.
set dictnew [dict create]
foreach k [lreverse [dict keys $o_data]] {
dict set dictnew $k [dict get $o_data $k]
diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm b/src/bootsupport/modules_tcl8/overtype-1.6.6.tm
similarity index 99%
rename from src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm
rename to src/bootsupport/modules_tcl8/overtype-1.6.6.tm
index 9363fb6d..b4e59ec6 100644
--- a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm
+++ b/src/bootsupport/modules_tcl8/overtype-1.6.6.tm
@@ -7,7 +7,7 @@
# (C) Julian Noble 2003-2023
#
# @@ Meta Begin
-# Application overtype 1.6.5
+# Application overtype 1.6.6
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@@ -17,7 +17,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
-#[manpage_begin overtype_module_overtype 0 1.6.5]
+#[manpage_begin overtype_module_overtype 0 1.6.6]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
@@ -2713,7 +2713,8 @@ tcl::namespace::eval overtype {
if {$idx > [llength $outcols]-1} {
lappend outcols " "
#tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack?
- lset understacks $idx [list]
+ #lset understacks $idx [list] ;#will get index $i out of range error
+ lappend understacks [list] ;#REVIEW
incr idx
incr cursor_column
} else {
@@ -4765,7 +4766,7 @@ tcl::namespace::eval overtype {
## Ready
package provide overtype [tcl::namespace::eval overtype {
variable version
- set version 1.6.5
+ set version 1.6.6
}]
return
diff --git a/src/vendormodules/pattern-1.2.4.tm b/src/bootsupport/modules_tcl8/pattern-1.2.4.tm
similarity index 100%
rename from src/vendormodules/pattern-1.2.4.tm
rename to src/bootsupport/modules_tcl8/pattern-1.2.4.tm
diff --git a/src/bootsupport/modules_tcl8/pattern-1.2.8.tm b/src/bootsupport/modules_tcl8/pattern-1.2.8.tm
new file mode 100644
index 00000000..7f5cf4c0
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/pattern-1.2.8.tm
@@ -0,0 +1,1288 @@
+# -*- tcl -*-
+# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt
+#
+#PATTERN
+# - A prototype-based Object system.
+#
+# Julian Noble 2003
+# License: Public domain
+#
+
+# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern.
+#
+#
+# Pattern uses a mixture of class-based and prototype-based object instantiation.
+#
+# A pattern object has 'properties' and 'methods'
+# The system makes a distinction between them with regards to the access syntax for write operations,
+# and yet provides unity in access syntax for read operations.
+# e.g >object . myProperty
+# will return the value of the property 'myProperty'
+# >ojbect . myMethod
+# will return the result of the method 'myMethod'
+# contrast this with the write operations:
+# set [>object . myProperty .] blah
+# >object . myMethod blah
+# however, the property can also be read using:
+# set [>object . myProperty .]
+# Note the trailing . to give us a sort of 'reference' to the property.
+# this is NOT equivalent to
+# set [>object . myProperty]
+# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property
+# i.e it is equivalent in this case to: set blah
+
+#All objects are represented by a command, the name of which contains a leading ">".
+#Any commands in the interp which use this naming convention are assumed to be a pattern object.
+#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined)
+
+#All user-added properties & methods of the wrapped object are accessed
+# using the separator character "."
+#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".."
+# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype)
+# you would use the 'Create' metamethod on the pattern object like so:
+# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject
+# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties
+# of the object it was created from. (
+
+
+#The use of the access-syntax separator character "." allows objects to be kept
+# 'clean' in the sense that the only methods &/or properties that can be called this way are ones
+# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax
+# so you are free to implement your own 'Create' method on your object that doesn't conflict with
+# the metamethod.
+
+#Chainability (or how to violate the Law of Demeter!)
+#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other
+# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference
+# structure, without the need to regress to enter matching brackets as is required when using
+# standard TCL command syntax.
+# ie instead of:
+# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething
+# we can use:
+# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething
+#
+# This separates out the object-traversal syntax from the TCL command syntax.
+
+# . is the 'traversal operator' when it appears between items in a commandlist
+# . is the 'reference operator' when it is the last item in a commandlist
+# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'.
+# It marks breaks in the multidimensional structure that correspond to how the data is stored.
+# e.g obj . arraydata x y , x1 y1 z1
+# represents an element of a 5-dimensional array structured as a plane of cubes
+# e.g2 obj . arraydata x y z , x1 y1
+# represents an element of a 5-dimensional array structured as a cube of planes
+# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1
+# .. is the 'meta-traversal operator' when it appears between items in a commandlist
+# .. is the 'meta-info operator'(?) when it is the last item in a commandlist
+
+
+#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing
+# implement iStacks & pStacks (interface stacks & pattern stacks)
+
+#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975
+
+
+#------------------------------------------------------------
+# System objects.
+#------------------------------------------------------------
+#::p::-1 ::p::internals::>metaface
+#::p::0 ::p::ifaces::>null
+#::p::1 ::>pattern
+#------------------------------------------------------------
+
+#TODO
+
+#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?)
+
+
+#CHANGES
+#2018-09 - v 1.2.2
+# varied refactoring
+# Changed invocant datastructure curried into commands (the _ID_ structure)
+# Changed MAP structure to dict
+# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns)
+# updated test suites
+#2018-08 - v 1.2.1
+# split ::p::predatorX functions into separate files (pkgs)
+# e.g patternpredator2-1.0.tm
+# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken
+#
+#2017-08 - v 1.1.6 Fairly big overhaul
+# New predator function using coroutines
+# Added bang operator !
+# Fixed Constructor chaining
+# Added a few tests to test::pattern
+#
+#2008-03 - preserve ::errorInfo during var writes
+
+#2007-11
+#Major overhaul + new functionality + new tests v 1.1
+# new dispatch system - 'predator'.
+# (preparing for multiple interface stacks, multiple invocants etc)
+#
+#
+#2006-05
+# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature.
+#
+#2005-12
+# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top.
+#
+# Fixed so that PatternVariable default applied on Create.
+#
+# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE::::
+# - heading towards multiple-interface objects
+#
+#2005-10-28
+# 1.0.8.1 passes 80/80 tests
+# >object .. Destroy - improved cleanup of interfaces & namespaces.
+#
+#2005-10-26
+# fixes to refsync (still messy!)
+# remove variable traces on REF vars during .. Destroy
+# passes 76/76
+#
+#2005-10-24
+# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined.
+# 1.0.8.0 now passes 75/76
+#
+#2005-10-19
+# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before)
+# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names)
+# 1.0.8.0 (passes 74/76)
+# tests now in own package
+# usage:
+# package require test::pattern
+# test::p::list
+# test::p::run ?nameglob? ?-version ?
+#
+#2005-09?-12
+#
+# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc.
+# fixed @next@ so that destination method resolved at interface compile time instead of call time
+# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x.
+# (before, the overlay only occured when '.. Method' was used to override.)
+#
+#
+# miscellaneous tidy-ups
+#
+# 1.0.7.8 (passes 71/73)
+#
+#2005-09-10
+# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value
+# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier.
+#
+#2005-09-07
+# bugfix indexed write to list property
+# bugfix Variable default value
+# 1.0.7.7 (passes 70/72)
+# fails:
+# arrayproperty.test - array-entire-reference
+# properties.test - property_getter_filter_via_ObjectRef
+#
+#2005-04-22
+# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!)
+#
+# 1.0.7.4
+#
+#2004-11-05
+# basic PropertyRead implementation (non-indexed - no tests!)
+#
+#2004-08-22
+# object creation speedups - (pattern::internals::obj simplified/indirected)
+#
+#2004-08-17
+# indexed property setter fixes + tests
+# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values)
+#
+#2004-08-16
+# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset)
+#
+#2004-08-15
+# reference syncing: ensure writes to properties always trigger traces on property references (+ tests)
+# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger
+# - also trigger on curried traces to indexed properties i.e list and array elements.
+# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties.
+#
+# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .]
+#
+#2004-08-05
+# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write)
+#
+# fix + add tests to support method & property of same name. (method precedence)
+#
+#2004-08-04
+# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var)
+#
+# 1.0.7.1
+# use objectref array access to read properties even when some props unset; + test
+# unset property using array access on object reference; + test
+#
+#
+#2004-07-21
+# object reference changes - array property values appear as list value when accessed using upvared array.
+# bugfixes + tests - properties containing lists (multidimensional access)
+#
+#1.0.7
+#
+#2004-07-20
+# fix default property value append problem
+#
+#2004-07-17
+# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods
+# (
+#
+#2004-06-18
+# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces.
+#
+#2004-06-05
+# change argsafety operator to be anything with leading -
+# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-'
+# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg,
+# the entire dash-prefixed operator is also passed in as an argument.
+# e.g >object . doStuff -window .
+# will call the doStuff method with the 2 parameters -window .
+# >object . doStuff - .
+# will call doStuff with single parameter .
+# >object . doStuff - -window .
+# will result in a reference to the doStuff method with the argument -window 'curried' in.
+#
+#2004-05-19
+#1.0.6
+# fix so custom constructor code called.
+# update Destroy metamethod to unset $self
+#
+#1.0.4 - 2004-04-22
+# bug fixes regarding method specialisation - added test
+#
+#------------------------------------------------------------
+
+package provide pattern [namespace eval pattern {variable version; set version 1.2.8}]
+
+
+namespace eval pattern::util {
+
+ # Generally better to use 'package require $minver-'
+ # - this only gives us a different error
+ proc package_require_min {pkg minver} {
+ if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} {
+ package require $pkg
+ } else {
+ error "Package pattern requires package $pkg of at least version $minver. Available: $available"
+ }
+ }
+}
+
+package require patterncmd 1.2.4-
+package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc)
+
+
+
+#package require cmdline
+package require overtype
+
+#package require md5 ;#will be loaded if/when needed
+#package require md4
+#package require uuid
+
+
+
+
+
+namespace eval pattern {
+ variable initialised 0
+
+
+ if 0 {
+ if {![catch {package require twapi_base} ]} {
+ #twapi is a windows only package
+ #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls.
+ # If available - windows seems to provide a fast uuid generator..
+ #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine)
+ # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid}))
+ interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok
+ } else {
+ #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ)
+ # (e.g 200usec 2018 corei9)
+ #(with or without tcllibc?)
+ #very first call is extremely slow though - 3.5seconds on 2018 corei9
+ package require uuid
+ interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate
+ }
+ #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement)
+ }
+
+
+}
+
+
+
+
+
+
+namespace eval p {
+ #this is also the interp alias namespace. (object commands created here , then renamed into place)
+ #the object aliases are named as incrementing integers.. !todo - consider uuids?
+ variable ID 0
+ namespace eval internals {}
+
+
+ #!??
+ #namespace export ??
+ variable coroutine_instance 0
+}
+
+#-------------------------------------------------------------------------------------
+#review - what are these for?
+#note - this function is deliberately not namespaced
+# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features
+proc process_pattern_aliases {object args} {
+ set o [namespace tail $object]
+ interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .]
+ interp alias {} process_method_$o {} [$object .. Method .]
+ interp alias {} process_constructor_$o {} [$object .. Constructor .]
+}
+#-------------------------------------------------------------------------------------
+
+
+
+
+#!store all interface objects here?
+namespace eval ::p::ifaces {}
+
+
+
+#K combinator - see http://wiki.tcl.tk/1923
+#proc ::p::K {x y} {set x}
+#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah]
+
+
+
+
+
+
+
+
+proc ::p::internals::(VIOLATE) {_ID_ violation_script} {
+ #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script]
+ set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]]
+
+ if {![dict get $processed explicitvars]} {
+ #no explicit var statements - we need the implicit ones
+ set self [set ::p::${_ID_}::(self)]
+ set IFID [lindex [set $self] 1 0 end]
+ #upvar ::p::${IFID}:: self_IFINFO
+
+
+ set varDecls {}
+ set vlist [array get ::p::${IFID}:: v,name,*]
+ set _k ""; set v ""
+ if {[llength $vlist]} {
+ append varDecls "upvar #0 "
+ foreach {_k v} $vlist {
+ append varDecls "::p::\${_ID_}::$v $v "
+ }
+ append varDecls "\n"
+ }
+
+ #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out]
+ set violation_script $varDecls\n[dict get $processed body]
+
+ #tidy up
+ unset processed varDecls self IFID _k v
+ } else {
+ set violation_script [dict get $processed body]
+ }
+ unset processed
+
+
+
+
+ #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible.
+ eval "unset violation_script;$violation_script"
+}
+
+
+proc ::p::internals::DestroyObjectsBelowNamespace {ns} {
+ #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n"
+
+ set nsparts [split [string trim [string map {:: :} $ns] :] :]
+ if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} {
+ #ns not of form ::p::?::_ref
+
+ foreach obj [info commands ${ns}::>*] {
+ #catch {::p::meta::Destroy $obj}
+ #puts ">>found object $obj below ns $ns - destroying $obj"
+ $obj .. Destroy
+ }
+ }
+
+ #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR]
+ #foreach tinfo $traces {
+ # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo
+ #}
+ #unset -nocomplain ${ns}::-->PATTERN_ANCHOR
+
+ foreach sub [namespace children $ns] {
+ ::p::internals::DestroyObjectsBelowNamespace $sub
+ }
+}
+
+
+
+
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+#################################################
+
+
+
+
+
+
+
+
+
+proc ::p::get_new_object_id {} {
+ tailcall incr ::p::ID
+ #tailcall ::pattern::new_uuid
+}
+
+#create a new minimal object - with no interfaces or patterns.
+
+#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {}
+proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} {
+
+ #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID"
+
+ if {$OID eq "-2"} {
+ set OID [::p::get_new_object_id]
+ #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?)
+ #set OID [pattern::new_uuid]
+ }
+ #if $wrapped provided it is assumed to be an existing namespace.
+ #if {[string length $wrapped]} {
+ # #???
+ #}
+
+ #sanity check - alias must not exist for this OID
+ if {[llength [interp alias {} ::p::$OID]]} {
+ error "Object alias '::p::$OID' already exists - cannot create new object with this id"
+ }
+
+ #system 'varspaces' -
+
+ #until we have a version of Tcl that doesn't have 'creative writing' scope issues -
+ # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword.
+ # (see http://wiki.tcl.tk/1030 'Dangers of creative writing')
+ #set o_open 1 - every object is initially also an open interface (?)
+ #NOTE! comments within namespace eval slow it down.
+ namespace eval ::p::$OID {
+ #namespace ensemble create
+ namespace eval _ref {}
+ namespace eval _meta {}
+ namespace eval _iface {
+ variable o_usedby;
+ variable o_open 1;
+ array set o_usedby [list];
+ variable o_varspace "" ;
+ variable o_varspaces [list];
+ variable o_methods [dict create];
+ variable o_properties [dict create];
+ variable o_variables;
+ variable o_propertyunset_handlers;
+ set o_propertyunset_handlers [dict create]
+ }
+ }
+
+ #set alias ::p::$OID
+
+ #objectid alis default_method object_command wrapped_namespace
+ set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped]
+
+ #MAP is a dict
+ set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}]
+
+
+
+ #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token
+ #we've already checked that ::p::$OID doesn't pre-exist
+ # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias
+ #interp alias {} ::p::$OID {} ::p::internals::predator $MAP
+
+
+ # _ID_ structure
+ set invocants_dict [dict create this [list $INVOCANTDATA] ]
+ #puts stdout "New _ID_structure: $interfaces_dict"
+ set _ID_ [dict create i $invocants_dict context ""]
+
+
+ interp alias {} ::p::$OID {} ::p::internals::predator $_ID_
+ #rename the command into place - thus the alias & the command name no longer match!
+ rename ::p::$OID $cmd
+
+ set ::p::${OID}::_meta::map $MAP
+
+ # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something
+ interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_
+
+ #set p2 [string map {> ?} $cmd]
+ #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_
+
+
+ #trace add command $cmd delete "$cmd .. Destroy ;#"
+ #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]"
+
+ trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename"
+ #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?)
+
+ #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'"
+
+
+ #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\""
+ #trace add command $cmd delete "puts deleting$cmd ;#"
+ #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\""
+
+
+ #puts "--> new_object returning map $MAP"
+ return $MAP
+}
+
+
+
+
+#>x .. Create >y
+# ".." is special case equivalent to "._."
+# (whereas in theory it would be ".default.")
+# "." is equivalent to ".default." is equivalent to ".default.default." (...)
+
+#>x ._. Create >y
+#>x ._.default. Create >y ???
+#
+#
+
+# create object using 'blah' as source interface-stack ?
+#>x .blah. .. Create >y
+#>x .blah,_. ._. Create .iStackDestination. >y
+
+
+
+#
+# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _]
+# the 1st item, blah in this case becomes the 'default' iStack.
+#
+#>x .*.
+# cast to object with all iStacks
+#
+#>x .*,!_.
+# cast to object with all iStacks except _
+#
+# ---------------------
+#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@'
+# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not.
+#
+#eg1: >x & >y . some_multi_method arg arg
+# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects)
+# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these'
+# The invocant signature is thus {these 2}
+# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1})
+# Invocation roles can be specified in the call using the @ operator.
+# e.g >x & >y @ points . some_multi_method arg arg
+# The invocant signature for this is: {points 2}
+#
+#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path
+# This has the signature {objects n plane 1} where n depends on the length of the list $objects
+#
+#
+# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration.
+# e.g set pointset [>x & >y .]
+# We can now call multimethods on $pointset
+#
+
+
+
+
+
+
+#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package)
+proc ::pattern::predatorversion {{ver ""}} {
+ variable active_predatorversion
+ set allowed_predatorversions {1 2}
+ set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions
+
+ if {![info exists active_predatorversion]} {
+ set first_time_set 1
+ } else {
+ set first_time_set 0
+ }
+
+ if {$ver eq ""} {
+ #get version
+ if {$first_time_set} {
+ set active_predatorversions $default_predatorversion
+ }
+ return $active_predatorversion
+ } else {
+ #set version
+ if {$ver ni $allowed_predatorversions} {
+ error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions"
+ }
+
+ if {!$first_time_set} {
+ if {$active_predatorversion eq $ver} {
+ #puts stderr "Active predator version is already '$ver'"
+ #ok - nothing to do
+ return $active_predatorversion
+ } else {
+ package require patternpredator$ver 1.2.4-
+ if {![llength [info commands ::p::predator$ver]]} {
+ error "Unable to set predatorversion - command ::p::predator$ver not found"
+ }
+ rename ::p::internals::predator ::p::predator$active_predatorversion
+ }
+ }
+ package require patternpredator$ver 1.2.4-
+ if {![llength [info commands ::p::predator$ver]]} {
+ error "Unable to set predatorversion - command ::p::predator$ver not found"
+ }
+
+ rename ::p::predator$ver ::p::internals::predator
+ set active_predatorversion $ver
+
+ return $active_predatorversion
+ }
+}
+::pattern::predatorversion 2
+
+
+
+
+
+
+
+
+
+
+
+
+# >pattern has object ID 1
+# meta interface has object ID 0
+proc ::pattern::init args {
+
+ if {[set ::pattern::initialised]} {
+ if {[llength $args]} {
+ #if callers want to avoid this error, they can do their own check of $::pattern::initialised
+ error "pattern package is already initialised. Unable to apply args: $args"
+ } else {
+ return 1
+ }
+ }
+
+ #this seems out of date.
+ # - where is PatternPropertyRead?
+ # - Object is obsolete
+ # - Coinjoin, Combine don't seem to exist
+ array set ::p::metaMethods {
+ Clone object
+ Conjoin object
+ Combine object
+ Create object
+ Destroy simple
+ Info simple
+ Object simple
+ PatternProperty simple
+ PatternPropertyWrite simple
+ PatternPropertyUnset simple
+ Property simple
+ PropertyWrite simple
+ PatternMethod simple
+ Method simple
+ PatternVariable simple
+ Variable simple
+ Digest simple
+ PatternUnknown simple
+ Unknown simple
+ }
+ array set ::p::metaProperties {
+ Properties object
+ Methods object
+ PatternProperties object
+ PatternMethods object
+ }
+
+
+
+
+
+ #create metaface - IID = -1 - also OID = -1
+ # all objects implement this special interface - accessed via the .. operator.
+
+
+
+
+
+ set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface
+
+
+ #OID = 0
+ ::p::internals::new_object ::p::ifaces::>null "" 0
+
+ #? null object has itself as level0 & level1 interfaces?
+ #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]]
+
+ #null interface should always have 'usedby' members. It should never be extended.
+ array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array
+ set ::p::0::_iface::o_open 0
+
+ set ::p::0::_iface::o_constructor [list]
+ set ::p::0::_iface::o_variables [list]
+ set ::p::0::_iface::o_properties [dict create]
+ set ::p::0::_iface::o_methods [dict create]
+ set ::p::0::_iface::o_varspace ""
+ set ::p::0::_iface::o_varspaces [list]
+ array set ::p::0::_iface::o_definition [list]
+ set ::p::0::_iface::o_propertyunset_handlers [dict create]
+
+
+
+
+ ###############################
+ # OID = 1
+ # >pattern
+ ###############################
+ ::p::internals::new_object ::>pattern "" 1
+
+ #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]]
+
+
+ array set ::p::1::_iface::o_usedby [list] ;#'usedby' array
+
+ set _self ::pattern
+
+ #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1
+ #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1
+
+
+
+ #1)this object references its interfaces
+ #lappend ID $IFID $IFID_1
+ #lset SELFMAP 1 0 $IFID
+ #lset SELFMAP 2 0 $IFID_1
+
+
+ #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND]
+ #proc ::>pattern args $body
+
+
+
+
+ #######################################################################################
+ #OID = 2
+ # >ifinfo interface for accessing interfaces.
+ #
+ ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object
+ set ::p::2::_iface::o_constructor [list]
+ set ::p::2::_iface::o_variables [list]
+ set ::p::2::_iface::o_properties [dict create]
+ set ::p::2::_iface::o_methods [dict create]
+ set ::p::2::_iface::o_varspace ""
+ set ::p::2::_iface::o_varspaces [list]
+ array set ::p::2::_iface::o_definition [list]
+ set ::p::2::_iface::o_open 1 ;#open for extending
+
+ ::p::ifaces::>2 .. AddInterface 2
+
+ #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations
+ #(bootstrap because we can't yet use metaface methods on it)
+
+
+
+ proc ::p::2::_iface::isOpen.1 {_ID_} {
+ return $::p::2::_iface::o_open
+ }
+ interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1
+
+ proc ::p::2::_iface::isClosed.1 {_ID_} {
+ return [expr {!$::p::2::_iface::o_open}]
+ }
+ interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1
+
+ proc ::p::2::_iface::open.1 {_ID_} {
+ set ::p::2::_iface::o_open 1
+ }
+ interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1
+
+ proc ::p::2::_iface::close.1 {_ID_} {
+ set ::p::2::_iface::o_open 0
+ }
+ interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1
+
+
+ #proc ::p::2::_iface::(GET)properties.1 {_ID_} {
+ # set ::p::2::_iface::o_properties
+ #}
+ #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1
+
+ #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties
+
+
+ #proc ::p::2::_iface::(GET)methods.1 {_ID_} {
+ # set ::p::2::_iface::o_methods
+ #}
+ #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1
+ #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods
+
+
+
+
+
+ #link from object to interface (which in this case are one and the same)
+
+ #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --]
+ #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --]
+ #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --]
+ #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --]
+
+ interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen
+ interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed
+ interp alias {} ::p::2::open {} ::p::2::_iface::open
+ interp alias {} ::p::2::close {} ::p::2::_iface::close
+
+
+ #namespace eval ::p::2 "namespace export $method"
+
+ #######################################################################################
+
+
+
+
+
+
+ set ::pattern::initialised 1
+
+
+ ::p::internals::new_object ::p::>interface "" 3
+ #create a convenience object on which to manipulate the >ifinfo interface
+ #set IF [::>pattern .. Create ::p::>interface]
+ set IF ::p::>interface
+
+
+ #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects?
+ # (or is forcing end user to add their own pStack/iStack ok .. ?)
+ #
+ ::p::>interface .. AddPatternInterface 2 ;#
+
+ ::p::>interface .. PatternVarspace _iface
+
+ ::p::>interface .. PatternProperty methods
+ ::p::>interface .. PatternPropertyRead methods {} {
+ varspace _iface
+ var {o_methods alias}
+ return $alias
+ }
+ ::p::>interface .. PatternProperty properties
+ ::p::>interface .. PatternPropertyRead properties {} {
+ varspace _iface
+ var o_properties
+ return $o_properties
+ }
+ ::p::>interface .. PatternProperty variables
+
+ ::p::>interface .. PatternProperty varspaces
+
+ ::p::>interface .. PatternProperty definition
+
+ ::p::>interface .. Constructor {{usedbylist {}}} {
+ #var this
+ #set this @this@
+ #set ns [$this .. Namespace]
+ #puts "-> creating ns ${ns}::_iface"
+ #namespace eval ${ns}::_iface {}
+
+ varspace _iface
+ var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces
+
+ set o_constructor [list]
+ set o_variables [list]
+ set o_properties [dict create]
+ set o_methods [dict create]
+ set o_varspaces [list]
+ array set o_definition [list]
+
+ foreach usedby $usedbylist {
+ set o_usedby(i$usedby) 1
+ }
+
+
+ }
+ ::p::>interface .. PatternMethod isOpen {} {
+ varspace _iface
+ var o_open
+
+ return $o_open
+ }
+ ::p::>interface .. PatternMethod isClosed {} {
+ varspace _iface
+ var o_open
+
+ return [expr {!$o_open}]
+ }
+ ::p::>interface .. PatternMethod open {} {
+ varspace _iface
+ var o_open
+ set o_open 1
+ }
+ ::p::>interface .. PatternMethod close {} {
+ varspace _iface
+ var o_open
+ set o_open 0
+ }
+ ::p::>interface .. PatternMethod refCount {} {
+ varspace _iface
+ var o_usedby
+ return [array size o_usedby]
+ }
+
+ set ::p::2::_iface::o_open 1
+
+
+
+
+ uplevel #0 {pattern::util::package_require_min patternlib 1.2.4}
+ #uplevel #0 {package require patternlib}
+ return 1
+}
+
+
+
+proc ::p::merge_interface {old new} {
+ #puts stderr " ** ** ** merge_interface $old $new"
+ set ns_old ::p::$old
+ set ns_new ::p::$new
+
+ upvar #0 ::p::${new}:: IFACE
+ upvar #0 ::p::${old}:: IFACEX
+
+ if {![catch {set c_arglist $IFACEX(c,args)}]} {
+ #constructor
+ #for now.. just add newer constructor regardless of any existing one
+ #set IFACE(c,args) $IFACEX(c,args)
+
+ #if {![info exists IFACE(c,args)]} {
+ # #target interface didn't have a constructor
+ #
+ #} else {
+ # #
+ #}
+ }
+
+
+ set methods [::list]
+ foreach nm [array names IFACEX m-1,name,*] {
+ lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden)
+ }
+
+ #puts " *** merge interface $old -> $new ****merging-in methods: $methods "
+
+ foreach method $methods {
+ if {![info exists IFACE(m-1,name,$method)]} {
+ #target interface doesn't yet have this method
+
+ set THISNAME $method
+
+ if {![string length [info command ${ns_new}::$method]]} {
+
+ if {![set ::p::${old}::_iface::o_open]} {
+ #interp alias {} ${ns_new}::$method {} ${ns_old}::$method
+ #namespace eval $ns_new "namespace export [namespace tail $method]"
+ } else {
+ #wait to compile
+ }
+
+ } else {
+ error "merge interface - command collision "
+ }
+ #set i 2 ???
+ set i 1
+
+ } else {
+ #!todo - handle how?
+ #error "command $cmd already exists in interface $new"
+
+
+ set i [incr IFACE(m-1,chain,$method)]
+
+ set THISNAME ___system___override_${method}_$i
+
+ #move metadata using subindices for delegated methods
+ set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method)
+ set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method)
+ set IFACE(mp-$i,$method) $IFACE(mp-1,$method)
+
+ set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method)
+ set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method)
+
+
+ #set next [::p::next_script $IFID0 $method]
+ if {![string length [info command ${ns_new}::$THISNAME]]} {
+ if {![set ::p::${old}::_iface::o_open]} {
+ interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method
+ namespace eval $ns_new "namespace export $method"
+ } else {
+ #wait for compile
+ }
+ } else {
+ error "merge_interface - command collision "
+ }
+
+ }
+
+ array set IFACE [::list \
+ m-1,chain,$method $i \
+ m-1,body,$method $IFACEX(m-1,body,$method) \
+ m-1,args,$method $IFACEX(m-1,args,$method) \
+ m-1,name,$method $THISNAME \
+ m-1,iface,$method $old \
+ ]
+
+ }
+
+
+
+
+
+ #array set ${ns_new}:: [array get ${ns_old}::]
+
+
+ #!todo - review
+ #copy everything else across..
+
+ foreach {nm v} [array get IFACEX] {
+ #puts "-.- $nm"
+ if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} {
+ set IFACE($nm) $v
+ }
+ }
+
+ #!todo -write a test
+ set ::p::${new}::_iface::o_open 1
+
+ #!todo - is this done also when iface compiled?
+ #namespace eval ::p::$new {namespace ensemble create}
+
+
+ #puts stderr "copy_interface $old $new"
+
+ #assume that the (usedby) data is now obsolete
+ #???why?
+ #set ${ns_new}::(usedby) [::list]
+
+ #leave ::(usedby) reference in place
+
+ return
+}
+
+
+
+
+#detect attempt to treat a reference to a method as a property
+proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} {
+#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args"
+ lassign [lrange $args end-2 end] vtraced vidx op
+ #NOTE! cannot rely on vtraced as it may have been upvared
+
+ switch -- $op {
+ write {
+ error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])"
+ }
+ unset {
+ #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace
+ #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args]
+
+ #!todo - don't use vtraced!
+ trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args]
+
+ #pointless raising an error as "Any errors in unset traces are ignored"
+ #error "cannot unset. $field is a method not a property"
+ }
+ read {
+ error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])"
+ }
+ array {
+ error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])"
+ #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args"
+ }
+ }
+
+ return
+}
+
+
+
+
+#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points.
+#
+# The 'dispatcher' is an object instance's underlying object command.
+#
+
+#proc ::p::make_dispatcher {obj ID IFID} {
+# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] {
+# ::p::@IID@ $methprop @oid@ {*}$args
+# }]
+# return
+#}
+
+
+
+
+################################################################################################################################################
+################################################################################################################################################
+################################################################################################################################################
+
+#aliased from ::p::${OID}::
+# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something
+proc ::p::internals::no_default_method {_ID_ args} {
+ puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'"
+ lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped
+ tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)"
+}
+
+#force 1 will extend an interface even if shared. (??? why is this necessary here?)
+#if IID empty string - create the interface.
+proc ::p::internals::expand_interface {IID {force 0}} {
+ #puts stdout ">>> expand_interface $IID [info level -1]<<<"
+ if {![string length $IID]} {
+ #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1)
+ set iid [expr {$::p::ID + 1}]
+ ::p::>interface .. Create ::p::ifaces::>$iid
+ return $iid
+ } else {
+ if {[set ::p::${IID}::_iface::o_open]} {
+ #interface open for extending - shared or not!
+ return $IID
+ }
+
+ if {[array size ::p::${IID}::_iface::o_usedby] > 1} {
+ #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby
+
+ #oops.. shared interface. Copy before specialising it.
+ set prev_IID $IID
+
+ #set IID [::p::internals::new_interface]
+ set IID [expr {$::p::ID + 1}]
+ ::p::>interface .. Create ::p::ifaces::>$IID
+
+ ::p::internals::linkcopy_interface $prev_IID $IID
+ #assert: prev_usedby contains at least one other element.
+ }
+
+ #whether copied or not - mark as open for extending.
+ set ::p::${IID}::_iface::o_open 1
+ return $IID
+ }
+}
+
+#params: old - old (shared) interface ID
+# new - new interface ID
+proc ::p::internals::linkcopy_interface {old new} {
+ #puts stderr " ** ** ** linkcopy_interface $old $new"
+ set ns_old ::p::${old}::_iface
+ set ns_new ::p::${new}::_iface
+
+
+
+ foreach nsmethod [info commands ${ns_old}::*.1] {
+ #puts ">>> adding $nsmethod to iface $new"
+ set tail [namespace tail $nsmethod]
+ set method [string range $tail 0 end-2] ;#strip .1
+
+ if {![llength [info commands ${ns_new}::$method]]} {
+
+ set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1
+
+ #link from new interface namespace to existing one.
+ #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...)
+ #!todo? verify?
+ #- actual link is chainslot to chainslot
+ interp alias {} ${ns_new}::$method.1 {} $oldhead
+
+ #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head?
+
+
+ #chainhead pointer within new interface
+ interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1
+
+ namespace eval $ns_new "namespace export $method"
+
+ #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} {
+ # lappend ${ns_new}::o_methods $method
+ #}
+ } else {
+ if {$method eq "(VIOLATE)"} {
+ #ignore for now
+ #!todo
+ continue
+ }
+
+ #!todo - handle how?
+ #error "command $cmd already exists in interface $new"
+
+ #warning - existing chainslot will be completely shadowed by linked method.
+ # - existing one becomes unreachable. #!todo review!?
+
+
+ error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)"
+
+ }
+ }
+
+
+ #foreach propinf [set ${ns_old}::o_properties] {
+ # lassign $propinf prop _default
+ # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop
+ # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop
+ # lappend ${ns_new}::o_properties $propinf
+ #}
+
+
+ set ${ns_new}::o_variables [set ${ns_old}::o_variables]
+ set ${ns_new}::o_properties [set ${ns_old}::o_properties]
+ set ${ns_new}::o_methods [set ${ns_old}::o_methods]
+ set ${ns_new}::o_constructor [set ${ns_old}::o_constructor]
+
+
+ set ::p::${old}::_iface::o_usedby(i$new) linkcopy
+
+
+ #obsolete.?
+ array set ::p::${new}:: [array get ::p::${old}:: ]
+
+
+
+ #!todo - is this done also when iface compiled?
+ #namespace eval ::p::${new}::_iface {namespace ensemble create}
+
+
+ #puts stderr "copy_interface $old $new"
+
+ #assume that the (usedby) data is now obsolete
+ #???why?
+ #set ${ns_new}::(usedby) [::list]
+
+ #leave ::(usedby) reference in place for caller to change as appropriate - 'copy'
+
+ return
+}
+################################################################################################################################################
+################################################################################################################################################
+################################################################################################################################################
+
+pattern::init
+
+return $::pattern::version
diff --git a/src/bootsupport/modules_tcl8/patterncmd-1.2.4.tm b/src/bootsupport/modules_tcl8/patterncmd-1.2.4.tm
new file mode 100644
index 00000000..ca061a7c
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/patterncmd-1.2.4.tm
@@ -0,0 +1,645 @@
+package provide patterncmd [namespace eval patterncmd {
+ variable version
+
+ set version 1.2.4
+}]
+
+
+namespace eval pattern {
+ variable idCounter 1 ;#used by pattern::uniqueKey
+
+ namespace eval cmd {
+ namespace eval util {
+ package require overtype
+ variable colwidths_lib [dict create]
+ variable colwidths_lib_default 15
+
+ dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""]
+ dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""]
+ dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""]
+ dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"]
+
+ proc colhead {type args} {
+ upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
+ set line ""
+ foreach colname [dict keys $colwidths] {
+ append line "[col $type $colname [string totitle $colname] {*}$args]"
+ }
+ return $line
+ }
+ proc colbreak {type} {
+ upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
+ set line ""
+ foreach colname [dict keys $colwidths] {
+ append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]"
+ }
+ return $line
+ }
+ proc col {type col val args} {
+ # args -head bool -tail bool ?
+ #----------------------------------------------------------------------------
+ set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify]
+ dict set default -backchar ""
+ dict set default -headchar ""
+ dict set default -tailchar ""
+ dict set default -headoverridechar ""
+ dict set default -tailoverridechar ""
+ dict set default -justify "left"
+ if {([llength $args] % 2) != 0} {
+ error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' "
+ }
+ foreach {k v} $args {
+ if {$k ni $known_opts} {
+ error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'"
+ }
+ }
+ set opts [dict merge $default $args]
+ set backchar [dict get $opts -backchar]
+ set headchar [dict get $opts -headchar]
+ set tailchar [dict get $opts -tailchar]
+ set headoverridechar [dict get $opts -headoverridechar]
+ set tailoverridechar [dict get $opts -tailoverridechar]
+ set justify [dict get $opts -justify]
+ #----------------------------------------------------------------------------
+
+
+
+ upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
+ #calculate headwidths
+ set headwidth 0
+ set tailwidth 0
+ foreach {key def} $colwidths {
+ set thisheadlen [string length [dict get $def head]]
+ if {$thisheadlen > $headwidth} {
+ set headwidth $thisheadlen
+ }
+ set thistaillen [string length [dict get $def tail]]
+ if {$thistaillen > $tailwidth} {
+ set tailwidth $thistaillen
+ }
+ }
+
+
+ set spec [dict get $colwidths $col]
+ if {[string length $backchar]} {
+ set ch $backchar
+ } else {
+ set ch [dict get $spec ch]
+ }
+ set num [dict get $spec num]
+ set headchar [dict get $spec head]
+ set tailchar [dict get $spec tail]
+
+ if {[string length $headchar]} {
+ set headchar $headchar
+ }
+ if {[string length $tailchar]} {
+ set tailchar $tailchar
+ }
+ #overrides only apply if the head/tail has a length
+ if {[string length $headchar]} {
+ if {[string length $headoverridechar]} {
+ set headchar $headoverridechar
+ }
+ }
+ if {[string length $tailchar]} {
+ if {[string length $tailoverridechar]} {
+ set tailchar $tailoverridechar
+ }
+ }
+ set head [string repeat $headchar $headwidth]
+ set tail [string repeat $tailchar $tailwidth]
+
+ set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]]
+ if {$justify eq "left"} {
+ set left_done [overtype::left $base "$head$val"]
+ return [overtype::right $left_done "$tail"]
+ } elseif {$justify in {centre center}} {
+ set mid_done [overtype::centre $base $val]
+ set left_mid_done [overtype::left $mid_done $head]
+ return [overtype::right $left_mid_done $tail]
+ } else {
+ set right_done [overtype::right $base "$val$tail"]
+ return [overtype::left $right_done $head]
+ }
+
+ }
+
+ }
+ }
+
+}
+
+#package require pattern
+
+proc ::pattern::libs {} {
+ set libs [list \
+ pattern {-type core -note "alternative:pattern2"}\
+ pattern2 {-type core -note "alternative:pattern"}\
+ patterncmd {-type core}\
+ metaface {-type core}\
+ patternpredator2 {-type core}\
+ patterndispatcher {-type core}\
+ patternlib {-type core}\
+ patterncipher {-type optional -note optional}\
+ ]
+
+
+
+ package require overtype
+ set result ""
+
+ append result "[cmd::util::colbreak lib]\n"
+ append result "[cmd::util::colhead lib -justify centre]\n"
+ append result "[cmd::util::colbreak lib]\n"
+ foreach libname [dict keys $libs] {
+ set libinfo [dict get $libs $libname]
+
+ append result [cmd::util::col lib library $libname]
+ if {[catch [list package present $libname] ver]} {
+ append result [cmd::util::col lib version "N/A"]
+ } else {
+ append result [cmd::util::col lib version $ver]
+ }
+ append result [cmd::util::col lib type [dict get $libinfo -type]]
+
+ if {[dict exists $libinfo -note]} {
+ set note [dict get $libinfo -note]
+ } else {
+ set note ""
+ }
+ append result [cmd::util::col lib note $note]
+ append result "\n"
+ }
+ append result "[cmd::util::colbreak lib]\n"
+ return $result
+}
+
+proc ::pattern::record {recname fields} {
+ if {[uplevel 1 [list namespace which $recname]] ne ""} {
+ error "(pattern::record) Can't create command '$recname': A command of that name already exists"
+ }
+
+ set index -1
+ set accessor [list ::apply {
+ {index rec args}
+ {
+ if {[llength $args] == 0} {
+ return [lindex $rec $index]
+ }
+ if {[llength $args] == 1} {
+ return [lreplace $rec $index $index [lindex $args 0]]
+ }
+ error "Invalid number of arguments."
+ }
+
+ }]
+
+ set map {}
+ foreach field $fields {
+ dict set map $field [linsert $accessor end [incr index]]
+ }
+ uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
+}
+proc ::pattern::record2 {recname fields} {
+ if {[uplevel 1 [list namespace which $recname]] ne ""} {
+ error "(pattern::record) Can't create command '$recname': A command of that name already exists"
+ }
+
+ set index -1
+ set accessor [list ::apply]
+
+ set template {
+ {rec args}
+ {
+ if {[llength $args] == 0} {
+ return [lindex $rec %idx%]
+ }
+ if {[llength $args] == 1} {
+ return [lreplace $rec %idx% %idx% [lindex $args 0]]
+ }
+ error "Invalid number of arguments."
+ }
+ }
+
+ set map {}
+ foreach field $fields {
+ set body [string map [list %idx% [incr index]] $template]
+ dict set map $field [list ::apply $body]
+ }
+ uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
+}
+
+proc ::argstest {args} {
+ package require cmdline
+
+}
+
+proc ::pattern::objects {} {
+ set result [::list]
+
+ foreach ns [namespace children ::pp] {
+ #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]]
+ set ch [namespace tail $ns]
+ if {[string range $ch 0 2] eq "Obj"} {
+ set OID [string range $ch 3 end] ;#OID need not be digits (!?)
+ lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]]
+ }
+ }
+
+
+
+
+ return $result
+}
+
+
+
+proc ::pattern::name {num} {
+ #!todo - fix
+ #set ::p::${num}::(self)
+
+ lassign [interp alias {} ::p::$num] _predator info
+ if {![string length $_predator$info]} {
+ error "No object found for num:$num (no interp alias for ::p::$num)"
+ }
+ set invocants [dict get $info i]
+ set invocants_with_role_this [dict get $invocants this]
+ set invocant_this [lindex $invocants_with_role_this 0]
+
+
+ #lassign $invocant_this id info
+ #set map [dict get $info map]
+ #set fields [lindex $map 0]
+ lassign $invocant_this _id _ns _defaultmethod name _etc
+ return $name
+}
+
+
+proc ::pattern::with {cmd script} {
+ foreach c [info commands ::p::-1::*] {
+ interp alias {} [namespace tail $c] {} $c $cmd
+ }
+ interp alias {} . {} $cmd .
+ interp alias {} .. {} $cmd ..
+
+ return [uplevel 1 $script]
+}
+
+
+
+
+
+#system diagnostics etc
+
+proc ::pattern::varspace_list {IID} {
+ namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables
+
+ set varspaces [list]
+ dict for {vname vdef} $o_variables {
+ set vs [dict get $vdef varspace]
+ if {$vs ni $varspaces} {
+ lappend varspaces $vs
+ }
+ }
+ if {$o_varspace ni $varspaces} {
+ lappend varspaces $o_varspace
+ }
+ return $varspaces
+}
+
+proc ::pattern::check_interfaces {} {
+ foreach ns [namespace children ::p] {
+ set IID [namespace tail $ns]
+ if {[string is digit $IID]} {
+ foreach ref [array names ${ns}::_iface::o_usedby] {
+ set OID [string range $ref 1 end]
+ if {![namespace exists ::p::${OID}::_iface]} {
+ puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n"
+ } else {
+ puts -nonewline stdout .
+ }
+
+
+ #if {![info exists ::p::${OID}::(self)]} {
+ # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID"
+ #}
+ }
+ }
+ }
+ puts -nonewline stdout "\r\n"
+}
+
+
+#from: http://wiki.tcl.tk/8766 (Introspection on aliases)
+#usedby: metaface-1.1.6+
+#required because aliases can be renamed.
+#A renamed alias will still return it's target with 'interp alias {} oldname'
+# - so given newname - we require which_alias to return the same info.
+ proc ::pattern::which_alias {cmd} {
+ uplevel 1 [list ::trace add execution $cmd enterstep ::error]
+ catch {uplevel 1 $cmd} res
+ uplevel 1 [list ::trace remove execution $cmd enterstep ::error]
+ #puts stdout "which_alias $cmd returning '$res'"
+ return $res
+ }
+# [info args] like proc following an alias recursivly until it reaches
+# the proc it originates from or cannot determine it.
+# accounts for default parameters set by interp alias
+#
+
+
+
+proc ::pattern::aliasargs {cmd} {
+ set orig $cmd
+
+ set defaultargs [list]
+
+ # loop until error or return occurs
+ while {1} {
+ # is it a proc already?
+ if {[string equal [info procs $cmd] $cmd]} {
+ set result [info args $cmd]
+ # strip off the interp set default args
+ return [lrange $result [llength $defaultargs] end]
+ }
+ # is it a built in or extension command we can get no args for?
+ if {![string equal [info commands $cmd] $cmd]} {
+ error "\"$orig\" isn't a procedure"
+ }
+
+ # catch bogus cmd names
+ if {[lsearch [interp aliases {}] $cmd]==-1} {
+ if {[catch {::pattern::which_alias $cmd} alias]} {
+ error "\"$orig\" isn't a procedure or alias or command"
+ }
+ #set cmd [lindex $alias 0]
+ if {[llength $alias]>1} {
+ set cmd [lindex $alias 0]
+ set defaultargs [concat [lrange $alias 1 end] $defaultargs]
+ } else {
+ set cmd $alias
+ }
+ } else {
+
+ if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
+ # check if it is aliased in from another interpreter
+ if {[catch {interp target {} $cmd} msg]} {
+ error "Cannot resolve \"$orig\", alias leads to another interpreter."
+ }
+ if {$msg != {} } {
+ error "Not recursing into slave interpreter \"$msg\".\
+ \"$orig\" could not be resolved."
+ }
+ # check if defaults are set for the alias
+ if {[llength $cmdargs]>1} {
+ set cmd [lindex $cmdargs 0]
+ set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
+ } else {
+ set cmd $cmdargs
+ }
+ }
+ }
+ }
+ }
+proc ::pattern::aliasbody {cmd} {
+ set orig $cmd
+
+ set defaultargs [list]
+
+ # loop until error or return occurs
+ while {1} {
+ # is it a proc already?
+ if {[string equal [info procs $cmd] $cmd]} {
+ set result [info body $cmd]
+ # strip off the interp set default args
+ return $result
+ #return [lrange $result [llength $defaultargs] end]
+ }
+ # is it a built in or extension command we can get no args for?
+ if {![string equal [info commands $cmd] $cmd]} {
+ error "\"$orig\" isn't a procedure"
+ }
+
+ # catch bogus cmd names
+ if {[lsearch [interp aliases {}] $cmd]==-1} {
+ if {[catch {::pattern::which_alias $cmd} alias]} {
+ error "\"$orig\" isn't a procedure or alias or command"
+ }
+ #set cmd [lindex $alias 0]
+ if {[llength $alias]>1} {
+ set cmd [lindex $alias 0]
+ set defaultargs [concat [lrange $alias 1 end] $defaultargs]
+ } else {
+ set cmd $alias
+ }
+ } else {
+
+ if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
+ # check if it is aliased in from another interpreter
+ if {[catch {interp target {} $cmd} msg]} {
+ error "Cannot resolve \"$orig\", alias leads to another interpreter."
+ }
+ if {$msg != {} } {
+ error "Not recursing into slave interpreter \"$msg\".\
+ \"$orig\" could not be resolved."
+ }
+ # check if defaults are set for the alias
+ if {[llength $cmdargs]>1} {
+ set cmd [lindex $cmdargs 0]
+ set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
+ } else {
+ set cmd $cmdargs
+ }
+ }
+ }
+ }
+ }
+
+
+
+
+
+proc ::pattern::uniqueKey2 {} {
+ #!todo - something else??
+ return [clock seconds]-[incr ::pattern::idCounter]
+}
+
+#used by patternlib package
+proc ::pattern::uniqueKey {} {
+ return [incr ::pattern::idCounter]
+ #uuid with tcllibc is about 30us compared with 2us
+ # for large datasets, e.g about 100K inserts this would be pretty noticable!
+ #!todo - uuid pool with background thread to repopulate when idle?
+ #return [uuid::uuid generate]
+}
+
+
+
+#-------------------------------------------------------------------------------------------------------------------------
+
+proc ::pattern::test1 {} {
+ set msg "OK"
+
+ puts stderr "next line should say:'--- saystuff:$msg"
+ ::>pattern .. Create ::>thing
+
+ ::>thing .. PatternMethod saystuff args {
+ puts stderr "--- saystuff: $args"
+ }
+ ::>thing .. Create ::>jjj
+
+ ::>jjj . saystuff $msg
+ ::>jjj .. Destroy
+ ::>thing .. Destroy
+}
+
+proc ::pattern::test2 {} {
+ set msg "OK"
+
+ puts stderr "next line should say:'--- property 'stuff' value:$msg"
+ ::>pattern .. Create ::>thing
+
+ ::>thing .. PatternProperty stuff $msg
+
+ ::>thing .. Create ::>jjj
+
+ puts stderr "--- property 'stuff' value:[::>jjj . stuff]"
+ ::>jjj .. Destroy
+ ::>thing .. Destroy
+}
+
+proc ::pattern::test3 {} {
+ set msg "OK"
+
+ puts stderr "next line should say:'--- property 'stuff' value:$msg"
+ ::>pattern .. Create ::>thing
+
+ ::>thing .. Property stuff $msg
+
+ puts stderr "--- property 'stuff' value:[::>thing . stuff]"
+ ::>thing .. Destroy
+}
+
+#---------------------------------
+#unknown/obsolete
+
+
+
+
+
+
+
+
+#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args}
+if {0} {
+ proc ::p::internals::new_interface {{usedbylist {}}} {
+ set OID [incr ::p::ID]
+ ::p::internals::new_object ::p::ifaces::>$OID "" $OID
+ puts "obsolete >> new_interface created object $OID"
+ foreach usedby $usedbylist {
+ set ::p::${OID}::_iface::o_usedby(i$usedby) 1
+ }
+ set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace)
+ #NOTE - o_varspace is only the default varspace for when new methods/properties are added.
+ # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value.
+
+ set ::p::${OID}::_iface::o_constructor [list]
+ set ::p::${OID}::_iface::o_variables [list]
+ set ::p::${OID}::_iface::o_properties [dict create]
+ set ::p::${OID}::_iface::o_methods [dict create]
+ array set ::p::${OID}::_iface::o_definition [list]
+ set ::p::${OID}::_iface::o_open 1 ;#open for extending
+ return $OID
+ }
+
+
+ #temporary way to get OID - assumes single 'this' invocant
+ #!todo - make generic.
+ proc ::pattern::get_oid {_ID_} {
+ #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]"
+ return [lindex [dict get $_ID_ i this] 0 0]
+
+ #set invocants [dict get $_ID_ i]
+ #set invocant_roles [dict keys $invocants]
+ #set role_members [dict get $invocants this]
+ ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list.
+ #set this_invocant [lindex [dict get $_ID_ i this] 0] ;
+ #lassign $this_invocant OID this_info
+ #
+ #return $OID
+ }
+
+ #compile the uncompiled level1 interface
+ #assert: no more than one uncompiled interface present at level1
+ proc ::p::meta::PatternCompile {self} {
+ ????
+
+ upvar #0 $self SELFMAP
+ set ID [lindex $SELFMAP 0 0]
+
+ set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces
+
+ set iid -1
+ foreach i $patterns {
+ if {[set ::p::${i}::_iface::o_open]} {
+ set iid $i ;#found it
+ break
+ }
+ }
+
+ if {$iid > -1} {
+ #!todo
+
+ ::p::compile_interface $iid
+ set ::p::${iid}::_iface::o_open 0
+ } else {
+ #no uncompiled interface present at level 1. Do nothing.
+ return
+ }
+ }
+
+
+ proc ::p::meta::Def {self} {
+ error ::p::meta::Def
+
+ upvar #0 $self SELFMAP
+ set self_ID [lindex $SELFMAP 0 0]
+ set IFID [lindex $SELFMAP 1 0 end]
+
+ set maxc1 0
+ set maxc2 0
+
+ set arrName ::p::${IFID}::
+
+ upvar #0 $arrName state
+
+ array set methods {}
+
+ foreach nm [array names state] {
+ if {[regexp {^m-1,name,(.+)} $nm _match mname]} {
+ set methods($mname) [set state($nm)]
+
+ if {[string length $mname] > $maxc1} {
+ set maxc1 [string length $mname]
+ }
+ if {[string length [set state($nm)]] > $maxc2} {
+ set maxc2 [string length [set state($nm)]]
+ }
+ }
+ }
+ set bg1 [string repeat " " [expr {$maxc1 + 2}]]
+ set bg2 [string repeat " " [expr {$maxc2 + 2}]]
+
+
+ set r {}
+ foreach nm [lsort -dictionary [array names methods]] {
+ set arglist $state(m-1,args,$nm)
+ append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n"
+ }
+ return $r
+ }
+
+
+
+}
\ No newline at end of file
diff --git a/src/bootsupport/modules_tcl8/patternlib-1.2.6.tm b/src/bootsupport/modules_tcl8/patternlib-1.2.6.tm
new file mode 100644
index 00000000..bd4b3e59
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/patternlib-1.2.6.tm
@@ -0,0 +1,2590 @@
+#JMN 2004
+#public domain
+
+
+package provide patternlib [namespace eval patternlib {
+
+ variable version
+ set version 1.2.6
+}]
+
+
+
+#Change History
+#-------------------------------------------------------------------------------
+#2022-05
+# added . search and . itemKeys methods to >collection to enable lookups by value
+#2021-09
+# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items.
+#
+#2006-05
+# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings.
+#
+#2005-04
+# remove 'name' method - incorporate indexed retrieval into 'names' method
+# !todo? - adjust key/keys methods for consistency?
+#
+#2004-10
+# initial key aliases support
+# fix negative index support on some methods e.g remove
+#2004-08
+# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection
+# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value
+#
+#2004-06-05
+# added 'sort' method to sort on values.
+# fixed 'keySort' method to accept multiple sort options
+# added predicate methods 'all' 'allKeys' 'collectAll'
+#2004-06-01
+# '>collection . names' method now accepts optional 'glob' parameter to filter result
+#2004-05-19
+#fix '>collection . clear' method so consecutive calls don't raise an error
+#-------------------------------------------------------------------------------
+
+namespace eval ::patternlib::util {
+ proc package_require_min {pkg minver} {
+ if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} {
+ package require $pkg
+ } else {
+ error "Package pattern requires package $pkg of at least version $minver. Available: $available"
+ }
+ }
+
+ #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter
+ # k-hashes
+ # m-bits
+ # n-elements
+ # optimal value of k: (m/n)ln(2)
+ #proc bloom_optimalNumHashes {capacity_n bitsize_m} {
+ # expr { round((double($bitsize_m) / $capacity_n) * log(2))}
+ #}
+ #proc bloom_optimalNumBits {capacity fpp} {
+ # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))}
+ #}
+
+}
+::patternlib::util::package_require_min pattern 1.2.4
+#package require pattern
+::pattern::init ;# initialises (if not already)
+
+
+namespace eval ::patternlib {namespace export {[a-z]*}
+ namespace export {[>]*}
+
+ variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified
+ proc uniqueKey {} {
+ return [incr ::patternlib::keyCounter]
+ }
+
+#!todo - multidimensional collection
+# - o_list as nested list
+# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key?
+# - perhaps a key is always a list length n where n is the number of dimensions?
+# - therefore we'll need an extra level of nesting for the current base case n=1
+#
+# - how about a nested dict for each key-structure (o_list & o_array) ?
+
+#COLLECTION
+#
+#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names
+# - consider array-style access using traced var named same as collection.
+# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..?
+#!todo - add boolean property to force unique values as well as keys
+
+
+#::pattern::create >collection
+
+
+
+
+::>pattern .. Create >collection
+set COL >collection
+#process_pattern_aliases [namespace origin >collection]
+#process_pattern_aliases ::patternlib::>collection
+$COL .. Property version 1.0
+$COL .. PatternDefaultMethod item
+
+set PV [$COL .. PatternVariable .]
+
+$PV o_data
+#$PV o_array
+#$PV o_list
+$PV o_alias
+$PV this
+
+#for invert method
+$PV o_dupes 0
+
+
+$COL .. PatternProperty bgEnum
+
+
+#PV o_ns
+
+$PV m_i_filteredCollection
+
+#set ID [lindex [set >collection] 0 0] ;#context ID
+#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID
+
+$COL .. Constructor {args} {
+ var o_data m_i_filteredCollection o_count o_bgEnum
+
+ var this
+ set this @this@
+
+ set m_i_filteredCollection 0
+ if {![llength $args]} {
+ set o_data [dict create]
+ #array set o_array [list]
+ #set o_list [list]
+ set o_count 0
+ } elseif {[llength $args] == 1} {
+ set o_data [dict create]
+ set pairs [lindex $args 0]
+ if {[llength $pairs] % 2} {
+ error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args"
+ }
+ set keys_seen [list]
+ foreach key [dict keys $pairs] {
+ if {[string is integer -strict $key] } {
+ error ">collection key must be non-integer. Bad key: $key. No items added."
+ }
+ if {$key in $keys_seen} {
+ error "key '$key' already exists in this collection. No items added."
+ }
+ lappend keys_seen $key
+ }
+ unset keys_seen
+ #rely on dict ordering guarantees (post 8.5? preserves order?)
+ set o_data [dict merge $o_data[set o_data {}] $pairs]
+ set o_count [dict size $o_data]
+ } else {
+ error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument."
+ }
+ array set o_alias [list]
+
+ array set o_bgEnum [list]
+ @next@
+}
+#comment block snipped from collection Constructor
+ #---------------------------------------------
+ #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway
+ #
+ #### OBSOLETE - left as example of an approach
+ #make count property traceable (e.g so property ref can be bound to Tk widgets)
+ #!todo - manually update o_count in relevant methods faster??
+ # should avoid trace calls for addList methods, shuffle etc
+ #
+ #set handler ::p::${_ID_}::___count_TraceHandler
+ #proc $handler {_ID_ vname vidx op} {
+ # #foreach {vname vidx op} [lrange $args end-2 end] {break}
+ # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name
+ #
+ # #this is only a 'write' handler
+ # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]]
+ # return
+ #}
+ #trace add variable o_list {write} [list $handler $_ID_]
+ ####
+ #
+ #
+ #puts "--->collection constructor id: $_ID_"
+
+
+
+
+set PM [$COL .. PatternMethod .]
+
+
+#!review - why do we need the count method as well as the property?
+#if needed - document why.
+# read traces on count property can be bypassed by method call... shouldn't we avoid that?
+#2018 - in theory write traces on the . count property are very useful from an application-writer's perpective.
+#
+$COL .. PatternMethod count {} {
+ #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added.
+ #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing.
+ var o_data
+ dict size $o_data
+}
+
+$COL .. PatternProperty count
+$COL .. PatternPropertyWrite count {_val} {
+ var
+ error "count property is read-only"
+}
+
+$COL .. PatternPropertyUnset count {} {
+ var
+} ;#cannot raise error's in unset trace handlers - simply fail to unset silently
+
+$COL .. PatternMethod isEmpty {} {
+ #var o_list
+ #return [expr {[llength $o_list] == 0}]
+ var o_data
+ expr {[dict size $o_data] == 0}
+}
+
+$COL .. PatternProperty inverted 0
+
+
+
+######
+# item
+######
+#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful?
+# i.e [>obj . item] returns the 1st element in the list
+#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands)
+#[>obj . item -2] returns 2nd last element (equiv to "end-1")
+
+
+$COL .. PatternMethod item {{idx 0}} {
+ #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000)
+ # (still at least 20 times slower than a plain array... at <5us)
+ var o_data o_alias
+
+ #!todo - review 'string is digit' vs 'string is integer' ??
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+ set keys [dict keys $o_data]
+ if {[catch {dict get $o_data [lindex $keys $idx]} result]} {
+ var this
+ error "no such index : '$idx' in collection: $this"
+ } else {
+ return $result
+ }
+ } else {
+ if {[catch {dict get $o_data $idx} result]} {
+ if {[catch {set o_alias($idx)} nextIdx ]} {
+ var this
+ error "no such index: '$idx' in collection: $this"
+ } else {
+ #try again
+ #return $o_array($nextIdx)
+ #tailcall?
+ #item $_ID_ $nextIdx
+ #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n"
+ tailcall item $_ID_ $nextIdx
+ }
+ } else {
+ return $result
+ }
+ }
+}
+
+
+
+if {0} {
+#leave this here for comparison.
+$COL .. PatternMethod item2 {{idx 0}} {
+ var o_array o_list o_alias this
+
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+
+ if {[catch {set o_array([lindex $o_list $idx])} result]} {
+ error "no such index : '$idx' in collection: $this"
+ } else {
+ return $result
+ }
+ } else {
+ if {[catch {set o_array($idx)} result]} {
+
+ if {[catch {set o_alias($idx)} nextIdx ]} {
+ error "no such index: '$idx' in collection: $this"
+ } else {
+ #try again
+ #return $o_array($nextIdx)
+ item $_ID_ $nextIdx
+ }
+ } else {
+ return $result
+ }
+ }
+
+}
+}
+
+#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!))
+$COL .. PatternMethod itemNamed {idx} {
+ var o_data
+ dict get $o_data $idx
+}
+$COL .. PatternMethod in {idx} {
+ var o_data
+ dict get $o_data $idx
+}
+
+$COL .. PatternMethod itemAt {idx} {
+ var o_data
+ dict get $o_data [lindex [dict keys $o_data] $idx]
+}
+
+$COL .. PatternMethod replace {idx val} {
+ var o_data o_alias this
+
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+
+ if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} {
+ error "no such index: '$idx' in collection: $this"
+ } else {
+ return $val
+ }
+ } else {
+ if {[catch {dict set o_data $idx $val}]} {
+ if {[catch {set o_alias($idx)} nextIdx ]} {
+ error "no such index: '$idx' in collection: $this"
+ } else {
+ #try again
+ tailcall replace $_ID_ $nextIdx $val
+ }
+
+ } else {
+ return $val
+ }
+ }
+}
+
+#if the supplied index is an alias, return the underlying key; else return the index supplied.
+$COL .. PatternMethod realKey {idx} {
+ var o_alias
+
+ if {[catch {set o_alias($idx)} key]} {
+ return $idx
+ } else {
+ return $key
+ }
+}
+
+#note alias feature is possibly ill-considered.
+#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing.
+$COL .. PatternMethod alias {newAlias existingKeyOrAlias} {
+ var o_alias
+
+ #set existingKey [realKey $_ID_ $existingKeyOrAlias]
+ #alias to the supplied KeyOrAlias - not the underlying key
+
+ if {[string is integer -strict $newAlias]} {
+ error "collection key alias cannot be integer"
+ }
+
+ if {[string length $existingKeyOrAlias]} {
+ set o_alias($newAlias) $existingKeyOrAlias
+ } else {
+ unset o_alias($newAlias)
+ }
+}
+$COL .. PatternMethod aliases {{key ""}} {
+ var o_alias
+
+ if {[string length $key]} {
+ set result [list]
+ #lsearch -stride?
+ foreach {n v} [array get o_alias] {
+ if {$v eq $key} {
+ lappend result $n $v
+ }
+ }
+
+ return $result
+ } else {
+ return [array get o_alias]
+ }
+}
+
+#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied
+
+#default to removing item from the end, otherwise from supplied index (position or key)
+#!todo - accept alias indices
+#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?)
+#!todo - review.. for performance.. shouldn't pop NOT accept an index?
+#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index??
+$COL .. PatternMethod pop {{idx ""}} {
+ var o_data o_count
+
+ if {$idx eq ""} {
+ set key [lindex [dict keys $o_data] end]
+ } else {
+ if {[string is integer -strict $idx]} {
+ set key [lindex [dict keys $o_data] $idx]
+ } else {
+ set key $idx
+ }
+ }
+ set posn [lsearch -exact [dict keys $o_data] $key]
+
+ if {($posn >= 0) && ($posn < [dict size $o_data])} {
+ set result [dict get $o_data $key]
+ dict unset o_data $key
+ set o_count [dict size $o_data]
+ return $result
+ } else {
+ error "no such index: '$idx'"
+ }
+}
+$COL .. PatternMethod poppair {} {
+ var o_data o_count
+ set key [lindex [dict keys $o_data] end]
+ set val [dict get $o_data $key]
+ dict unset o_data $key
+ set o_count [dict size $o_data]
+ return [list $key $val]
+}
+
+
+
+#!todo - add 'push' method... (basically specialized versions of 'add')
+#push - add at end (effectively an alias for add)
+#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array.
+#add - add at end
+
+#ordered
+$COL .. PatternMethod items {} {
+ var o_data
+
+ dict values $o_data
+}
+
+
+
+
+####
+#pair
+####
+#fifo-style accesss when no idx supplied (likewise with 'add' method)
+$COL .. PatternMethod pair {{idx 0}} {
+ var o_data
+
+ if {[string is integer -strict $idx]} {
+ set key [lindex [dict keys $o_data] $idx]
+ } else {
+ set key $idx
+ }
+
+ if {[catch {dict get $o_data $key} val]} {
+ error "no such index: '$idx'"
+ } else {
+ return [list $key $val]
+ }
+}
+$COL .. PatternMethod pairs {} {
+ var o_data
+ set o_data
+}
+
+$COL .. PatternMethod get {} {
+ var o_data
+ set o_data
+}
+#todo - fix >pattern so that methods don't collide with builtins
+#may require change to use oo - or copy 'my' mechanism to call own methods
+$COL .. PatternMethod Info {} {
+ var o_data
+ return [dict info $o_data]
+}
+#2006-05-21.. args to add really should be in key, value order?
+# - this the natural order in array-like lists
+# - however.. key should be optional.
+
+$COL .. PatternMethod add {val args} {
+ #(using args instead of {key ""} enables use of empty string as a key )
+
+ var o_data o_alias o_count this
+
+ if {![llength $args]} {
+ set key "_[::patternlib::uniqueKey]_"
+ } else {
+ #!todo - could we handle multiple val,key pairs without impacting performance of the common case?
+ if {[llength $args] > 1} {
+ error "add method expected 'val' and optional 'key' - got: $val $args"
+
+ }
+
+ set key [lindex $args 0]
+ if {[string is integer -strict $key]} {
+ error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys"
+ }
+ }
+
+ if {[dict exists $o_data $key]} {
+ #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]"
+ error "key '$key' already exists in collection $this"
+ }
+ if {[info exists o_alias($key)]} {
+ if {[dict exists $o_data $o_alias($key)]} {
+ #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias
+ error "key '$key' already exists as an alias for $o_alias($key) in collection $this"
+ }
+ }
+
+ dict set o_data $key $val
+
+
+ set posn $o_count
+ incr o_count
+
+ return $posn
+}
+
+
+#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface?
+#what then of methods like 'count' which apply equally well to collections and stacks?
+
+#Alias for 'add' - is there a way to alias this to add implementation with zero overhead??
+$COL .. PatternMethod push {val args} {
+ #(using args instead of {key ""} enables use of empty string as a key )
+
+ var o_data o_alias o_count this
+
+ if {![llength $args]} {
+ set key "_[::patternlib::uniqueKey]_"
+ } else {
+ #!todo - could we handle multiple val,key pairs without impacting performance of the common case?
+ if {[llength $args] > 1} {
+ error "add method expected 'val' and optional 'key' - got: $val $args"
+
+ }
+
+ set key [lindex $args 0]
+ if {[string is integer -strict $key]} {
+ error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys"
+ }
+ }
+
+ if {[dict exists $o_data $key]} {
+ #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]"
+ error "key '$key' already exists in collection $this"
+ }
+ if {[info exists o_alias($key)]} {
+ if {[dict exists $o_data $o_alias($key)]} {
+ #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias
+ error "key '$key' already exists as an alias for $o_alias($key) in collection $this"
+ }
+ }
+
+ dict set o_data $key $val
+
+
+ set posn $o_count
+ incr o_count
+
+ return $posn
+}
+
+
+#shift/unshift - roughly analogous to those found in Perl & PHP
+#unshift adds 1 or more values to the beginning of the collection.
+$COL .. PatternMethod unshift {values {keys ""}} {
+ var o_data o_count
+
+ if {![llength $keys]} {
+ for {set i 0} {$i < [llength $values]} {incr i} {
+ lappend keys "_[::patternlib::uniqueKey]_"
+ }
+ } else {
+ #check keys before we insert any of them.
+ foreach newkey $keys {
+ if {[string is integer -strict $newkey]} {
+ error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys"
+ }
+ }
+ }
+ if {[llength $values] != [llength $keys]} {
+ error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys"
+ }
+
+ #separate loop through keys because we want to fail the whole operation if any are invalid.
+
+ set existing_keys [dict keys $o_data]
+ foreach newkey $keys {
+ if {$newkey in $exisint_keys} {
+ #puts stderr "==============> key $key already exists in this collection"
+ error "key '$newkey' already exists in this collection"
+ }
+ }
+
+
+ #ok - looks like entire set can be inserted.
+ set newpairs [list]
+ foreach val $values key $keys {
+ lappend newpairs $key $val
+ }
+ set o_data [concat $newpairs $o_data[set o_data {}]]
+ set o_count [dict size $o_data]
+
+ return [expr {$o_count - 1}]
+}
+
+#default to removing item from the beginning, otherwise from supplied index (position or key)
+#!todo - accept alias indices
+$COL .. PatternMethod shift {{idx ""}} {
+ var o_data o_count
+
+ if {$idx eq ""} {
+ set key [lindex [dict keys $o_data] 0]
+ } else {
+ if {[string is integer -strict $idx]} {
+ set key [lindex [dict keys $o_data] $idx]
+ } else {
+ set key $idx
+ }
+ }
+ set posn [lsearch -exact [dict keys $o_data] $key]
+
+ if {($posn >= 0) && (($posn/2) < [dict size $o_data])} {
+ set result [dict get $o_data $key]
+ dict unset o_data $key
+ set o_count [dict size $o_data]
+ return $result
+ } else {
+ error "no such index: '$idx'"
+ }
+}
+
+
+$COL .. PatternMethod peek {} {
+ var o_data
+
+ #set o_array([lindex $o_list end])
+
+ #dict get $o_data [lindex [dict keys $o_data] end]
+ lindex $o_data end
+}
+
+$COL .. PatternMethod peekKey {} {
+ var o_data
+ #lindex $o_list end
+ lindex $o_data end-1
+}
+
+
+$COL .. PatternMethod insert {val args} {
+ var o_data o_count
+
+ set idx 0
+ set key ""
+
+ if {[llength $args] <= 2} {
+ #standard arg (ordered) style:
+ #>obj . insert $value $position $key
+
+ lassign $args idx key
+ } else {
+ #allow for literate programming style:
+ #e.g
+ # >obj . insert $value at $listPosition as $key
+
+ if {[catch {array set iargs $args}]} {
+ error "insert did not understand argument list.
+usage:
+>obj . insert \$val \$position \$key
+>obj . insert \$val at \$position as \$key"
+ }
+ if {[info exists iargs(at)]} {
+ set idx $iargs(at)
+ }
+ if {[info exists iargs(as)]} {
+ set key $iargs(as)
+ }
+ }
+
+ if {![string length $key]} {
+ set key "_[::patternlib::uniqueKey]_"
+ }
+
+ if {[string is integer -strict $key]} {
+ error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys"
+ }
+
+
+ if {[dict exists $o_data $key]} {
+ #puts stderr "==============> key $key already exists in this collection"
+ error "key '$key' already exists in this collection"
+ }
+
+ if {$idx eq "end"} {
+ #lappend o_list $key
+ #standard dict set will add it to the end anyway
+ dict set o_data $key $val
+
+ } else {
+ #set o_list [linsert $o_list $idx $key]
+
+ #treat dict as list
+ set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val]
+ }
+
+
+ #set o_array($key) $val
+
+
+ set o_count [dict size $o_data]
+
+ return [expr {$o_count - 1}]
+}
+
+#!todo - deprecate and give it a better name! addDict addPairs ?
+$COL .. PatternMethod addArray {list} {
+ var
+ puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead"
+ tailcall addPairs $_ID_ $list
+}
+$COL .. PatternMethod addPairs {list} {
+ var o_data o_alias o_count
+ if {[llength $list] % 2} {
+ error "must supply an even number of elements"
+ }
+
+ set aliaslist [array names o_alias]
+ #set keylist [dict keys $o_data]
+ foreach newkey [dict keys $list] {
+ if {[string is integer -strict $newkey] } {
+ error ">collection key must be non-integer. Bad key: $newkey. No items added."
+ }
+
+ #if {$newkey in $keylist} {}
+ #for small to medium collections - testing for newkey in $keylist is probably faster,
+ # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient.
+ if {[dict exists $o_data $newkey]} {
+ error "key '$newkey' already exists in this collection. No items added."
+ }
+ #The assumption is that there are in general relatively few aliases - so a list test is appropriate
+ if {$newkey in $aliaslist} {
+ if {[dict exists $o_data $o_alias($newkey)]} {
+ error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added "
+ }
+ }
+ #! check if $list contains dups?
+ #- slows method down - for little benefit?
+ }
+ #!todo - test? (but we need a loop to test for integer keys.. so what's the point?)
+ #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]]
+ #if {[llength $intersection]} {
+ # error "keys '$intersection' already present in this collection. No items added."
+ #}
+
+
+ #rely on dict ordering guarantees (post 8.5? preserves order?)
+ set o_data [dict merge $o_data[set o_data {}] $list]
+
+ set o_count [dict size $o_data]
+
+ return [expr {$o_count - 1}]
+}
+$COL .. PatternMethod addList {list} {
+ var o_data o_count
+
+ foreach val $list {
+ dict set o_data "_[::patternlib::uniqueKey]_" $val
+ #!todo - test. Presumably lappend faster because we don't need to check existing keys..
+ #..but.. is there shimmering involved in treating o_data as a list?
+ #lappend o_data _[::patternlib::uniqueKey]_ $val
+
+ #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data]
+ }
+ set o_count [dict size $o_data]
+
+ return [expr {$o_count - 1}]
+}
+
+#'del' is not a very good name... as we're not really 'deleting' anything.
+# 'remove' seems better, and appears to be more consistent with other languages' collection implementations.
+#!todo - handle 'endRange' parameter for removing ranges of items.
+$COL .. PatternMethod del {idx {endRange ""}} {
+ var
+ #!todo - emit a deprecation warning for 'del'
+ tailcall remove $_ID_ $idx $endRange
+}
+
+$COL .. PatternMethod remove {idx {endRange ""}} {
+ var o_data o_count o_alias this
+
+ if {[string length $endRange]} {
+ error "ranged removal not yet implemented.. remove one item at a time."
+ }
+
+
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+ set key [lindex [dict keys $o_data] $idx]
+ set posn $idx
+ } else {
+ set key $idx
+ set posn [lsearch -exact [dict keys $o_data] $key]
+ if {$posn < 0} {
+ if {[catch {set o_alias($key)} nextKey]} {
+ error "no such index: '$idx' in collection: $this"
+ } else {
+ #try with next key in alias chain...
+ #return [remove $_ID_ $nextKey]
+ tailcall remove $_ID_ $nextKey
+ }
+ }
+ }
+
+ dict unset o_data $key
+
+ set o_count [dict size $o_data]
+ return
+}
+
+#ordered
+$COL .. PatternMethod names {{globOrIdx {}}} {
+ var o_data
+
+ if {[llength $globOrIdx]} {
+ if {[string is integer -strict $globOrIdx]} {
+ #Idx
+ set idx $globOrIdx
+
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+
+
+
+ if {[catch {lindex [dict keys $o_data] $idx} result]} {
+ error "no such index : '$idx'"
+ } else {
+ return $result
+ }
+
+ } else {
+ #glob
+ return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx]
+ }
+ } else {
+ return [dict keys $o_data]
+ }
+}
+
+#ordered
+$COL .. PatternMethod keys {} {
+ #like 'names' but without globbing
+ var o_data
+ dict keys $o_data
+}
+
+#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects
+# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases?
+# - some sort of resolution order/interface-selection is clearly required anyway
+# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism.
+# In the mean time however... we'll at least avoid 'name'!
+#
+#$PM name {{posn 0}} {
+# var o_array o_list
+#
+# if {$posn < 0} {
+# set posn "end-[expr {abs($posn + 1)}]"
+# }
+#
+# if {[catch {lindex $o_list $posn} result]} {
+# error "no such index : '$posn'"
+# } else {
+# return $result
+# }
+#}
+
+$COL .. PatternMethod key {{posn 0}} {
+ var o_data
+
+ if {$posn < 0} {
+ set posn "end-[expr {abs($posn + 1)}]"
+ }
+
+ if {[catch {lindex [dict keys $o_data] $posn} result]} {
+ error "no such index : '$posn'"
+ } else {
+ return $result
+ }
+}
+
+
+#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands.
+$COL .. PatternMethod setPosn {idx to} {
+ var o_data
+
+ if {![string is integer -strict $to]} {
+ error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored"
+ }
+
+ if {[string is integer -strict $idx]} {
+ set idx [expr {$idx % [dict size $o_data]}]
+
+ set key [lindex [dict keys $o_data] $idx]
+ set posn $idx
+ } else {
+ set key $idx
+ set posn [lsearch -exact [dict keys $o_data] $key]
+ }
+
+ set to [expr {$to % [dict size $o_data]}]
+
+
+ set val [dict get $o_data $key]
+ dict unset o_data $key
+
+ #treat dict as list
+ set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val]
+
+ #set o_list [lreplace $o_list $posn $posn]
+ #set o_list [linsert $o_list $to $key]
+
+ return $to
+}
+#!todo - improve efficiency of calls to other functions on this object.. 'inline'??
+#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability.
+$COL .. PatternMethod incrPosn {idx {by 1}} {
+ var o_data
+ if {[string is integer -strict $idx]} {
+ set idx [expr {$idx % [dict size $o_data]}]
+ set key [lindex [dict keys $o_data] $idx]
+ set posn $idx
+ } else {
+ set key $idx
+ set posn [lsearch -exact [dict keys $o_data] $key]
+ }
+
+ set newPosn [expr {($posn + $by) % [dict size $o_data]}]
+
+ setPosn $_ID_ $posn $newPosn
+ return $newPosn
+}
+$COL .. PatternMethod decrPosn {idx {by 1}} {
+ var
+ return [incrPosn $_ID_ $idx [expr {- $by}]]
+}
+$COL .. PatternMethod move {idx to} {
+ var
+ return [setPosn $_ID_ $idx $to]
+}
+$COL .. PatternMethod posn {key} {
+ var o_data
+ return [lsearch -exact [dict keys $o_data] $key]
+}
+
+#!todo? - disallow numeric values for newKey so as to be consistent with add
+#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything
+# - this is ok.
+$COL .. PatternMethod reKey {idx newKey} {
+ var o_data o_alias
+
+
+ if {[dict exists $o_data $newKey]} {
+ #puts stderr "==============> reKey collision, key $newKey already exists in this collection"
+ error "reKey collision, key '$newKey' already exists in this collection"
+ }
+ if {[info exists o_alias($newKey)]} {
+ if {[dict exists $o_data $o_alias($newKey)]} {
+ error "reKey collision, key '$newKey' already present as an alias in this collection"
+ } else {
+ set newKey $o_alias($newKey)
+ }
+ }
+
+
+
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+ set key [lindex [dict keys $o_data] $idx]
+ set posn $idx
+ } else {
+ set key $idx
+ set posn [lsearch -exact [dict keys $o_data] $key]
+ if {$posn < 0} {
+ if {[catch {set o_alias($key)} nextKey]} {
+ error "no such index: '$idx'"
+ } else {
+ #try with next key in alias chain...
+ #return [reKey $_ID_ $nextKey $newKey]
+ tailcall reKey $_ID_ $nextKey $newKey
+ }
+ }
+ }
+
+ #set o_list [lreplace $o_list $posn $posn $newKey]
+ ##atomic? (traces on array?)
+ #set o_array($newKey) $o_array($key)
+ #unset o_array($key)
+
+ dict set o_data $newKey [dict get $o_data $key]
+ dict unset o_data $key
+
+ return
+}
+$COL .. PatternMethod hasKey {key} {
+ var o_data
+ dict exists $o_data $key
+}
+$COL .. PatternMethod hasAlias {key} {
+ var o_alias
+ info exists o_alias($key)
+}
+
+#either key or alias
+$COL .. PatternMethod hasIndex {key} {
+ var o_data o_alias
+ if {[dict exists $o_data $key]} {
+ return 1
+ } else {
+ return [info exists o_alias($key)]
+ }
+}
+
+
+#Shuffle methods from http://mini.net/tcl/941
+$COL .. PatternMethod shuffleFast {} {
+ #shuffle6 - fast, but some orders more likely than others.
+
+ var o_data
+
+ set keys [dict keys $o_data]
+
+ set n [llength $keys]
+ for { set i 1 } { $i < $n } { incr i } {
+ set j [expr { int( rand() * $n ) }]
+ set temp [lindex $keys $i]
+ lset keys $i [lindex $keys $j]
+ lset keys $j $temp
+ }
+
+ #rebuild dict in new order
+ #!todo - can we do the above 'in place'?
+ set newdata [dict create]
+ foreach k $keys {
+ dict set newdata $k [dict get $o_data $k]
+ }
+ set o_data $newdata
+
+ return
+}
+$COL .. PatternMethod shuffle {} {
+ #shuffle5a
+
+ var o_data
+
+ set n 1
+ set keys [list] ;#sorted list of keys
+ foreach k [dict keys $o_data] {
+ #set index [expr {int(rand()*$n)}]
+
+ #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k]
+
+ #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b]
+ set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k]
+ incr n
+ }
+
+ #rebuild dict in new order
+ #!todo - can we do the above 'in place'?
+ set newdata [dict create]
+ foreach k $keys {
+ dict set newdata $k [dict get $o_data $k]
+ }
+ set o_data $newdata
+
+ return
+}
+
+
+#search is a somewhat specialised form of 'itemKeys'
+$COL .. PatternMethod search {value args} {
+ var o_data
+ #only search on values as it's possible for keys to match - especially with options such as -glob
+ set matches [lsearch {*}$args [dict values $o_data] $value]
+
+ if {"-inline" in $args} {
+ return $matches
+ } else {
+ set keylist [list]
+ foreach i $matches {
+ set idx [expr {(($i + 1) * 2) -2}]
+ lappend keylist [lindex $o_data $idx]
+ }
+ return $keylist
+ }
+}
+
+#inverse lookup
+$COL .. PatternMethod itemKeys {value} {
+ var o_data
+ #only search on values as it's possible for keys to match
+ set value_indices [lsearch -all [dict values $o_data] $value]
+
+ set keylist [list]
+ foreach i $value_indices {
+ set idx [expr {(($i + 1) * 2) -2}]
+ lappend keylist [lindex $o_data $idx]
+ }
+ return $keylist
+}
+
+#invert:
+#change collection to be indexed by its values with the old keys as new values.
+# - keys of duplicate values become a list keyed on the value.
+#e.g the array equivalent is:
+# arr(a) 1
+# arr(b) 2
+# arr(c) 2
+#becomes
+# inv(1) a
+# inv(2) {b c}
+#where the order of duplicate-value keys is not defined.
+#
+#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates.
+#
+
+
+#!todo - try just [lreverse $o_data] ??
+
+
+$COL .. PatternMethod invert {{splitvalues ""}} {
+
+ var o_data o_count o_dupes o_inverted
+
+
+ if {$splitvalues eq ""} {
+ #not overridden - use o_dupes from last call to determine if values are actually keylists.
+ if {$o_dupes > 0} {
+ set splitvalues 1
+ } else {
+ set splitvalues 0
+ }
+ }
+
+
+ #set data [array get o_array]
+ set data $o_data
+
+ if {$o_count > 500} {
+ #an arbitrary optimisation for 'larger' collections.
+ #- should theoretically keep the data size and save some reallocations.
+ #!todo - test & review
+ #
+ foreach nm [dict keys $o_data] {
+ dict unset o_data $nm
+ }
+ } else {
+ set o_data [dict create]
+ }
+
+ if {!$splitvalues} {
+ dict for {k v} $data {
+ dict set o_data $v $k
+ }
+ } else {
+ dict for {k v} $data {
+ #we're splitting values because each value is a list of keys
+ #therefore sub should be unique - no need for lappend in this branch.
+ foreach sub $v {
+ #if {[info exists o_array($sub)]} {
+ # puts stderr "---here! v:$v sub:$sub k:$k"
+ # lappend o_array($sub) $k
+ #} else {
+ dict set o_data $sub $k
+ #}
+ }
+ }
+ }
+
+
+ if {[dict size $o_data] != $o_count} {
+ #must have been some dupes
+
+ set o_dupes [expr {$o_count - [dict size $o_data]}]
+ #update count to match inverted collection
+ set o_count [dict size $o_data]
+ } else {
+ set o_dupes 0
+ }
+
+ set o_inverted [expr {!$o_inverted}]
+
+ #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes'
+ return $o_dupes
+}
+
+
+
+
+
+
+#NOTE: values are treated as lists and split into separate keys for inversion only if requested!
+# To treat values as keylists - set splitvalues 1
+# To treat each value atomically - set splitvalues 0
+# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert!
+#
+#
+#Initially call invert with splitvalues = 0
+#To keep calling invert and get back where you started..
+# The rule is... if the previous call to invert returned > 0... pass 1 on the next call.
+#
+$COL .. PatternMethod invert_manual {{splitvalues 0}} {
+ #NOTE - the list nesting here is *tricky* - It probably isn't broken.
+
+ var o_list o_array o_count
+
+ set data [array get o_array]
+
+ if {$o_count > 500} {
+ #an arbitrary optimisation for 'large' collections.
+ #- should theoretically keep the array size and save some reallocations.
+ #!todo - test & review
+ #
+ foreach nm [array names o_array] {
+ unset o_array($nm)
+ }
+ } else {
+ array unset o_array
+ }
+
+ if {!$splitvalues} {
+ foreach {k v} $data {
+ lappend o_array($v) $k
+ }
+ } else {
+ foreach {k v} $data {
+ #we're splitting values because each value is a list of keys
+ #therefore sub should be unique - no need for lappend in this branch.
+ foreach sub $v {
+ #if {[info exists o_array($sub)]} {
+ # puts stderr "---here! v:$v sub:$sub k:$k"
+ # lappend o_array($sub) $k
+ #} else {
+ set o_array($sub) $k
+ #}
+ }
+ }
+ }
+
+
+ if {[array size o_array] != $o_count} {
+ #must have been some dupes
+ set o_list [array names o_array]
+
+
+ set dupes [expr {$o_count - [array size o_array]}]
+ #update count to match inverted collection
+ set o_count [array size o_array]
+ } else {
+ #review - are these machinations worthwhile for order preservation? what speed penalty do we pay?
+ array set prev $data
+ set i -1
+ if {$splitvalues} {
+ #values are lists of length one. Take lindex 0 so list values aren't overnested.
+ foreach oldkey $o_list {
+ lset o_list [incr i] [lindex $prev($oldkey) 0]
+ }
+ } else {
+ foreach oldkey $o_list {
+ lset o_list [incr i] $prev($oldkey)
+ }
+ }
+
+ set dupes 0
+ }
+
+
+ #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes'
+ return $dupes
+}
+
+
+
+#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys
+# (keys that are lists)
+$COL .. PatternMethod invert_lossy {{splitvalues 1}} {
+ var o_list o_array o_count
+
+ set data [array get o_array]
+
+ if {$o_count > 500} {
+ #an arbitrary optimisation for 'large' collections.
+ #- should theoretically keep the array size and save some reallocations.
+ #!todo - test & review
+ #
+ foreach nm [array names o_array] {
+ unset o_array($nm)
+ }
+ } else {
+ array unset o_array
+ }
+
+ if {!$splitvalues} {
+ foreach {k v} $data {
+ #note! we must check for existence and use 'set' for first case.
+ #using 'lappend' only will result in deeper nestings on each invert!
+ #If you don't understand this - don't change it!
+ if {[info exists o_array($v)]} {
+ lappend o_array($v) $k
+ } else {
+ set o_array($v) $k
+ }
+ }
+ } else {
+ foreach {k v} $data {
+ #length test necessary to avoid incorrect 'un-nesting'
+ #if {[llength $v] > 1} {
+ foreach sub $v {
+ if {[info exists o_array($sub)]} {
+ lappend o_array($sub) $k
+ } else {
+ set o_array($sub) $k
+ }
+ }
+ #} else {
+ # if {[info exists o_array($v)]} {
+ # lappend o_array($v) $k
+ # } else {
+ # set o_array($v) $k
+ # }
+ #}
+ }
+ }
+
+
+ if {[array size o_array] != $o_count} {
+ #must have been some dupes
+ set o_list [array names o_array]
+
+
+ set dupes [expr {$o_count - [array size o_array]}]
+ #update count to match inverted collection
+ set o_count [array size o_array]
+ } else {
+ #review - are these machinations worthwhile for order preservation? what speed penalty do we pay?
+ array set prev $data
+ set i -1
+ foreach oldkey $o_list {
+ lset o_list [incr i] $prev($oldkey)
+ }
+ set dupes 0
+ }
+
+
+ #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes'
+ return $dupes
+}
+
+$COL .. PatternMethod reverse {} {
+ var o_data
+
+ set dictnew [dict create]
+ foreach k [lreverse [dict keys $o_data]] {
+ dict set dictnew $k [dict get $o_data $k]
+ }
+ set o_data $dictnew
+ return
+}
+
+$COL .. PatternMethod keySort {{options -ascii}} {
+ var o_data
+
+ set keys [lsort {*}$options [dict keys $o_data]]
+
+ set dictnew [dict create]
+ foreach k $keys {
+ dict set dictnew $k [dict get $o_data $k]
+ }
+ set o_data $dictnew
+
+ return
+}
+
+#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting.
+$COL .. PatternMethod sort {args} {
+ var o_data
+
+ #defaults
+ set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting.
+
+ set options_simple [list]
+
+
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set a [lindex $args $i]
+ switch -- $a {
+ -indices -
+ -ascii -
+ -dictionary -
+ -integer -
+ -real -
+ -increasing -
+ -decreasing {
+ #dict set options $a 1
+ lappend options_simple $a
+ }
+ -unique {
+ #not a valid option
+ #this would stuff up the data...
+ #!todo? - remove dups from collection if this option used? - alias the keys?
+ }
+ -object {
+ #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing
+ #may be slow - but handy. Consider -indexed property to store/cache these values on first run
+ }
+ -command {
+ dict set options $a [lindex $args [incr i]]
+ }
+ -index {
+ #allow sorting on subindices of the value.
+ dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ]
+ }
+ default {
+ #unrecognised option - print usage?
+ }
+ }
+ }
+
+
+
+ if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} {
+
+ var o_array
+
+ set slist [list]
+ foreach k [dict keys $o_data] {
+ lappend slist [list $k [dict get $o_data $k]]
+ }
+ return [lsort {*}$options_simple {*}$options $slist]
+
+
+
+ #set options_simple [lreplace $options_simple $posn $posn] ;#
+ #set slist [list]
+ #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] {
+ # lappend slist [list $n $v]
+ #}
+ #set slist [lsort {*}$options_simple {*}$options $slist]
+ #foreach i $slist {
+ # #determine the position in the collections list
+ # lappend result {*}[lsearch -exact $o_list [lindex $i 0]]
+ #}
+ #return $result
+ } else {
+ set slist [list]
+ dict for {k v} $o_data {
+ lappend slist [list $k $v]
+ }
+ #set slist [lsort {*}$options_simple {*}$options $slist]
+ set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency
+
+
+ #set o_list [lsearch -all -inline -subindices -index 0 $slist *]
+
+ set o_data [dict create]
+ foreach pair $slist {
+ dict set o_data [lindex $pair 0] [lindex $pair 1]
+ }
+
+
+
+ return
+ }
+
+}
+
+
+$COL .. PatternMethod clear {} {
+ var o_data o_count
+
+ set o_data [dict create]
+ set o_count 0
+ #aliases?
+ return
+}
+
+#see http://wiki.tcl.tk/15271 - A generic collection traversal interface
+#
+#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?))
+#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration?
+# - should this be an option? which mechanism should be the default?
+# - currently only the keylist is treated in 'snapshot' fashion
+# so values could be changed and the state could be invalidated by other code during an enumeration
+#
+$COL .. PatternMethod enumerate {args} {
+ #----------
+ lassign [lrange $args end-1 end] cmd seed
+ set optionlist [list]
+ foreach a [lrange $args 0 end-2] {
+ lappend optionlist $a
+ }
+ set opt(-direction) left
+ set opt(-completioncommand) ""
+ array set opt $optionlist
+ #----------
+ var o_data
+
+ if {[string tolower [string index $opt(-direction) 0]] eq "r"} {
+ #'right' 'RIGHT' 'r' etc.
+ set list [lreverse [dict keys $o_data]]
+ } else {
+ #normal left-right order
+ set list [dict keys $o_data]
+ }
+
+ if {![string length $opt(-completioncommand)]} {
+ #standard synchronous processing
+ foreach k $list {
+ set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]]
+ }
+ return $seed
+ } else {
+ #ASYNCHRONOUS enumeration
+ var this o_bgEnum
+ #!todo - make id unique
+ #!todo - facility to abort running enumeration.
+ set enumID enum[array size o_bgEnum]
+
+ set seedvar [$this . bgEnum $enumID .]
+ set $seedvar $seed
+
+ after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)]
+ return $enumID
+ }
+}
+
+#!todo - make private? - put on a separate interface?
+$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} {
+ var this o_data
+
+
+ #Note that we don't post to the eventqueue using 'foreach s $slice'
+ # we only schedule another event after each item is processed
+ # - otherwise we would be spamming the eventqueue with items.
+
+ #!todo? - accept a -granularity option to allow handling of n list-items per event?
+
+ if {[llength $slice]} {
+ set slice [lassign $slice head]
+
+ set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] {
+ %cmd% [set %seedvar%] %val%
+ }]
+
+ #post to eventqueue and re-enter _doBackgroundEnum
+ #
+ after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]]
+
+ } else {
+ #done.
+
+ set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] {
+ lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0
+ }]
+
+ after idle [list after 0 [list uplevel #0 $script]]
+ }
+
+ return
+}
+
+$COL .. PatternMethod enumeratorstate {} {
+ var o_bgEnum
+ parray o_bgEnum
+}
+
+#proc ::bgerror {args} {
+# puts stderr "=bgerror===>$args"
+#}
+
+
+#map could be done in terms of the generic 'enumerate' method.. but it's slower.
+#
+#$PM map2 {proc} {
+# var
+# enumerate $_ID_ [list ::map-helper $proc] [list]
+#}
+#proc ::map-helper {proc accum item} {
+# lappend accum [uplevel #0 [list {*}$proc $item]]
+#}
+
+$COL .. PatternMethod map {cmd} {
+ var o_data
+ set seed [list]
+ dict for {k v} $o_data {
+ lappend seed [uplevel #0 [list {*}$cmd $v]]
+ }
+
+ return $seed
+}
+$COL .. PatternMethod objectmap {cmd} {
+ var o_data
+ set seed [list]
+ dict for {k v} $o_data {
+ lappend seed [uplevel #0 [list $v {*}$cmd]]
+ }
+
+ return $seed
+}
+
+
+#End core collection functionality.
+#collection 'mixin' interfaces
+
+>pattern .. Create >keyvalprotector
+>keyvalprotector .. PatternVariable o_protectedkeys
+>keyvalprotector .. PatternVariable o_protectedvals
+
+#!todo - write test regarding errors in Constructors for mixins like this
+# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args
+>keyvalprotector .. Constructor {args} {
+ var this o_protectedkeys o_protectedvals
+ set this @this@
+ #----------------------------------------------------------------------------
+ set known_opts [list -keys -vals ]
+ dict set default -keys [list]
+ dict set default -vals [list]
+ if {([llength $args] % 2) != 0} {
+ error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' "
+ }
+ foreach {k v} $args {
+ if {$k ni $known_opts} {
+ error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'"
+ }
+ }
+ set opts [dict merge $default $args]
+ set o_protectedkeys [dict get $opts -keys]
+ set o_protectedvals [dict get $opts -vals]
+ #----------------------------------------------------------------------------
+ set protections [concat $o_protectedkeys $o_protectedvals]
+ if {![llength $protections]} {
+ error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys"
+ }
+
+}
+>keyvalprotector .. PatternMethod clear {} {
+ error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear"
+}
+>keyvalprotector .. PatternMethod pop {{idx ""}} {
+ var o_data o_count o_protectedkeys o_protectedvals
+
+ if {$idx eq ""} {
+ set key [lindex [dict keys $o_data] end]
+ } else {
+ if {[string is integer -strict $idx]} {
+ set key [lindex [dict keys $o_data] $idx]
+ } else {
+ set key $idx
+ }
+ }
+
+ if {$key in $o_protectedkeys} {
+ error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection."
+ }
+ set posn [lsearch -exact [dict keys $o_data] $key]
+ if {($posn >= 0) && ($posn < [dict size $o_data])} {
+ set result [dict get $o_data $key]
+ if {$result in $o_protectedvals} {
+ error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection."
+ }
+ dict unset o_data $key
+ set o_count [dict size $o_data]
+ return $result
+ } else {
+ error "no such index: '$idx'"
+ }
+
+}
+>keyvalprotector .. PatternMethod remove {idx {endRange ""}} {
+ var this o_data o_count o_alias o_protectedkeys o_protectedvals
+
+ if {[string length $endRange]} {
+ error "ranged removal not yet implemented.. remove one item at a time."
+ }
+
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+ set key [lindex [dict keys $o_data] $idx]
+ if {$key in $o_protectedkeys} {
+ error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection"
+ }
+ set posn $idx
+ } else {
+ set key $idx
+ set posn [lsearch -exact [dict keys $o_data] $key]
+ if {$posn < 0} {
+ if {[catch {set o_alias($key)} nextKey]} {
+ error "no such index: '$idx' in collection: $this"
+ } else {
+ if {$key in $o_protectedkeys} {
+ error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection"
+ }
+ #try with next key in alias chain...
+ #return [remove $_ID_ $nextKey]
+ tailcall remove $_ID_ $nextKey
+ }
+ }
+ }
+
+ dict unset o_data $key
+
+ set o_count [dict size $o_data]
+ return
+}
+
+#1)
+#predicate methods (order preserving)
+#usage:
+# >collection .. Create >c1
+# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection
+
+#e.g >col1 . all {$val > 14}
+#e.g >col1 . filterToCollection {$val > 19} . count
+#e.g >col1 . filter {[string match "x*" $key]}
+#!todo - fix. currying fails..
+
+::>pattern .. Create >predicatedCollection
+#process_pattern_aliases ::patternlib::>predicatedCollection
+
+set PM [>predicatedCollection .. PatternMethod .]
+
+>predicatedCollection .. PatternMethod filter {predicate} {
+ var this o_list o_array
+ set result [list]
+
+ #!note (jmn 2004) how could we do smart filtering based on $posn?
+ #i.e it would make sense to lrange $o_list based on $posn...
+ #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ??
+ #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon.
+ #given this, is $posn even useful?
+
+ set posn 0
+ foreach key $o_list {
+ set val $o_array($key)
+ if $predicate {
+ lappend result $val
+ }
+ incr posn
+ }
+ set result
+}
+>predicatedCollection .. PatternMethod filterToKeys {predicate} {
+ var this o_list o_array
+ set result [list]
+
+ set posn 0
+ foreach key $o_list {
+ set val $o_array($key)
+ if $predicate {
+ lappend result $key
+ }
+ incr posn
+ }
+ set result
+}
+>predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} {
+ #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent?
+ #!todo - implement as 'view' on current collection object.. extra o_list variables?
+ #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required?
+ var this o_list o_array m_i_filteredCollection
+
+ incr m_i_filteredCollection
+ if {![string length $destCollection]} {
+ #!todo? - implement 'one-shot' object (similar to RaTcl)
+ set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection]
+ } else {
+ set result $destCollection
+ }
+
+ ####
+ #externally manipulate new collection
+ #set ADD [$c . add .]
+ #foreach key $o_list {
+ # set val $o_array($key)
+ # if $predicate {
+ # $ADD $val $key
+ # }
+ #}
+ ###
+
+ #internal manipulation faster
+ #set cID [lindex [set $result] 0]
+ set cID [lindex [$result --] 0]
+
+ #use list to get keys so as to preserve order
+ set posn 0
+ upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST
+ foreach key $o_list {
+ set val $o_array($key)
+ if $predicate {
+ if {[info exists cARRAY($key)]} {
+ error "key '$key' already exists in this collection"
+ }
+ lappend cLIST $key
+ set cARRAY($key) $val
+ }
+ incr posn
+ }
+
+ return $result
+}
+
+#NOTE! unbraced expr/if statements. We want to evaluate the predicate.
+>predicatedCollection .. PatternMethod any {predicate} {
+ var this o_list o_array
+ set posn 0
+ foreach key $o_list {
+ set val $o_array($key)
+ if $predicate {
+ return 1
+ }
+ incr posn
+ }
+ return 0
+}
+>predicatedCollection .. PatternMethod all {predicate} {
+ var this o_list o_array
+ set posn 0
+ foreach key $o_list {
+ set val $o_array($key)
+ if !($predicate) {
+ return 0
+ }
+ incr posn
+ }
+ return 1
+}
+>predicatedCollection .. PatternMethod dropWhile {predicate} {
+ var this o_list o_array
+ set result [list]
+ set _idx 0
+ set posn 0
+ foreach key $o_list {
+ set val $o_array($key)
+ if $predicate {
+ incr _idx
+ } else {
+ break
+ }
+ incr posn
+ }
+ set remaining [lrange $o_list $_idx end]
+ foreach key $remaining {
+ set val $o_array($key)
+ lappend result $val
+ }
+ return $result
+}
+>predicatedCollection .. PatternMethod takeWhile {predicate} {
+ var this o_list o_array
+ set result [list]
+ set posn 0
+ foreach key $o_list {
+ set val $o_array($key)
+ if $predicate {
+ lappend result $val
+ } else {
+ break
+ }
+ incr posn
+ }
+ set result
+}
+
+
+
+#end >collection mixins
+######################################
+
+
+
+
+#-----------------------------------------------------------
+#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently?
+# Why do we need both? apart from the size variable, what is the use of hashMap?
+#-----------------------------------------------------------
+#::pattern::create >hashMap
+::>pattern .. Create >hashMap
+
+>hashMap .. PatternVariable o_size
+>hashMap .. PatternVariable o_array
+
+>hashMap .. Constructor {args} {
+ var o_array o_size
+ array set o_array [list]
+ set o_size 0
+}
+>hashMap .. PatternDefaultMethod "item"
+>hashMap .. PatternMethod item {key} {
+ var o_array
+ set o_array($key)
+}
+>hashMap .. PatternMethod items {} {
+ var o_array
+
+ set result [list]
+ foreach nm [array names o_array] {
+ lappend result $o_array($nm)
+ }
+ return $result
+}
+>hashMap .. PatternMethod pairs {} {
+ var o_array
+
+ array get o_array
+}
+>hashMap .. PatternMethod add {val key} {
+ var o_array o_size
+
+ set o_array($key) $val
+ incr o_size
+ return $key
+}
+
+>hashMap .. PatternMethod del {key} {
+ var
+ puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead."
+ remove $_ID_ $key
+}
+>hashMap .. PatternMethod remove {key} {
+ var o_array o_size
+ unset o_array($key)
+ incr o_size -1
+ return $key
+}
+>hashMap .. PatternMethod count {} {
+ var o_size
+ #array size o_array
+ return $o_size
+}
+>hashMap .. PatternMethod count2 {} {
+ var o_array
+ #array size o_array ;#slow, at least for TCLv8.4.4
+ #even array statistics is faster than array size !
+ #e.g return [lindex [array statistics o_array] 0]
+ #but.. apparently there are circumstances where array statistics doesn't report the correct size.
+ return [array size o_array]
+}
+>hashMap .. PatternMethod names {} {
+ var o_array
+ array names o_array
+}
+>hashMap .. PatternMethod keys {} {
+ #synonym for names
+ var o_array
+ array names o_array
+}
+>hashMap .. PatternMethod hasKey {key} {
+ var o_array
+ return [info exists o_array($key)]
+}
+>hashMap .. PatternMethod clear {} {
+ var o_array o_size
+ unset o_array
+ set o_size 0
+ return
+}
+#>hashMap .. Ready 1
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#explicitly create metadata. Not required for user-defined patterns.
+# this is only done here because this object is used for the metadata of all objects
+# so the object must have all it's methods/props before its own metadata structure can be built.
+#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection"
+#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection"
+
+
+
+
+if 0 {
+
+
+#-----------------------------------------------------------
+#::pattern::create >arrayHandle {
+# variable o_arrayName
+# variable this
+#}
+::>pattern .. Create >arrayHandle
+
+>arrayHandle .. PatternVariable o_arrayName
+>arrayHandle .. PatternVariable this
+
+>arrayHandle .. Constructor {args} {
+ var o_arrayName this
+ set this @this@
+
+
+ set o_arrayName [$this .. Namespace]::array
+
+ upvar #0 $o_arrayName $this
+ #? how to automatically update this after a namespace import?
+
+ array set $o_arrayName [list]
+
+}
+>arrayHandle .. PatternMethod array {} {
+ var o_arrayName
+ return $o_arrayName
+}
+
+#-------------------------------------------------------
+#---- some experiments
+>arrayHandle .. PatternMethod up {varname} {
+ var o_arrayName
+
+ #is it dodgy to hard-code the calling depth?
+ #will it be different for different object systems?
+ #Will it even be consistent for the same object.
+ # Is this method necessary anyway? -
+ # - users can always instead do:
+ # upvar #0 [>instance . array] var
+
+ uplevel 3 [list upvar 0 $o_arrayName $varname]
+
+ return
+}
+>arrayHandle .. PatternMethod global {varname} {
+ var o_arrayName
+ # upvar #0 [>instance . array] var
+
+ if {![string match ::* $varname]} {
+ set varname ::$varname
+ }
+
+ upvar #0 $o_arrayName $varname
+
+ return
+}
+>arrayHandle .. PatternMethod depth {} {
+ var o_arrayName
+ #
+ for {set i 0} {$i < [info level]} {
+ puts "${i}: [uplevel $i [list namespace current] , [info level $i]]"
+ }
+
+}
+ # --------------------------------------------
+
+
+>arrayHandle .. PatternMethod item {key} {
+ var o_arrayName
+ set ${o_arrayName}($key)
+}
+>arrayHandle .. PatternMethod items {} {
+ var o_arrayName
+
+ set result [list]
+ foreach nm [array names $o_arrayName] {
+ lappend result [set ${o_arrayName}($nm)]
+ }
+ return $result
+}
+>arrayHandle .. PatternMethod pairs {} {
+ var o_arrayName
+
+ array get $o_arrayName
+}
+>arrayHandle .. PatternMethod add {val key} {
+ var o_arrayName
+
+ set ${o_arrayName}($key) $val
+ return $key
+}
+>arrayHandle .. PatternMethod del {key} {
+ puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead."
+ remove $_ID_ $key
+}
+>arrayHandle .. PatternMethod remove {key} {
+ var o_arrayName
+ unset ${o_arrayName}($key)
+ return $key
+}
+>arrayHandle .. PatternMethod size {} {
+ var o_arrayName
+ return [array size $o_arrayName]
+}
+>arrayHandle .. PatternMethod count {} {
+ #alias for size
+ var o_arrayName
+ return [array size $o_arrayName]
+}
+>arrayHandle .. PatternMethod statistics {} {
+ var o_arrayName
+ return [array statistics $o_arrayName]
+}
+>arrayHandle .. PatternMethod names {} {
+ var o_arrayName
+ array names $o_arrayName
+}
+>arrayHandle .. PatternMethod keys {} {
+ #synonym for names
+ var o_arrayName
+ array names $o_arrayName
+}
+>arrayHandle .. PatternMethod hasKey {key} {
+ var o_arrayName
+
+ return [info exists ${o_arrayName}($key)]
+}
+>arrayHandle .. PatternMethod clear {} {
+ var o_arrayName
+ unset $o_arrayName
+ array set $o_arrayName [list]
+
+ return
+}
+#>arrayHandle .. Ready 1
+
+
+
+
+::>pattern .. Create >matrix
+
+>matrix .. PatternVariable o_array
+>matrix .. PatternVariable o_size
+
+>matrix .. Constructor {args} {
+ var o_array o_size
+
+ array set o_array [list]
+ set o_size 0
+}
+
+
+#process_pattern_aliases ::patternlib::>matrix
+
+set PM [>matrix .. PatternMethod .]
+
+>matrix .. PatternMethod item {args} {
+ var o_array
+
+ if {![llength $args]} {
+ error "indices required"
+ } else {
+
+ }
+ if [info exists o_array($args)] {
+ return $o_array($args)
+ } else {
+ error "no such index: '$args'"
+ }
+}
+>matrix .. PatternMethod items {} {
+ var o_array
+
+ set result [list]
+ foreach nm [array names o_array] {
+ lappend result $o_array($nm)
+ }
+ return $result
+}
+>matrix .. PatternMethod pairs {} {
+ var o_array
+
+ array get o_array
+}
+>matrix .. PatternMethod slice {args} {
+ var o_array
+
+ if {"*" ni $args} {
+ lappend args *
+ }
+
+ array get o_array $args
+}
+>matrix .. PatternMethod add {val args} {
+ var o_array o_size
+
+ if {![llength $args]} {
+ error "indices required"
+ }
+
+ set o_array($args) $val
+ incr o_size
+
+ #return [array size o_array]
+ return $o_size
+}
+>matrix .. PatternMethod names {} {
+ var o_array
+ array names o_array
+}
+>matrix .. PatternMethod keys {} {
+ #synonym for names
+ var o_array
+ array names o_array
+}
+>matrix .. PatternMethod hasKey {args} {
+ var o_array
+
+ return [info exists o_array($args)]
+}
+>matrix .. PatternMethod clear {} {
+ var o_array o_size
+ unset o_array
+ set o_size 0
+ return
+}
+>matrix .. PatternMethod count {} {
+ var o_size
+ return $o_size
+}
+>matrix .. PatternMethod count2 {} {
+ var o_array
+ #see comments for >hashMap count2
+ return [array size o_array]
+}
+#>matrix .. Ready 1
+
+#--------------------------------------------------------
+#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming)
+#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html
+#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden.
+::>pattern .. Create >tree
+
+set _NODE [::>pattern .. Create [>tree .. Namespace]::>node]
+set _TREE_NODE $_NODE
+#process_pattern_aliases $_TREE_NODE
+
+$_NODE .. PatternVariable o_treens ;#tree namespace
+$_NODE .. PatternVariable o_idref
+$_NODE .. PatternVariable o_nodePrototype
+
+#$_NODE .. PatternProperty data
+$_NODE .. PatternProperty info
+
+$_NODE .. PatternProperty tree
+$_NODE .. PatternProperty parent
+$_NODE .. PatternProperty children
+$_NODE .. PatternMethod addNode {} {
+ set nd_id [incr $o_idref]
+ set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@]
+ @this@ . add $nd n-$nd_id
+
+ return n-$nd_id
+}
+#flat list of all nodes below this
+#!todo - something else? ad-hoc collections?
+#!todo - non-recursive version? tail-call opt?
+$_NODE .. PatternMethod nodes {} {
+ set result [list]
+
+ #use(abuse?) our knowledge of >collection internals
+ foreach n $o_list {
+ #eval lappend result $n [$o_array($n) . nodes]
+ #!todo - test
+ lappend result $n {*}[$o_array($n) . nodes]
+ }
+ return $result
+}
+#count of number of descendants
+#!todo - non-recursive version? tail-call opt?
+$_NODE .. PatternMethod size {} {
+ set result 0
+ #use(abuse?) our knowledge of >collection internals
+ foreach n $o_list {
+ incr result [expr {1 + [$o_array($n) . size]}]
+ }
+ return $result
+}
+$_NODE .. PatternMethod isLeaf {} {
+ #!todo - way to stop unused vars being uplevelled?
+ var o_tree
+
+ #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns?
+ tailcall [@this@ . isEmpty .]
+}
+$_NODE .. Constructor {args} {
+ array set A $args
+
+ set o_tree $A(-tree)
+ set o_parent $A(-parent)
+
+ #array set o_data [list]
+ array set o_info [list]
+
+ set o_nodePrototype [::patternlib::>tree .. Namespace]::>node
+ set o_idref [$o_tree . nodeID .]
+ set o_treens [$o_tree .. Namespace]
+ #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children]
+
+ #overlay children collection directly on the node
+ set o_children [::patternlib::>collection .. Create @this@]
+
+ return
+}
+
+>tree .. PatternProperty test blah
+>tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept?
+>tree .. PatternVariable o_ns
+>tree .. Constructor {args} {
+ set o_ns [@this@ .. Namespace]
+
+ #>tree is itself also a node (root node)
+ #overlay new 'root' node onto existing tree, pass tree to constructor
+ [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent ""
+}
+
+
+
+
+unset _NODE
+
+
+
+
+#--------------------------------------------------------
+#a basic binary search tree experiment
+# - todo - 'scheme' property to change behaviour? e.g balanced tree
+::>pattern .. Create >bst
+#process_pattern_aliases ::patternlib::>bst
+>bst .. PatternVariable o_NS ;#namespace
+>bst .. PatternVariable o_this ;#namespace
+>bst .. PatternVariable o_nodeID
+
+>bst .. PatternProperty root ""
+>bst .. Constructor {args} {
+ set o_this @this@
+ set o_NS [$o_this .. Namespace]
+ namespace eval ${o_NS}::nodes {}
+ puts stdout ">bst constructor"
+ set o_nodeID 0
+}
+>bst .. PatternMethod insert {key args} {
+ set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]]
+ set [$newnode . key .] $key
+ if {[llength $args]} {
+ set [$newnode . value .] $args
+ }
+ if {![string length $o_root]} {
+ set o_root $newnode
+ set [$newnode . parent .] $o_this
+ } else {
+ set ipoint {} ;#insertion point
+ set tpoint $o_root ;#test point
+ set side {}
+ while {[string length $tpoint]} {
+ set ipoint $tpoint
+ if {[$newnode . key] < [$tpoint . key]} {
+ set tpoint [$tpoint . left]
+ set side left
+ } else {
+ set tpoint [$tpoint . right]
+ set side right
+ }
+ }
+ set [$newnode . parent .] $ipoint
+ set [$ipoint . $side .] $newnode
+ }
+ return $newnode
+}
+>bst .. PatternMethod item {key} {
+ if {![string length $o_root]} {
+ error "item $key not found"
+ } else {
+ set tpoint $o_root
+ while {[string length $tpoint]} {
+ if {[$tpoint . key] eq $key} {
+ return $tpoint
+ } else {
+ if {$key < [$tpoint . key]} {
+ set tpoint [$tpoint . left]
+ } else {
+ set tpoint [$tpoint . right]
+ }
+ }
+ }
+ error "item $key not found"
+ }
+}
+>bst .. PatternMethod inorder-walk {} {
+ if {[string length $o_root]} {
+ $o_root . inorder-walk
+ }
+ puts {}
+}
+>bst .. PatternMethod view {} {
+ array set result [list]
+
+ if {[string length $o_root]} {
+ array set result [$o_root . view 0 [list]]
+ }
+
+ foreach depth [lsort [array names result]] {
+ puts "$depth: $result($depth)"
+ }
+
+}
+::>pattern .. Create >bstnode
+#process_pattern_aliases ::patternlib::>bstnode
+>bstnode .. PatternProperty parent
+>bstnode .. PatternProperty left ""
+>bstnode .. PatternProperty right ""
+>bstnode .. PatternProperty key
+>bstnode .. PatternProperty value
+
+>bstnode .. PatternMethod inorder-walk {} {
+ if {[string length $o_left]} {
+ $o_left . inorder-walk
+ }
+
+ puts -nonewline "$o_key "
+
+ if {[string length $o_right]} {
+ $o_right . inorder-walk
+ }
+
+ return
+}
+>bstnode .. PatternMethod view {depth state} {
+ #!todo - show more useful representation of structure
+ set lower [incr depth]
+
+ if {[string length $o_left]} {
+ set state [$o_left . view $lower $state]
+ }
+
+ if {[string length $o_right]} {
+ set state [$o_right . view $lower $state]
+ }
+
+
+ array set s $state
+ lappend s($depth) $o_key
+
+ return [array get s]
+}
+
+
+#--------------------------------------------------------
+#::pattern::create ::pattern::>metaObject
+#::pattern::>metaObject PatternProperty methods
+#::pattern::>metaObject PatternProperty properties
+#::pattern::>metaObject PatternProperty PatternMethods
+#::pattern::>metaObject PatternProperty patternProperties
+#::pattern::>metaObject Constructor args {
+# set this @this@
+#
+# set [$this . methods .] [::>collection create [$this namespace]::methods]
+# set [$this . properties .] [::>collection create [$this namespace]::properties]
+# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods]
+# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties]
+#
+#}
+
+
+
+ #tidy up
+ unset PV
+ unset PM
+
+
+
+#--------------------------------------------------------
+::>pattern .. Create >enum
+#process_pattern_aliases ::patternlib::>enum
+>enum .. PatternMethod item {{idx 0}} {
+ var o_array o_list
+
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0} {
+ set idx "end-[expr {abs($idx + 1)}]"
+ }
+ if {[catch {set o_array([lindex $o_list $idx])} result]} {
+ error "no such index : '$idx'"
+ } else {
+ return $result
+ }
+ } else {
+ if {[catch {set o_array($idx)} result]} {
+ error "no such index: '$idx'"
+ } else {
+ return $result
+ }
+ }
+}
+
+
+
+#proc makeenum {type identifiers} {
+# #!!todo - make generated procs import into whatever current system context?
+#
+# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2
+#
+# #obliterate any previous enum for this type
+# catch {unset a1}
+# catch {unset a2}
+#
+# set n 0
+# foreach id $identifiers {
+# set a1($id) $n
+# set a2($n) $id
+# incr n
+# }
+# proc ::${type}_to_number key [string map [list @type@ $type] {
+# upvar #0 wbpbenum_@type@_number ary
+# if {[catch {set ary($key)} num]} {
+# return -code error "unknown @type@ '$key'"
+# }
+# return $num
+# }]
+#
+# proc ::number_to_${type} {number} [string map [list @type@ $type] {
+# upvar #0 wbpbenum_number_@type@ ary
+# if {[catch {set ary($number)} @type@]} {
+# return -code error "no @type@ for '$number'"
+# }
+# return $@type@
+# }]
+#
+# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}"
+# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}"
+#}
+#
+#--------------------------------------------------------
+::>pattern .. Create >nest
+>nest .. PatternVariable THIS
+>nest .. PatternProperty data -autoclone
+>nest .. Constructor {args} {
+ var o_data
+ var THIS
+ set THIS @this@
+ array set o_data [list]
+}
+>nest .. PatternMethod item {args} {
+ set THIS @this@
+ return [$THIS . data [join $args ,]]
+}
+
+#
+# e.g
+# set [>nest a , b . data c .] blah
+# >nest a , b , c
+#
+# set [>nest w x , y . data z .] etc
+# >nest w x , y , z
+#--------------------------------------------------------
+
+}
+
+}
+
+
+#package require patternlibtemp
diff --git a/src/bootsupport/modules_tcl8/patternpredator2-1.2.4.tm b/src/bootsupport/modules_tcl8/patternpredator2-1.2.4.tm
new file mode 100644
index 00000000..680ea88f
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/patternpredator2-1.2.4.tm
@@ -0,0 +1,754 @@
+package provide patternpredator2 1.2.4
+
+proc ::p::internals::jaws {OID _ID_ args} {
+ #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args"
+ #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
+
+ yield
+ set w 1
+
+ set stack [list]
+ set wordcount [llength $args]
+ set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first
+ set unsupported 0
+ set operator ""
+ set operator_prev "" ;#used only by argprotect to revert to previous operator
+
+
+ if {$OID ne "null"} {
+ #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!)
+ #upvar #0 ::p::${OID}::_meta::map MAP
+ set MAP [set ::p::${OID}::_meta::map]
+ } else {
+ # error "jaws - OID = 'null' ???"
+ set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key
+ }
+ set invocantdata [dict get $MAP invocantdata]
+ lassign $invocantdata OID alias default_method object_command wrapped
+
+ set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code
+
+ #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w
+ while {$w < $wordcount} {
+ set word [lindex $args [expr {$w -1}]]
+ #puts stdout "w:$w word:$word stack:$stack"
+
+ if {$operator eq "argprotect"} {
+ set operator $operator_prev
+ lappend stack $word
+ incr w
+ } else {
+ if {[llength $stack]} {
+ if {$word in $terminals} {
+ set reduction [list 0 $_ID_ {*}$stack ]
+ #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w"
+
+
+ set _ID_ [yield $reduction]
+ set stack [list]
+ #set OID [::pattern::get_oid $_ID_]
+ set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
+
+ if {$OID ne "null"} {
+ set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here!
+ } else {
+ set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]]
+ #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????"
+ }
+
+ #review - 2018. switched to _ID_ instead of MAP
+ lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command
+ #lassign [dict get $MAP invocantdata] OID alias default_method object_command
+
+
+ #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command"
+ set operator $word
+ #don't incr w
+ #incr w
+ } else {
+ if {$operator eq "argprotect"} {
+ set operator $operator_prev
+ set operator_prev ""
+ lappend stack $word
+ } else {
+ #only look for leading argprotect chacter (-) if we're not already in argprotect mode
+ if {$word eq "--"} {
+ set operator_prev $operator
+ set operator "argprotect"
+ #Don't add the plain argprotector to the stack
+ } elseif {[string match "-*" $word]} {
+ #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
+ set operator_prev $operator
+ set operator "argprotect"
+ lappend stack $word
+ } else {
+ lappend stack $word
+ }
+ }
+
+
+ incr w
+ }
+ } else {
+ #no stack
+ switch -- $word {.} {
+
+ if {$OID ne "null"} {
+ #we know next word is a property or method of a pattern object
+ incr w
+ set nextword [lindex $args [expr {$w - 1}]]
+ set command ::p::${OID}::$nextword
+ set stack [list $command] ;#2018 j
+ set operator .
+ if {$w eq $wordcount} {
+ set finished_args 1
+ }
+ } else {
+ # don't incr w
+ #set nextword [lindex $args [expr {$w - 1}]]
+ set command $object_command ;#taken from the MAP
+ set stack [list "_exec_" $command]
+ set operator .
+ }
+
+
+ } {..} {
+ incr w
+ set nextword [lindex $args [expr {$w -1}]]
+ set command ::p::-1::$nextword
+ #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list.
+ set stack [list $command] ;#faster, and intent is clearer than lappend.
+ set operator ..
+ if {$w eq $wordcount} {
+ set finished_args 1
+ }
+ } {,} {
+ #puts stdout "Stackless comma!"
+
+
+ if {$OID ne "null"} {
+ set command ::p::${OID}::$default_method
+ } else {
+ set command [list $default_method $object_command]
+ #object_command in this instance presumably be a list and $default_method a list operation
+ #e.g "lindex {A B C}"
+ }
+ #lappend stack $command
+ set stack [list $command]
+ set operator ,
+ } {--} {
+ set operator_prev $operator
+ set operator argprotect
+ #no stack -
+ } {!} {
+ set command $object_command
+ set stack [list "_exec_" $object_command]
+ #puts stdout "!!!! !!!! $stack"
+ set operator !
+ } default {
+ if {$operator eq ""} {
+ if {$OID ne "null"} {
+ set command ::p::${OID}::$default_method
+ } else {
+ set command [list $default_method $object_command]
+ }
+ set stack [list $command]
+ set operator ,
+ lappend stack $word
+ } else {
+ #no stack - so we don't expect to be in argprotect mode already.
+ if {[string match "-*" $word]} {
+ #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
+ set operator_prev $operator
+ set operator "argprotect"
+ lappend stack $word
+ } else {
+ lappend stack $word
+ }
+
+ }
+ }
+ incr w
+ }
+
+ }
+ } ;#end while
+
+ #process final word outside of loop
+ #assert $w == $wordcount
+ #trailing operators or last argument
+ if {!$finished_args} {
+ set word [lindex $args [expr {$w -1}]]
+ if {$operator eq "argprotect"} {
+ set operator $operator_prev
+ set operator_prev ""
+
+ lappend stack $word
+ incr w
+ } else {
+
+
+ switch -- $word {.} {
+ if {![llength $stack]} {
+ #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]]
+ yieldto return [::p::internals::ref_to_object $_ID_]
+ error "assert: never gets here"
+
+ } else {
+ #puts stdout "==== $stack"
+ #assert - whenever _ID_ changed in this proc - we have updated the $OID variable
+ yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack]
+ error "assert: never gets here"
+ }
+ set operator .
+
+ } {..} {
+ #trailing .. after chained call e.g >x . item 0 ..
+ #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$"
+ #set reduction [list 0 $_ID_ {*}$stack]
+ yieldto return [yield [list 0 $_ID_ {*}$stack]]
+ } {#} {
+ set unsupported 1
+ } {,} {
+ set unsupported 1
+ } {&} {
+ set unsupported 1
+ } {@} {
+ set unsupported 1
+ } {--} {
+
+ #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]]
+ #puts stdout " -> -> -> about to call yield $reduction <- <- <-"
+ set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ]
+ #set OID [::pattern::get_oid $_ID_]
+ set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
+
+ if {$OID ne "null"} {
+ set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
+ } else {
+ set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ]
+ }
+ yieldto return $MAP
+ } {!} {
+ #error "untested branch"
+ set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]]
+ #set OID [::pattern::get_oid $_ID_]
+ set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
+
+ if {$OID ne "null"} {
+ set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
+ } else {
+ set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ]
+ }
+ lassign [dict get $MAP invocantdata] OID alias default_command object_command
+ set command $object_command
+ set stack [list "_exec_" $command]
+ set operator !
+ } default {
+ if {$operator eq ""} {
+ #error "untested branch"
+ lassign [dict get $MAP invocantdata] OID alias default_command object_command
+ #set command ::p::${OID}::item
+ set command ::p::${OID}::$default_command
+ lappend stack $command
+ set operator ,
+
+ }
+ #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway.
+ lappend stack $word
+ }
+ if {$unsupported} {
+ set unsupported 0
+ error "trailing '$word' not supported"
+
+ }
+
+ #if {$operator eq ","} {
+ # incr wordcount 2
+ # set stack [linsert $stack end-1 . item]
+ #}
+ incr w
+ }
+ }
+
+
+ #final = 1
+ #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]"
+
+ return [list 1 $_ID_ {*}$stack]
+}
+
+
+
+#trailing. directly after object
+proc ::p::internals::ref_to_object {_ID_} {
+ set OID [lindex [dict get $_ID_ i this] 0 0]
+ upvar #0 ::p::${OID}::_meta::map MAP
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command
+ set refname ::p::${OID}::_ref::__OBJECT
+
+ array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces
+
+ set traceCmd [list ::p::predator::object_read_trace $OID $_ID_]
+ if {[list {read} $traceCmd] ni [trace info variable $refname]} {
+ #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'"
+ trace add variable $refname {read} $traceCmd
+ }
+ set traceCmd [list ::p::predator::object_array_trace $OID $_ID_]
+ if {[list {array} $traceCmd] ni [trace info variable $refname]} {
+ trace add variable $refname {array} $traceCmd
+ }
+
+ set traceCmd [list ::p::predator::object_write_trace $OID $_ID_]
+ if {[list {write} $traceCmd] ni [trace info variable $refname]} {
+ trace add variable $refname {write} $traceCmd
+ }
+
+ set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_]
+ if {[list {unset} $traceCmd] ni [trace info variable $refname]} {
+ trace add variable $refname {unset} $traceCmd
+ }
+ return $refname
+}
+
+
+proc ::p::internals::create_or_update_reference {OID _ID_ refname command} {
+ #if {[lindex $fullstack 0] eq "_exec_"} {
+ # #strip it. This instruction isn't relevant for a reference.
+ # set commandstack [lrange $fullstack 1 end]
+ #} else {
+ # set commandstack $fullstack
+ #}
+ #set argstack [lassign $commandstack command]
+ #set field [string map {> __OBJECT_} [namespace tail $command]]
+
+
+
+ set reftail [namespace tail $refname]
+ set argstack [lassign [split $reftail +] field]
+ set field [string map {> __OBJECT_} [namespace tail $command]]
+
+ #puts stderr "refname:'$refname' command: $command field:$field"
+
+
+ if {$OID ne "null"} {
+ upvar #0 ::p::${OID}::_meta::map MAP
+ } else {
+ #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map]
+ set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}]
+ }
+ lassign [dict get $MAP invocantdata] OID alias default_method object_command
+
+
+
+ if {$OID ne "null"} {
+ interp alias {} $refname {} $command $_ID_ {*}$argstack
+ } else {
+ interp alias {} $refname {} $command {*}$argstack
+ }
+
+
+ #set iflist [lindex $map 1 0]
+ set iflist [dict get $MAP interfaces level0]
+ #set iflist [dict get $MAP interfaces level0]
+ set field_is_property_like 0
+ foreach IFID [lreverse $iflist] {
+ #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient.
+ if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} {
+ set field_is_property_like 1
+ #There is a setter or getter (but not necessarily an entry in the o_properties dict)
+ break
+ }
+ }
+
+
+
+
+ #whether field is a property or a method - remove any commandrefMisuse_TraceHandler
+ foreach tinfo [trace info variable $refname] {
+ #puts "-->removing traces on $refname: $tinfo"
+ if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} {
+ trace remove variable $refname {*}$tinfo
+ }
+ }
+
+ if {$field_is_property_like} {
+ #property reference
+
+
+ set this_invocantdata [lindex [dict get $_ID_ i this] 0]
+ lassign $this_invocantdata OID _alias _defaultmethod object_command
+ #get fully qualified varspace
+
+ #
+ set propdict [$object_command .. GetPropertyInfo $field]
+ if {[dict exist $propdict $field]} {
+ set field_is_a_property 1
+ set propinfo [dict get $propdict $field]
+ set varspace [dict get $propinfo varspace]
+ if {$varspace eq ""} {
+ set full_varspace ::p::${OID}
+ } else {
+ if {[::string match "::*" $varspace]} {
+ set full_varspace $varspace
+ } else {
+ set full_varspace ::p::${OID}::$varspace
+ }
+ }
+ } else {
+ set field_is_a_property 0
+ #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property
+ #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later)
+ set full_varspace ::p::${OID}
+ }
+
+
+
+
+
+ #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first))
+ set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field]
+ if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
+ trace add variable ${full_varspace}::o_${field} {write} $Hndlr
+ }
+ set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field]
+ if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
+ trace add variable ${full_varspace}::o_${field} {unset} $Hndlr
+ }
+
+
+ #supply all data in easy-access form so that propref_trace_read is not doing any extra work.
+ set get_cmd ::p::${OID}::(GET)$field
+ set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack]
+
+ if {[list {read} $traceCmd] ni [trace info variable $refname]} {
+ set fieldvarname ${full_varspace}::o_${field}
+
+
+ #synch the refvar with the real var if it exists
+ #catch {set $refname [$refname]}
+ if {[array exists $fieldvarname]} {
+ if {![llength $argstack]} {
+ #unindexed reference
+ array set $refname [array get $fieldvarname]
+ #upvar $fieldvarname $refname
+ } else {
+ set s0 [lindex $argstack 0]
+ #refs to nonexistant array members common? (catch vs 'info exists')
+ if {[info exists ${fieldvarname}($s0)]} {
+ set $refname [set ${fieldvarname}($s0)]
+ }
+ }
+ } else {
+ #refs to uninitialised props actually should be *very* common.
+ #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive.
+ #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch.
+
+ #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches!
+
+ #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------"
+
+
+ if {![llength $argstack]} {
+ #catch {set $refname [set ::p::${OID}::o_$field]}
+ if {[info exists $fieldvarname]} {
+ set $refname [set $fieldvarname]
+ #upvar $fieldvarname $refname
+ }
+ } else {
+ if {[llength $argstack] == 1} {
+ #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]}
+ if {[info exists $fieldvarname]} {
+ set $refname [lindex [set $fieldvarname] [lindex $argstack 0]]
+ }
+
+ } else {
+ #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]}
+ if {[info exists $fieldvarname]} {
+ set $refname [lindex [set $fieldvarname] $argstack]
+ }
+ }
+ }
+
+ #! what if someone has put a trace on ::errorInfo??
+ #set ::errorInfo $errorInfo_prev
+ }
+ trace add variable $refname {read} $traceCmd
+
+ set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname]
+ trace add variable $refname {write} $traceCmd
+
+ set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname]
+ trace add variable $refname {unset} $traceCmd
+
+
+ set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname]
+ # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd"
+ trace add variable $refname {array} $traceCmd
+ }
+
+ } else {
+ #puts "$refname ====> adding refMisuse_traceHandler $alias $field"
+ #matching variable in order to detect attempted use as property and throw error
+
+ #2018
+ #Note that we are adding a trace on a variable (the refname) which does not exist.
+ #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex)
+ #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added
+ ##array set $refname {} ;#empty array
+ # - the empty array would mean a slightly better error message when misusing a command ref as an array
+ #but this seems like a code complication for little benefit
+ #review
+
+ trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field]
+ }
+}
+
+
+
+#trailing. after command/property
+proc ::p::internals::ref_to_stack {OID _ID_ fullstack} {
+ if {[lindex $fullstack 0] eq "_exec_"} {
+ #strip it. This instruction isn't relevant for a reference.
+ set commandstack [lrange $fullstack 1 end]
+ } else {
+ set commandstack $fullstack
+ }
+ set argstack [lassign $commandstack command]
+ set field [string map {> __OBJECT_} [namespace tail $command]]
+
+
+ #!todo?
+ # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace.
+ # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted.
+
+
+ #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself.
+ # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables.
+
+
+ set refname ::p::${OID}::_ref::[join [concat $field $argstack] +]
+
+ if {[llength [info commands $refname]]} {
+ #todo - review - what if the field changed to/from a property/method?
+ #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs
+ return $refname
+ }
+ ::p::internals::create_or_update_reference $OID $_ID_ $refname $command
+ return $refname
+}
+
+
+namespace eval pp {
+ variable operators [list .. . -- - & @ # , !]
+ variable operators_notin_args ""
+ foreach op $operators {
+ append operators_notin_args "({$op} ni \$args) && "
+ }
+ set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands
+ #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)}
+}
+interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks!
+
+
+
+
+
+# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism.
+#each map is a 2 element list of lists.
+# form: {$commandinfo $interfaceinfo}
+# commandinfo is of the form: {ID Namespace defaultmethod commandname _?}
+
+#2018
+#each map is a dict.
+#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}}
+
+
+#OID = Object ID (integer for now - could in future be a uuid)
+proc ::p::predator2 {_ID_ args} {
+ #puts stderr "predator2: _ID_:'$_ID_' args:'$args'"
+ #set invocants [dict get $_ID_ i]
+ #set invocant_roles [dict keys $invocants]
+
+ #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc.
+ #set this_role_members [dict get $invocants this]
+ #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list.
+ #lassign $this_invocant this_OID this_info_dict
+
+ set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
+
+
+ set cheat 1 ;#
+ #-------
+ #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call)
+ #(it should be functionally equivalent to remove this shortcut block)
+ if {$cheat} {
+ if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} {
+
+ set remaining_args [lassign $args dot method_or_prop]
+
+ #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ???
+ set command ::p::${this_OID}::$method_or_prop
+ #REVIEW!
+ #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say')
+ #if {[llength $command] > 1} {
+ # error "methods with spaces not included in test suites - todo fix!"
+ #}
+ #Dont use {*}$command - (so we can support methods with spaces)
+ #if {![llength [info commands $command]]} {}
+ if {[namespace which $command] eq ""} {
+ if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} {
+ #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces
+ set command ::p::${this_OID}::(UNKNOWN)
+ #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
+ tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
+ } else {
+ return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found"
+ }
+ } else {
+ #tailcall {*}$command $_ID_ {*}$remaining_args
+ tailcall $command $_ID_ {*}$remaining_args
+ }
+ }
+ }
+ #------------
+
+
+ if {([llength $args] == 1) && ([lindex $args 0] eq "..")} {
+ return $_ID_
+ }
+
+
+ #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args"
+
+
+
+ #puts stderr "this_info_dict: $this_info_dict"
+
+
+
+
+ if {![llength $args]} {
+ #should return some sort of public info.. i.e probably not the ID which is an implementation detail
+ #return cmd
+ return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID
+
+ #return a dict keyed on object command name - (suitable as use for a .. Create 'target')
+ #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped
+ #return [list $object_command [list -id $this_OID ]]
+ } elseif {[llength $args] == 1} {
+ #short-circuit the single index case for speed.
+ if {[lindex $args 0] ni {.. . -- - & @ # , !}} {
+ #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method
+ lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method
+
+ tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0]
+ } elseif {[lindex $args 0] eq {--}} {
+
+ #!todo - we could hide the invocant by only allowing this call from certain uplevel procs..
+ # - combined with using UUIDs for $OID, and a secured/removed metaface on the object
+ # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases)
+ # - this could effectively hide the object's namespaces,vars etc from the caller (?)
+ return [set ::p::${this_OID}::_meta::map]
+ }
+ }
+
+
+
+ #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls)
+ #incr c
+ #set reduce ::p::reducer${this_OID}_$c
+ set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance]
+ #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args"
+ coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args
+
+
+ set current_ID_ $_ID_
+
+ set final 0
+ set result ""
+ while {$final == 0} {
+ #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws)
+ set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command]
+ #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'"
+ #if {[string match *Destroy $command]} {
+ # puts stdout " calling Destroy reduction_args:'$reduction_args'"
+ #}
+ if {$final == 1} {
+
+ if {[llength $command] == 1} {
+ if {$command eq "_exec_"} {
+ tailcall {*}$reduction_args
+ }
+ if {[llength [info commands $command]]} {
+ tailcall {*}$command $current_ID_ {*}$reduction_args
+ }
+ set cmdname [namespace tail $command]
+ set this_OID [lindex [dict get $current_ID_ i this] 0 0]
+ if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
+ lset command 0 ::p::${this_OID}::(UNKNOWN)
+ tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg.
+ } else {
+ return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
+ }
+
+ } else {
+ #e.g lindex {a b c}
+ tailcall {*}$command {*}$reduction_args
+ }
+
+
+ } else {
+ if {[lindex $command 0] eq "_exec_"} {
+ set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]]
+
+ set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ]
+ } else {
+ if {[llength $command] == 1} {
+ if {![llength [info commands $command]]} {
+ set cmdname [namespace tail $command]
+ set this_OID [lindex [dict get $current_ID_ i this] 0 0]
+ if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
+
+ lset command 0 ::p::${this_OID}::(UNKNOWN)
+ set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
+ } else {
+ return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
+ }
+ } else {
+ #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
+ set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
+
+ }
+ } else {
+ set result [uplevel 1 [list {*}$command {*}$reduction_args]]
+ }
+
+ if {[llength [info commands $result]]} {
+ if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} {
+ #looks like a pattern command
+ set current_ID_ [$result .. INVOCANTDATA]
+
+
+ #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA
+ #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} {
+ # set current_ID_ $result_invocantdata
+ #} else {
+ # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object"
+ #}
+ } else {
+ #non-pattern command
+ set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
+ }
+ } else {
+ set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
+ #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists)
+
+ }
+ }
+
+ }
+ }
+ error "Assert: Shouldn't get here (end of ::p::predator2)"
+ #return $result
+}
diff --git a/src/bootsupport/modules_tcl8/promise-1.2.0.tm b/src/bootsupport/modules_tcl8/promise-1.2.0.tm
new file mode 100644
index 00000000..a4b82e45
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/promise-1.2.0.tm
@@ -0,0 +1,1311 @@
+# Copyright (c) 2015-2023, Ashok P. Nadkarni
+# All rights reserved.
+
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+package require Tcl 8.6-
+
+namespace eval promise {
+ proc version {} { return 1.2.0 }
+}
+
+proc promise::lambda {params body args} {
+ # Creates an anonymous procedure and returns a command prefix for it.
+ # params - parameter definitions for the procedure
+ # body - body of the procedures
+ # args - additional arguments to be passed to the procedure when it
+ # is invoked
+ #
+ # This is just a convenience command since anonymous procedures are
+ # commonly useful with promises. The lambda package from tcllib
+ # is identical in function.
+
+ return [list ::apply [list $params $body] {*}$args]
+}
+
+catch {promise::Promise destroy}
+oo::class create promise::Promise {
+
+ # The promise state can be one of
+ # PENDING - Initial state where it has not yet been assigned a
+ # value or error
+ # FULFILLED - The promise has been assigned a value
+ # REJECTED - The promise has been assigned an error
+ # CHAINED - The promise is attached to another promise
+ variable _state
+
+ # Stores data that is accessed through the setdata/getdata methods.
+ # The Promise class itself does not use this.
+ variable _clientdata
+
+ # The promise value once it is fulfilled or rejected. In the latter
+ # case, it should be an the error message
+ variable _value
+
+ # The error dictionary in case promise is rejected
+ variable _edict
+
+ # Reactions to be notified when the promise is rejected. Each element
+ # in this list is a pair consisting of the fulfilment reaction
+ # and the rejection reaction. Either element of the pair could be
+ # empty signifying no reaction for that case. The list is populated
+ # via the then method.
+ variable _reactions
+
+ # Reference counting to free up promises since Tcl does not have
+ # garbage collection for objects. Garbage collection via reference
+ # counting only takes place after at least one done/then reaction
+ # is placed on the event queue, not before. Else promises that
+ # are immediately resolved on construction would be freed right
+ # away before the application even gets a chance to call done/then.
+ variable _do_gc
+ variable _nrefs
+
+ # If no reject reactions are registered, then the Tcl bgerror
+ # handler is invoked. But don't want to do this more than once
+ # so track it
+ variable _bgerror_done
+
+ constructor {cmd} {
+ # Create a promise for the asynchronous operation to be initiated
+ # by $cmd.
+ # cmd - a command prefix that should initiate an asynchronous
+ # operation.
+ # The command prefix $cmd is passed an additional argument - the
+ # name of this Promise object. It should arrange for one of the
+ # object's settle methods [fulfill], [chain] or
+ # [reject] to be called when the operation completes.
+
+ set _state PENDING
+ set _reactions [list ]
+ set _do_gc 0
+ set _bgerror_done 0
+ set _nrefs 0
+ array set _clientdata {}
+
+ # Errors in the construction command are returned via
+ # the standard mechanism of reject.
+ #
+ if {[catch {
+ # For some special cases, $cmd may be "" if the async operation
+ # is initiated outside the constructor. This is not a good
+ # thing because the error in the initiator will not be
+ # trapped via the standard promise error catching mechanism
+ # but that's the application's problem (actually pgeturl also
+ # uses this).
+ if {[llength $cmd]} {
+ uplevel #0 [linsert $cmd end [self]]
+ }
+ } msg edict]} {
+ my reject $msg $edict
+ }
+ }
+
+ destructor {
+ # Destroys the object.
+ #
+ # This method should not be generally called directly as [Promise]
+ # objects are garbage collected either automatically or via the [ref]
+ # and [unref] methods.
+ }
+
+ method state {} {
+ # Returns the current state of the promise.
+ #
+ # The promise state may be one of the values `PENDING`,
+ # `FULFILLED`, `REJECTED` or `CHAINED`
+ return $_state
+ }
+
+ method getdata {key} {
+ # Returns data previously stored through the setdata method.
+ # key - key whose associated values is to be returned.
+ # An error will be raised if no value is associated with the key.
+ return $_clientdata($key)
+ }
+
+ method setdata {key value} {
+ # Sets a value to be associated with a key.
+ # key - the lookup key
+ # value - the value to be associated with the key
+ # A promise internally maintains a dictionary whose values can
+ # be accessed with the [getdata] and [setdata] methods. This
+ # dictionary is not used by the Promise class itself but is meant
+ # to be used by promise library specializations or applications.
+ # Callers need to take care that keys used for a particular
+ # promise are sufficiently distinguishable so as to not clash.
+ #
+ # Returns the value stored with the key.
+ set _clientdata($key) $value
+ }
+
+ method value {} {
+ # Returns the settled value for the promise.
+ #
+ # The returned value may be the fulfilled value or the rejected
+ # value depending on whether the associated operation was successfully
+ # completed or failed.
+ #
+ # An error is raised if the promise is not settled yet.
+ if {$_state ni {FULFILLED REJECTED}} {
+ error "Value is not set."
+ }
+ return $_value
+ }
+
+ method ref {} {
+ # Increments the reference count for the object.
+ incr _nrefs
+ }
+
+ method unref {} {
+ # Decrements the reference count for the object.
+ #
+ # The object may have been destroyed when the call returns.
+ incr _nrefs -1
+ my GC
+ }
+
+ method nrefs {} {
+ # Returns the current reference count.
+ #
+ # Use for debugging only! Note, internal references are not included.
+ return $_nrefs
+ }
+
+ method GC {} {
+ if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} {
+ my destroy
+ }
+ }
+
+ method FulfillAttached {value} {
+ if {$_state ne "CHAINED"} {
+ return
+ }
+ set _value $value
+ set _state FULFILLED
+ my ScheduleReactions
+ return
+ }
+
+ method RejectAttached {reason edict} {
+ if {$_state ne "CHAINED"} {
+ return
+ }
+ set _value $reason
+ set _edict $edict
+ set _state REJECTED
+ my ScheduleReactions
+ return
+ }
+
+ # Method to invoke to fulfil a promise with a value or another promise.
+ method fulfill {value} {
+ # Fulfills the promise.
+ # value - the value with which the promise is fulfilled
+ #
+ # Returns `0` if promise had already been settled and `1` if
+ # it was fulfilled by the current call.
+
+ #ruff
+ # If the promise has already been settled, the method has no effect.
+ if {$_state ne "PENDING"} {
+ return 0; # Already settled
+ }
+
+ #ruff
+ # Otherwise, it is transitioned to the `FULFILLED` state with
+ # the value specified by $value. If there are any fulfillment
+ # reactions registered by the [Promise.done] or [Promise.then] methods, they
+ # are scheduled to be run.
+ set _value $value
+ set _state FULFILLED
+ my ScheduleReactions
+ return 1
+ }
+
+ # Method to invoke to fulfil a promise with a value or another promise.
+ method chain {promise} {
+ # Chains the promise to another promise.
+ # promise - the [Promise] object to which this promise is to
+ # be chained
+ #
+ # Returns `0` if promise had already been settled and `1` otherwise.
+
+ #ruff
+ # If the promise on which this method is called
+ # has already been settled, the method has no effect.
+ if {$_state ne "PENDING"} {
+ return 0;
+ }
+
+ #ruff
+ # Otherwise, it is chained to $promise so that it reflects that
+ # other promise's state.
+ if {[catch {
+ $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}]
+ } msg edict]} {
+ my reject $msg $edict
+ } else {
+ set _state CHAINED
+ }
+
+ return 1
+ }
+
+ method reject {reason {edict {}}} {
+ # Rejects the promise.
+ # reason - a message string describing the reason for the rejection.
+ # edict - a Tcl error dictionary
+ #
+ # The $reason and $edict values are passed on to the rejection
+ # reactions. By convention, these should be of the form returned
+ # by the `catch` or `try` commands in case of errors.
+ #
+ # Returns `0` if promise had already been settled and `1` if
+ # it was rejected by the current call.
+
+ #ruff
+ # If the promise has already been settled, the method has no effect.
+ if {$_state ne "PENDING"} {
+ return 0; # Already settled
+ }
+
+ #ruff
+ # Otherwise, it is transitioned to the `REJECTED` state. If
+ # there are any reject reactions registered by the [Promise.done] or
+ # [Promise.then] methods, they are scheduled to be run.
+
+ set _value $reason
+ #ruff
+ # If $edict is not specified, or specified as an empty string,
+ # a suitable error dictionary is constructed in its place
+ # to be passed to the reaction.
+ if {$edict eq ""} {
+ catch {throw {PROMISE REJECTED} $reason} - edict
+ }
+ set _edict $edict
+ set _state REJECTED
+ my ScheduleReactions
+ return 1
+ }
+
+ # Internal method to queue all registered reactions based on
+ # whether the promise is succesfully fulfilled or not
+ method ScheduleReactions {} {
+ if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } {
+ # Promise is not settled or no reactions registered
+ return
+ }
+
+ # Note on garbage collection: garbage collection is to be enabled if
+ # at least one FULFILLED or REJECTED reaction is registered.
+ # Also if the promise is REJECTED but no rejection handlers are run
+ # we also schedule a background error.
+ # In all cases, CLEANUP reactions do not count.
+ foreach reaction $_reactions {
+ foreach type {FULFILLED REJECTED} {
+ if {[dict exists $reaction $type]} {
+ set _do_gc 1
+ if {$type eq $_state} {
+ set cmd [dict get $reaction $type]
+ if {[llength $cmd]} {
+ if {$type eq "FULFILLED"} {
+ lappend cmd $_value
+ } else {
+ lappend cmd $_value $_edict
+ }
+ set ran_reaction($type) 1
+ # Enqueue the reaction via the event loop
+ after 0 [list after idle $cmd]
+ }
+ }
+ }
+ }
+ if {[dict exists $reaction CLEANUP]} {
+ set cmd [dict get $reaction CLEANUP]
+ if {[llength $cmd]} {
+ # Enqueue the cleaner via the event loop passing the
+ # *state* as well as the value
+ if {$_state eq "REJECTED"} {
+ lappend cmd $_state $_value $_edict
+ } else {
+ lappend cmd $_state $_value
+ }
+ after 0 [list after idle $cmd]
+ # Note we do not set _do_gc if we only run cleaners
+ }
+ }
+ }
+ set _reactions [list ]
+
+ # Check for need to background error (see comments above)
+ if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} {
+ # TBD - should we also check _nrefs before backgrounding error?
+
+ # Wrap in catch in case $_edict does not follow error conventions
+ # or is not even a dictionary
+ if {[catch {
+ dict get $_edict -level
+ dict get $_edict -code
+ }]} {
+ catch {throw {PROMISE REJECT} $_value} - edict
+ } else {
+ set edict $_edict
+ }
+ # TBD - how exactly is level to be handled?
+ # If -level is not 0, bgerror barfs because it treates
+ # it as TCL_RETURN no matter was -code is
+ dict set edict -level 0
+ after idle [interp bgerror {}] [list $_value $edict]
+ set _bgerror_done 1
+ }
+
+ my GC
+ return
+ }
+
+ method RegisterReactions {args} {
+ # Registers the specified reactions.
+ # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED`
+ # with values being the corresponding reaction callback
+
+ lappend _reactions $args
+ my ScheduleReactions
+ return
+ }
+
+ method done {{on_fulfill {}} {on_reject {}}} {
+ # Registers reactions to be run when the promise is settled.
+ # on_fulfill - command prefix for the reaction to run
+ # if the promise is fulfilled.
+ # reaction is registered.
+ # on_reject - command prefix for the reaction to run
+ # if the promise is rejected.
+ # Reactions are called with an additional argument which is
+ # the value with which the promise was settled.
+ #
+ # The command may be called multiple times to register multiple
+ # reactions to be run at promise settlement. If the promise was
+ # already settled at the time the call was made, the reactions
+ # are invoked immediately. In all cases, reactions are not called
+ # directly, but are invoked by scheduling through the event loop.
+ #
+ # The method triggers garbage collection of the object if the
+ # promise has been settled and any registered reactions have been
+ # scheduled. Applications can hold on to the object through
+ # appropriate use of the [ref] and [unref] methods.
+ #
+ # Note that both $on_fulfill and $on_reject may be specified
+ # as empty strings if no further action needs to be taken on
+ # settlement of the promise. If the promise is rejected, and
+ # no rejection reactions are registered, the error is reported
+ # via the Tcl `interp bgerror` facility.
+
+ # TBD - as per the Promise/A+ spec, errors in done should generate
+ # a background error (unlike then).
+
+ my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject
+
+ #ruff
+ # The method does not return a value.
+ return
+ }
+
+ method then {on_fulfill {on_reject {}}} {
+ # Registers reactions to be run when the promise is settled
+ # and returns a new [Promise] object that will be settled by the
+ # reactions.
+ # on_fulfill - command prefix for the reaction to run
+ # if the promise is fulfilled. If an empty string, no fulfill
+ # reaction is registered.
+ # on_reject - command prefix for the reaction to run
+ # if the promise is rejected. If unspecified or an empty string,
+ # no reject reaction is registered.
+ # Both reactions are passed the value with which the promise was settled.
+ # The reject reaction is passed an additional argument which is
+ # the error dictionary.
+ #
+ # The command may be called multiple times to register multiple
+ # reactions to be run at promise settlement. If the promise was
+ # already settled at the time the call was made, the reactions
+ # are invoked immediately. In all cases, reactions are not called
+ # directly, but are invoked by scheduling through the event loop.
+ #
+ # If the reaction that is invoked runs without error, its return
+ # value fulfills the new promise returned by the `then` method.
+ # If it raises an exception, the new promise will be rejected
+ # with the error message and dictionary from the exception.
+ #
+ # Alternatively, the reactions can explicitly invoke commands
+ # [then_fulfill], [then_reject] or [then_chain] to
+ # resolve the returned promise. In this case, the return value
+ # (including exceptions) from the reactions are ignored.
+ #
+ # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified),
+ # the new promise is created and fulfilled (or rejected) with
+ # the same value that would have been passed in to the reactions.
+ #
+ # The method triggers garbage collection of the object if the
+ # promise has been settled and registered reactions have been
+ # scheduled. Applications can hold on to the object through
+ # appropriate use of the [ref] and [unref] methods.
+ #
+ # Returns a new promise that is settled by the registered reactions.
+
+ set then_promise [[self class] new ""]
+ my RegisterReactions \
+ FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \
+ REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject]
+ return $then_promise
+ }
+
+ # This could be a forward, but then we cannot document it via ruff!
+ method catch {on_reject} {
+ # Registers reactions to be run when the promise is rejected.
+ # on_reject - command prefix for the reaction
+ # reaction to run if the promise is rejected. If unspecified
+ # or an empty string, no reject reaction is registered. The
+ # reaction is called with an additional argument which is the
+ # value with which the promise was settled.
+ # This method is just a wrapper around [Promise.then] with the
+ # `on_fulfill` parameter defaulting to an empty string. See
+ # the description of that method for details.
+ return [my then "" $on_reject]
+ }
+
+ method cleanup {cleaner} {
+ # Registers a reaction to be executed for running cleanup
+ # code when the promise is settled.
+ # cleaner - command prefix to run on settlement
+ # This method is intended to run a clean up script
+ # when a promise is settled. Its primary use is to avoid duplication
+ # of code in the `then` and `catch` handlers for a promise.
+ # It may also be called multiple times
+ # to clean up intermediate steps when promises are chained.
+ #
+ # The method returns a new promise that will be settled
+ # as per the following rules.
+ # - if the cleaner runs without errors, the returned promise
+ # will reflect the settlement of the promise on which this
+ # method is called.
+ # - if the cleaner raises an exception, the returned promise
+ # is rejected with a value consisting of the error message
+ # and dictionary pair.
+ #
+ # Returns a new promise that is settled based on the cleaner
+ set cleaner_promise [[self class] new ""]
+ my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner]
+ return $cleaner_promise
+ }
+}
+
+proc promise::_then_reaction {target_promise status cmd value {edict {}}} {
+ # Run the specified command and fulfill/reject the target promise
+ # accordingly. If the command is empty, the passed-in value is passed
+ # on to the target promise.
+
+ # IMPORTANT!!!!
+ # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else
+ # promise::then_fulfill/then_reject/then_chain will not work
+ # Also, Do NOT change the param name target_promise without changing
+ # those procs.
+ # Oh what a hack to get around lack of closures. Alternative would have
+ # been to pass an additional parameter (target_promise)
+ # to the application code but then that script would have had to
+ # carry that around.
+
+ if {[info level] != 1} {
+ error "Internal error: _then_reaction not at level 1"
+ }
+
+ if {[llength $cmd] == 0} {
+ switch -exact -- $status {
+ FULFILLED { $target_promise fulfill $value }
+ REJECTED { $target_promise reject $value $edict}
+ CHAINED -
+ PENDING -
+ default {
+ $target_promise reject "Internal error: invalid status $state"
+ }
+ }
+ } else {
+ # Invoke the real reaction code and fulfill/reject the target promise.
+ # Note the reaction code may have called one of the promise::then_*
+ # commands itself and reactions run resulting in the object being
+ # freed. Hence resolve using the safe* variants
+ # TBD - ideally we would like to execute at global level. However
+ # the then_* commands retrieve target_promise from level 1 (here)
+ # which they cannot if uplevel #0 is done. So directly invoke.
+ if {$status eq "REJECTED"} {
+ lappend cmd $value $edict
+ } else {
+ lappend cmd $value
+ }
+ if {[catch $cmd reaction_value reaction_edict]} {
+ safe_reject $target_promise $reaction_value $reaction_edict
+ } else {
+ safe_fulfill $target_promise $reaction_value
+ }
+ }
+ return
+}
+
+proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} {
+ # Run the specified cleaner and fulfill/reject the target promise
+ # accordingly. If the cleaner executes without error, the original
+ # value and state is passed on. If the cleaner executes with error
+ # the promise is rejected.
+
+ if {[llength $cleaner] == 0} {
+ switch -exact -- $state {
+ FULFILLED { $target_promise fulfill $value }
+ REJECTED { $target_promise reject $value $edict }
+ CHAINED -
+ PENDING -
+ default {
+ $target_promise reject "Internal error: invalid state $state"
+ }
+ }
+ } else {
+ if {[catch {uplevel #0 $cleaner} err edict]} {
+ # Cleaner failed. Reject the target promise
+ $target_promise reject $err $edict
+ } else {
+ # Cleaner completed without errors, pass on the original value
+ if {$state eq "FULFILLED"} {
+ $target_promise fulfill $value
+ } else {
+ $target_promise reject $value $edict
+ }
+ }
+ }
+ return
+}
+
+proc promise::then_fulfill {value} {
+ # Fulfills the promise returned by a [Promise.then] method call from
+ # within its reaction.
+ # value - the value with which to fulfill the promise
+ #
+ # The [Promise.then] method is a mechanism to chain asynchronous
+ # reactions by registering them on a promise. It returns a new
+ # promise which is settled by the return value from the reaction,
+ # or by the reaction calling one of three commands - `then_fulfill`,
+ # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills
+ # the promise returned by the `then` method that queued the currently
+ # running reaction.
+ #
+ # It is an error to call this command from outside a reaction
+ # that was queued via the [Promise.then] method on a promise.
+
+ # TBD - what if someone calls this from within a uplevel #0 ? The
+ # upvar will be all wrong
+ upvar #1 target_promise target_promise
+ if {![info exists target_promise]} {
+ set msg "promise::then_fulfill called in invalid context."
+ throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg
+ }
+ $target_promise fulfill $value
+}
+
+proc promise::then_chain {promise} {
+ # Chains the promise returned by a [Promise.then] method call to
+ # another promise.
+ # promise - the promise to which the promise returned by [Promise.then] is
+ # to be chained
+ #
+ # The [Promise.then] method is a mechanism to chain asynchronous
+ # reactions by registering them on a promise. It returns a new
+ # promise which is settled by the return value from the reaction,
+ # or by the reaction calling one of three commands - [then_fulfill],
+ # `then_reject` or [then_chain]. Calling `then_chain` chains
+ # the promise returned by the `then` method that queued the currently
+ # running reaction to $promise so that the former will be settled
+ # based on the latter.
+ #
+ # It is an error to call this command from outside a reaction
+ # that was queued via the [Promise.then] method on a promise.
+ upvar #1 target_promise target_promise
+ if {![info exists target_promise]} {
+ set msg "promise::then_chain called in invalid context."
+ throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg
+ }
+ $target_promise chain $promise
+}
+
+proc promise::then_reject {reason edict} {
+ # Rejects the promise returned by a [Promise.then] method call from
+ # within its reaction.
+ # reason - a message string describing the reason for the rejection.
+ # edict - a Tcl error dictionary
+ # The [Promise.then] method is a mechanism to chain asynchronous
+ # reactions by registering them on a promise. It returns a new
+ # promise which is settled by the return value from the reaction,
+ # or by the reaction calling one of three commands - [then_fulfill],
+ # `then_reject` or [then_chain]. Calling `then_reject` rejects
+ # the promise returned by the `then` method that queued the currently
+ # running reaction.
+ #
+ # It is an error to call this command from outside a reaction
+ # that was queued via the [Promise.then] method on a promise.
+ upvar #1 target_promise target_promise
+ if {![info exists target_promise]} {
+ set msg "promise::then_reject called in invalid context."
+ throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg
+ }
+ $target_promise reject $reason $edict
+}
+
+proc promise::all {promises} {
+ # Returns a promise that fulfills or rejects when all promises
+ # in the $promises argument have fulfilled or any one has rejected.
+ # promises - a list of Promise objects
+ # If any of $promises rejects, then the promise returned by the
+ # command will reject with the same value. Otherwise, the promise
+ # will fulfill when all promises have fulfilled.
+ # The resolved value will be a list of the resolved
+ # values of the contained promises.
+
+ set all_promise [Promise new [lambda {promises prom} {
+ set npromises [llength $promises]
+ if {$npromises == 0} {
+ $prom fulfill {}
+ return
+ }
+
+ # Ask each promise to update us when resolved.
+ foreach promise $promises {
+ $promise done \
+ [list ::promise::_all_helper $prom $promise FULFILLED] \
+ [list ::promise::_all_helper $prom $promise REJECTED]
+ }
+
+ # We keep track of state with a dictionary that will be
+ # stored in $prom with the following keys:
+ # PROMISES - the list of promises in the order passed
+ # PENDING_COUNT - count of unresolved promises
+ # RESULTS - dictionary keyed by promise and containing resolved value
+ set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}]
+
+ $prom setdata ALLPROMISES $all_state
+ } $promises]]
+
+ return $all_promise
+}
+
+proc promise::all* args {
+ # Returns a promise that fulfills or rejects when all promises
+ # in the $args argument have fulfilled or any one has rejected.
+ # args - list of Promise objects
+ # This command is identical to the all command except that it takes
+ # multiple arguments, each of which is a Promise object. See [all]
+ # for a description.
+ return [all $args]
+}
+
+# Callback for promise::all.
+# all_promise - the "master" promise returned by the all call.
+# done_promise - the promise whose callback is being serviced.
+# resolution - whether the current promise was resolved with "FULFILLED"
+# or "REJECTED"
+# value - the value of the currently fulfilled promise or error description
+# in case rejected
+# edict - error dictionary (if promise was rejected)
+proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} {
+ if {![info object isa object $all_promise]} {
+ # The object has been deleted. Naught to do
+ return
+ }
+ if {[$all_promise state] ne "PENDING"} {
+ # Already settled. This can happen when a tracked promise is
+ # rejected and another tracked promise gets settled afterwards.
+ return
+ }
+ if {$resolution eq "REJECTED"} {
+ # This promise failed. Immediately reject the master promise
+ # TBD - can we somehow indicate which promise failed ?
+ $all_promise reject $value $edict
+ return
+ }
+
+ # Update the state of the resolved tracked promise
+ set all_state [$all_promise getdata ALLPROMISES]
+ dict set all_state RESULTS $done_promise $value
+ dict incr all_state PENDING_COUNT -1
+ $all_promise setdata ALLPROMISES $all_state
+
+ # If all promises resolved, resolve the all promise
+ if {[dict get $all_state PENDING_COUNT] == 0} {
+ set values {}
+ foreach prom [dict get $all_state PROMISES] {
+ lappend values [dict get $all_state RESULTS $prom]
+ }
+ $all_promise fulfill $values
+ }
+ return
+}
+
+proc promise::race {promises} {
+ # Returns a promise that fulfills or rejects when any promise
+ # in the $promises argument is fulfilled or rejected.
+ # promises - a list of Promise objects
+ # The returned promise will fulfill and reject with the same value
+ # as the first promise in $promises that fulfills or rejects.
+ set race_promise [Promise new [lambda {promises prom} {
+ if {[llength $promises] == 0} {
+ catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict
+ $prom reject $reason $edict
+ return
+ }
+ # Use safe_*, do not directly call methods since $prom may be
+ # gc'ed once settled
+ foreach promise $promises {
+ $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom]
+ }
+ } $promises]]
+
+ return $race_promise
+}
+
+proc promise::race* {args} {
+ # Returns a promise that fulfills or rejects when any promise
+ # in the passed arguments is fulfilled or rejected.
+ # args - list of Promise objects
+ # This command is identical to the `race` command except that it takes
+ # multiple arguments, each of which is a Promise object. See [race]
+ # for a description.
+ return [race $args]
+}
+
+proc promise::await {prom} {
+ # Waits for a promise to be settled and returns its resolved value.
+ # prom - the promise that is to be waited on
+ # This command may only be used from within a procedure constructed
+ # with the [async] command or any code invoked from it.
+ #
+ # Returns the resolved value of $prom if it is fulfilled or raises an error
+ # if it is rejected.
+ set coro [info coroutine]
+ if {$coro eq ""} {
+ throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine"
+ }
+ $prom done [list $coro success] [list $coro fail]
+ lassign [yieldto return -level 0] status val ropts
+ if {$status eq "success"} {
+ return $val
+ } else {
+ return -options $ropts $val
+ }
+}
+
+proc promise::async {name paramdefs body} {
+ # Defines an procedure that will run a script asynchronously as a coroutine.
+ # name - name of the procedure
+ # paramdefs - the parameter definitions to the procedure in the same
+ # form as passed to the standard `proc` command
+ # body - the script to be executed
+ #
+ # When the defined procedure $name is called, it runs the supplied $body
+ # within a new coroutine. The return value from the $name procedure call
+ # will be a promise that will be fulfilled when the coroutine completes
+ # normally or rejected if it completes with an error.
+ #
+ # Note that the passed $body argument is not the body of the
+ # the procedure $name. Rather it is run as an anonymous procedure in
+ # the coroutine but in the same namespace context as $name. Thus the
+ # caller or the $body script must not make any assumptions about
+ # relative stack levels, use of `uplevel` etc.
+ #
+ # The primary purpose of this command is to make it easy, in
+ # conjunction with the [await] command, to wrap a sequence of asynchronous
+ # operations as a single computational unit.
+ #
+ # Returns a promise that will be settled with the result of the script.
+ if {![string equal -length 2 "$name" "::"]} {
+ set ns [uplevel 1 namespace current]
+ set name ${ns}::$name
+ } else {
+ set ns ::
+ }
+ set tmpl {
+ proc %NAME% {%PARAMDEFS%} {
+ set p [promise::Promise new [promise::lambda {real_args prom} {
+ coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} {
+ upvar #1 _current_async_promise current_p
+ set current_p $p
+ set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts]
+ if {$status == 0} {
+ $p fulfill $res
+ } else {
+ $p reject $res $ropts
+ }
+ } $prom {*}$real_args]
+ } [lrange [info level 0] 1 end]]]
+ return $p
+ }
+ }
+ eval [string map [list %NAME% $name \
+ %PARAMDEFS% $paramdefs \
+ %BODY% $body \
+ %NS% $ns] $tmpl]
+}
+
+proc promise::async_fulfill {val} {
+ # Fulfills a promise for an async procedure with the specified value.
+ # val - the value with which to fulfill the promise
+ # This command must only be called with the context of an [async]
+ # procedure.
+ #
+ # Returns an empty string.
+ upvar #1 _current_async_promise current_p
+ if {![info exists current_p]} {
+ error "async_fulfill called from outside an async context."
+ }
+ $current_p fulfill $val
+ return
+}
+
+proc promise::async_reject {val {edict {}}} {
+ # Rejects a promise for an async procedure with the specified value.
+ # val - the value with which to reject the promise
+ # edict - error dictionary for rejection
+ # This command must only be called with the context of an [async]
+ # procedure.
+ #
+ # Returns an empty string.
+ upvar #1 _current_async_promise current_p
+ if {![info exists current_p]} {
+ error "async_reject called from outside an async context."
+ }
+ $current_p reject $val $edict
+ return
+}
+
+proc promise::async_chain {prom} {
+ # Chains a promise for an async procedure to the specified promise.
+ # prom - the promise to which the async promise is to be linked.
+ # This command must only be called with the context of an [async]
+ # procedure.
+ #
+ # Returns an empty string.
+ upvar #1 _current_async_promise current_p
+ if {![info exists current_p]} {
+ error "async_chain called from outside an async context."
+ }
+ $current_p chain $prom
+ return
+}
+
+proc promise::pfulfilled {value} {
+ # Returns a new promise that is already fulfilled with the specified value.
+ # value - the value with which to fulfill the created promise
+ return [Promise new [lambda {value prom} {
+ $prom fulfill $value
+ } $value]]
+}
+
+proc promise::prejected {value {edict {}}} {
+ # Returns a new promise that is already rejected.
+ # value - the value with which to reject the promise
+ # edict - error dictionary for rejection
+ # By convention, $value should be of the format returned by
+ # [Promise.reject].
+ return [Promise new [lambda {value edict prom} {
+ $prom reject $value $edict
+ } $value $edict]]
+}
+
+proc promise::eventloop {prom} {
+ # Waits in the eventloop until the specified promise is settled.
+ # prom - the promise to be waited on
+ # The command enters the event loop in similar fashion to the
+ # Tcl `vwait` command except that instead of waiting on a variable
+ # the command waits for the specified promise to be settled. As such
+ # it has the same caveats as the vwait command in terms of care
+ # being taken in nested calls etc.
+ #
+ # The primary use of the command is at the top level of a script
+ # to wait for one or more promise based tasks to be completed. Again,
+ # similar to the vwait forever idiom.
+ #
+ #
+ # Returns the resolved value of $prom if it is fulfilled or raises an error
+ # if it is rejected.
+
+ set varname [namespace current]::_pwait_[info cmdcount]
+ $prom done \
+ [lambda {varname result} {
+ set $varname [list success $result]
+ } $varname] \
+ [lambda {varname error ropts} {
+ set $varname [list fail $error $ropts]
+ } $varname]
+ vwait $varname
+ lassign [set $varname] status result ropts
+ if {$status eq "success"} {
+ return $result
+ } else {
+ return -options $ropts $result
+ }
+}
+
+proc promise::pgeturl {url args} {
+ # Returns a promise that will be fulfilled when the URL is fetched.
+ # url - the URL to fetch
+ # args - arguments to pass to the `http::geturl` command
+ # This command invokes the asynchronous form of the `http::geturl` command
+ # of the `http` package. If the operation completes with a status of
+ # `ok`, the returned promise is fulfilled with the contents of the
+ # http state array (see the documentation of `http::geturl`). If the
+ # the status is anything else, the promise is rejected with
+ # the `reason` parameter to the reaction containing the error message
+ # and the `edict` parameter containing the Tcl error dictionary
+ # with an additional key `http_state`, containing the
+ # contents of the http state array.
+
+ uplevel #0 {package require http}
+ proc pgeturl {url args} {
+ set prom [Promise new [lambda {http_args prom} {
+ http::geturl {*}$http_args -command [promise::lambda {prom tok} {
+ upvar #0 $tok http_state
+ if {$http_state(status) eq "ok"} {
+ $prom fulfill [array get http_state]
+ } else {
+ if {[info exists http_state(error)]} {
+ set msg [lindex $http_state(error) 0]
+ }
+ if {![info exists msg] || $msg eq ""} {
+ set msg "Error retrieving URL."
+ }
+ catch {throw {PROMISE PGETURL} $msg} msg edict
+ dict set edict http_state [array get http_state]
+ $prom reject $msg $edict
+ }
+ http::cleanup $tok
+ } $prom]
+ } [linsert $args 0 $url]]]
+ return $prom
+ }
+ tailcall pgeturl $url {*}$args
+}
+
+proc promise::ptimer {millisecs {value "Timer expired."}} {
+ # Returns a promise that will be fulfilled when the specified time has
+ # elapsed.
+ # millisecs - time interval in milliseconds
+ # value - the value with which the promise is to be fulfilled
+ # In case of errors (e.g. if $milliseconds is not an integer), the
+ # promise is rejected with the `reason` parameter set to an error
+ # message and the `edict` parameter set to a Tcl error dictionary.
+ #
+ # Also see [ptimeout] which is similar but rejects the promise instead
+ # of fulfilling it.
+
+ return [Promise new [lambda {millisecs value prom} {
+ if {![string is integer -strict $millisecs]} {
+ # We don't allow "idle", "cancel" etc. as an argument to after
+ throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"."
+ }
+ after $millisecs [list promise::safe_fulfill $prom $value]
+ } $millisecs $value]]
+}
+
+proc promise::ptimeout {millisecs {value "Operation timed out."}} {
+ # Returns a promise that will be rejected when the specified time has
+ # elapsed.
+ # millisecs - time interval in milliseconds
+ # value - the value with which the promise is to be rejected
+ # In case of errors (e.g. if $milliseconds is not an integer), the
+ # promise is rejected with the `reason` parameter set to $value
+ # and the `edict` parameter set to a Tcl error dictionary.
+ #
+ # Also see [ptimer] which is similar but fulfills the promise instead
+ # of rejecting it.
+
+ return [Promise new [lambda {millisecs value prom} {
+ if {![string is integer -strict $millisecs]} {
+ # We don't want to accept "idle", "cancel" etc. for after
+ throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"."
+ }
+ after $millisecs [::promise::lambda {prom msg} {
+ catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict
+ ::promise::safe_reject $prom $msg $edict
+ } $prom $value]
+ } $millisecs $value]]
+}
+
+proc promise::pconnect {args} {
+ # Returns a promise that will be fulfilled when the socket connection
+ # is completed.
+ # args - arguments to be passed to the Tcl `socket` command
+ # This is a wrapper for the async version of the Tcl `socket` command.
+ # If the connection completes, the promise is fulfilled with the
+ # socket handle.
+ # In case of errors (e.g. if the address cannot be fulfilled), the
+ # promise is rejected with the `reason` parameter containing the
+ # error message and the `edict` parameter containing the Tcl error
+ # dictionary.
+ #
+ return [Promise new [lambda {so_args prom} {
+ set so [socket -async {*}$so_args]
+ fileevent $so writable [promise::lambda {prom so} {
+ fileevent $so writable {}
+ set err [chan configure $so -error]
+ if {$err eq ""} {
+ $prom fulfill $so
+ } else {
+ catch {throw {PROMISE PCONNECT FAIL} $err} err edict
+ $prom reject $err $edict
+ }
+ } $prom $so]
+ } $args]]
+}
+
+proc promise::_read_channel {prom chan data} {
+ set newdata [read $chan]
+ if {[string length $newdata] || ![eof $chan]} {
+ append data $newdata
+ fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data]
+ return
+ }
+
+ # EOF
+ set code [catch {
+ # Need to make the channel blocking else no error is returned
+ # on the close
+ fileevent $chan readable {}
+ fconfigure $chan -blocking 1
+ close $chan
+ } result edict]
+ if {$code} {
+ safe_reject $prom $result $edict
+ } else {
+ safe_fulfill $prom $data
+ }
+}
+
+proc promise::pexec {args} {
+ # Runs an external program and returns a promise for its output.
+ # args - program and its arguments as passed to the Tcl `open` call
+ # for creating pipes
+ # If the program runs without errors, the promise is fulfilled by its
+ # standard output content. Otherwise
+ # promise is rejected.
+ #
+ # Returns a promise that will be settled by the result of the program
+ return [Promise new [lambda {open_args prom} {
+ set chan [open |$open_args r]
+ fconfigure $chan -blocking 0
+ fileevent $chan readable [list promise::_read_channel $prom $chan ""]
+ } $args]]
+}
+
+proc promise::safe_fulfill {prom value} {
+ # Fulfills the specified promise.
+ # prom - the [Promise] object to be fulfilled
+ # value - the fulfillment value
+ # This is a convenience command that checks if $prom still exists
+ # and if so fulfills it with $value.
+ #
+ # Returns 0 if the promise does not exist any more, else the return
+ # value from its [fulfill][Promise.fulfill] method.
+ if {![info object isa object $prom]} {
+ # The object has been deleted. Naught to do
+ return 0
+ }
+ return [$prom fulfill $value]
+}
+
+proc promise::safe_reject {prom value {edict {}}} {
+ # Rejects the specified promise.
+ # prom - the [Promise] object to be fulfilled
+ # value - see [Promise.reject]
+ # edict - see [Promise.reject]
+ # This is a convenience command that checks if $prom still exists
+ # and if so rejects it with the specified arguments.
+ #
+ # Returns 0 if the promise does not exist any more, else the return
+ # value from its [reject][Promise.reject] method.
+ if {![info object isa object $prom]} {
+ # The object has been deleted. Naught to do
+ return
+ }
+ $prom reject $value $edict
+}
+
+proc promise::ptask {script} {
+ # Creates a new Tcl thread to run the specified script and returns
+ # a promise for the script results.
+ # script - script to run in the thread
+ # Returns a promise that will be settled by the result of the script
+ #
+ # The `ptask` command runs the specified script in a new Tcl
+ # thread. The promise returned from this command will be fulfilled
+ # with the result of the script if it completes
+ # successfully. Otherwise, the promise will be rejected with an
+ # with the `reason` parameter containing the error message
+ # and the `edict` parameter containing the Tcl error dictionary
+ # from the script failure.
+ #
+ # Note that $script is a standalone script in that it is executed
+ # in a new thread with a virgin Tcl interpreter. Any packages used
+ # by $script have to be explicitly loaded, variables defined in the
+ # the current interpreter will not be available in $script and so on.
+ #
+ # The command requires the Thread package to be loaded.
+
+ uplevel #0 package require Thread
+ proc [namespace current]::ptask script {
+ return [Promise new [lambda {script prom} {
+ set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] {
+ set retcode [catch {%SCRIPT%} result edict]
+ if {$retcode == 0 || $retcode == 2} {
+ # ok or return
+ set response [list ::promise::safe_fulfill %PROM% $result]
+ } else {
+ set response [list ::promise::safe_reject %PROM% $result $edict]
+ }
+ thread::send -async %TID% $response
+ }]
+ thread::create $thread_script
+ } $script]]
+ }
+ tailcall [namespace current]::ptask $script
+}
+
+proc promise::pworker {tpool script} {
+ # Runs a script in a worker thread from a thread pool and
+ # returns a promise for the same.
+ # tpool - thread pool identifier
+ # script - script to run in the worker thread
+ # Returns a promise that will be settled by the result of the script
+ #
+ # The Thread package allows creation of a thread pool with the
+ # `tpool create` command. The `pworker` command runs the specified
+ # script in a worker thread from a thread pool. The promise
+ # returned from this command will be fulfilled with the result of
+ # the script if it completes successfully.
+ # Otherwise, the promise will be rejected with an
+ # with the `reason` parameter containing the error message
+ # and the `edict` parameter containing the Tcl error dictionary
+ # from the script failure.
+ #
+ # Note that $script is a standalone script in that it is executed
+ # in a new thread with a virgin Tcl interpreter. Any packages used
+ # by $script have to be explicitly loaded, variables defined in the
+ # the current interpreter will not be available in $script and so on.
+
+ # No need for package require Thread since if tpool is passed to
+ # us, Thread must already be loaded
+ return [Promise new [lambda {tpool script prom} {
+ set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] {
+ set retcode [catch {%SCRIPT%} result edict]
+ if {$retcode == 0 || $retcode == 2} {
+ set response [list ::promise::safe_fulfill %PROM% $result]
+ } else {
+ set response [list ::promise::safe_reject %PROM% $result $edict]
+ }
+ thread::send -async %TID% $response
+ }]
+ tpool::post -detached -nowait $tpool $thread_script
+ } $tpool $script]]
+}
+
+if {0} {
+ package require http
+ proc checkurl {url} {
+ set prom [promise::Promise new [promise::lambda {url prom} {
+ http::geturl $url -method HEAD -command [promise::lambda {prom tok} {
+ upvar #0 $tok http_state
+ $prom fulfill [list $http_state(url) $http_state(status)]
+ ::http::cleanup $tok
+ } $prom]
+ } $url]]
+ return $prom
+ }
+
+ proc checkurls {urls} {
+ return [promise::all [lmap url $urls {checkurl $url}]]
+ }
+
+ [promise::all [
+ list [
+ promise::ptask {expr 1+1}
+ ] [
+ promise::ptask {expr 2+2}
+ ]
+ ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}]
+}
+
+package provide promise [promise::version]
+
+if {[info exists ::argv0] &&
+ [file tail [info script]] eq [file tail $::argv0]} {
+ set filename [file tail [info script]]
+ if {[llength $::argv] == 0} {
+ puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version"
+ exit 1
+ }
+ switch -glob -- [lindex $::argv 0] {
+ ver* { puts [promise::version] }
+ tm -
+ dist* {
+ if {[file extension $filename] ne ".tm"} {
+ set dir [file join [file dirname [info script]] .. build]
+ file mkdir $dir
+ file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm]
+ } else {
+ error "Cannot create distribution from a .tm file"
+ }
+ }
+ install {
+ # Install in first native file system that exists on search path
+ foreach path [tcl::tm::path list] {
+ if {[lindex [file system $path] 0] eq "native"} {
+ set dir $path
+ if {[file isdirectory $path]} {
+ break
+ }
+ # Else keep looking
+ }
+ }
+ if {![file exists $dir]} {
+ file mkdir $dir
+ }
+ if {[file extension $filename] eq ".tm"} {
+ # We already are a .tm with version number
+ set target $filename
+ } else {
+ set target [file rootname $filename]-[promise::version].tm
+ }
+ file copy -force [info script] [file join $dir $target]
+ }
+ default {
+ puts stderr "Unknown option/command \"[lindex $::argv 0]\""
+ exit 1
+ }
+ }
+}
diff --git a/src/bootsupport/modules_tcl8/punk-0.1.tm b/src/bootsupport/modules_tcl8/punk-0.1.tm
new file mode 100644
index 00000000..4bc2c7ce
--- /dev/null
+++ b/src/bootsupport/modules_tcl8/punk-0.1.tm
@@ -0,0 +1,8381 @@
+#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk.
+#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into.
+
+
+namespace eval punk {
+ proc lazyload {pkg} {
+ package require zzzload
+ if {[package provide $pkg] eq ""} {
+ zzzload::pkg_require $pkg
+ }
+ }
+ #lazyload twapi ?
+
+ catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later
+
+ variable can_exec_windowsapp
+ set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed
+ variable windowsappdir
+ set windowsappdir ""
+ variable cmdexedir
+ set cmdexedir ""
+
+ proc sync_package_paths_script {} {
+ #the tcl::tm namespace doesn't exist until one of the tcl::tm commands
+ #is run. (they are loaded via ::auto_index triggering load of tm.tcl)
+ #we call tcl::tm::list to trigger the initial set of tm paths before
+ #we can override it, otherwise our changes will be lost
+ #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc
+ return "\
+ apply {{ap tmlist} {
+ set ::auto_path \$ap
+ tcl::tm::list
+ set ::tcl::tm::paths \$tmlist
+ }} {$::auto_path} {[tcl::tm::list]}
+ "
+ }
+
+ proc rehash {{refresh 0}} {
+ global auto_execs
+ if {!$refresh} {
+ unset -nocomplain auto_execs
+ } else {
+ set names [array names auto_execs]
+ unset -nocomplain auto_execs
+ foreach nm $names {
+ auto_execok_windows $nm
+ }
+ }
+ return
+ }
+
+
+ proc ::punk::auto_execok_original name [info body ::auto_execok]
+ variable better_autoexec
+
+ #set better_autoexec 0 ;#use this var via better_autoexec only
+ #proc ::punk::auto_execok_windows name {
+ # ::punk::auto_execok_original $name
+ #}
+
+ set better_autoexec 1
+ proc ::punk::auto_execok_windows name {
+ ::punk::auto_execok_better $name
+ }
+
+ set has_commandstack [expr {![catch {package require commandstack}]}]
+ if {$has_commandstack} {
+ if {[catch {
+ package require punk::packagepreference
+ } errM]} {
+ catch {puts stderr "Failed to load punk::packagepreference"}
+ }
+ catch punk::packagepreference::install
+ } else {
+ #
+ }
+
+ if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} {
+
+ #still a caching version of auto_execok - but with proper(fixed) search order
+
+ #set b [info body ::auto_execok]
+ #proc ::auto_execok_original name $b
+
+ proc better_autoexec {{onoff ""}} {
+ variable better_autoexec
+ if {$onoff eq ""} {
+ return $better_autoexec
+ }
+ if {![string is boolean -strict $onoff]} {
+ error "better_autoexec argument 'onoff' must be a boolean, received: $onoff"
+ }
+ if {$onoff && ($onoff != $better_autoexec)} {
+ puts "Turning on better_autoexec - search PATH first then extension"
+ set better_autoexec 1
+ proc ::punk::auto_execok_windows name {
+ ::punk::auto_execok_better $name
+ }
+ punk::rehash
+ } elseif {!$onoff && ($onoff != $better_autoexec)} {
+ puts "Turning off better_autoexec - search extension then PATH"
+ set better_autoexec 0
+ proc ::punk::auto_execok_windows name {
+ ::punk::auto_execok_original $name
+ }
+ punk::rehash
+ } else {
+ puts "no change"
+ }
+ }
+ #better_autoexec $better_autoexec ;#init to default
+
+
+ proc auto_execok_better name {
+ global auto_execs env tcl_platform
+
+ if {[info exists auto_execs($name)]} {
+ return $auto_execs($name)
+ }
+ #puts stdout "[a+ red]...[a]"
+ set auto_execs($name) ""
+
+ set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \
+ md mkdir mklink move rd ren rename rmdir start time type ver vol]
+ if {[info exists env(PATHEXT)]} {
+ # Add an initial ; to have the {} extension check first.
+ set execExtensions [split ";$env(PATHEXT)" ";"]
+ } else {
+ set execExtensions [list {} .com .exe .bat .cmd]
+ }
+
+ if {[string tolower $name] in $shellBuiltins} {
+ # When this is command.com for some reason on Win2K, Tcl won't
+ # exec it unless the case is right, which this corrects. COMSPEC
+ # may not point to a real file, so do the check.
+ set cmd $env(COMSPEC)
+ if {[file exists $cmd]} {
+ set cmd [file attributes $cmd -shortname]
+ }
+ return [set auto_execs($name) [list $cmd /c $name]]
+ }
+
+ if {[llength [file split $name]] != 1} {
+ #has a path
+ foreach ext $execExtensions {
+ set file ${name}${ext}
+ if {[file exists $file] && ![file isdirectory $file]} {
+ return [set auto_execs($name) [list $file]]
+ }
+ }
+ return ""
+ }
+
+ #change1
+ #set path "[file dirname [info nameofexecutable]];.;"
+ set path "[file dirname [info nameofexecutable]];"
+
+ if {[info exists env(SystemRoot)]} {
+ set windir $env(SystemRoot)
+ } elseif {[info exists env(WINDIR)]} {
+ set windir $env(WINDIR)
+ }
+ if {[info exists windir]} {
+ append path "$windir/system32;$windir/system;$windir;"
+ }
+
+ foreach var {PATH Path path} {
+ if {[info exists env($var)]} {
+ append path ";$env($var)"
+ }
+ }
+
+ #change2
+ if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} {
+ set lookfor [list $name]
+ } else {
+ set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}]
+ }
+ #puts "-->$lookfor"
+ foreach dir [split $path {;}] {
+ set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe"
+ #set dir [file normalize $dir]
+ # Skip already checked directories
+ if {[info exists checked($dir)] || ($dir eq "")} {
+ continue
+ }
+ set checked($dir) {}
+
+ #surprisingly fast
+ #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor]
+ ##puts "--dir $dir matches:$matches"
+ #if {[llength $matches]} {
+ # set file [file join $dir [lindex $matches 0]]
+ # #puts "--match0:[lindex $matches 0] file:$file"
+ # return [set auto_execs($name) [list $file]]
+ #}
+
+ #what if it's a link?
+ #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] {
+ # set file [file join $dir $match]
+ # if {[file exists $file]} {
+ # return [set auto_execs($name) [list $file]]
+ # }
+ #}
+
+ #safest? could be a link?
+ foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] {
+ set file [file join $dir $match]
+ if {[file exists $file] && ![file isdirectory $file]} {
+ return [set auto_execs($name) [list $file]]
+ }
+ }
+ }
+
+ #foreach ext $execExtensions {
+ #unset -nocomplain checked
+ #foreach dir [split $path {;}] {
+ # # Skip already checked directories
+ # if {[info exists checked($dir)] || ($dir eq "")} {
+ # continue
+ # }
+ # set checked($dir) {}
+ # set file [file join $dir ${name}${ext}]
+ # if {[file exists $file] && ![file isdirectory $file]} {
+ # return [set auto_execs($name) [list $file]]
+ # }
+ #}
+ #}
+ return ""
+ }
+
+
+
+ #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe?
+ #what if we create another interp and use the same ::auto_execs? The appdir won't be detected.
+ #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed
+
+
+
+ #winget is installed on all modern windows (but not on windows sandbox!) and is an example of the problem this addresses
+ #we target apps with same location
+
+ #the main purpose of this override is to support windows app executables (installed as 'reparse points')
+ #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac
+ #versions prior to this will use cmd.exe to resolve the links
+ set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name {
+ #set windowsappdir "%appdir%"
+ upvar ::punk::can_exec_windowsapp can_exec_windowsapp
+ upvar ::punk::windowsappdir windowsappdir
+ upvar ::punk::cmdexedir cmdexedir
+
+ if {$windowsappdir eq ""} {
+ #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points'
+ #Tcl (2025) can't exec when given a path to these 0KB files
+ #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps
+ if {!([info exists ::env(LOCALAPPDATA)] &&
+ [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} {
+ #should be unlikely to get here - unless LOCALAPPDATA missing (or winget.exe missing e.g windows sandbox)
+ set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]]
+ catch {puts stderr "(resolved winget by search)"}
+ } else {
+ set windowsappdir [file dirname $testapp]
+ }
+ }
+
+ #set default_auto [$COMMANDSTACKNEXT $name]
+ set default_auto [::punk::auto_execok_windows $name]
+ #if {$name ni {cmd cmd.exe}} {
+ # unset -nocomplain ::auto_execs
+ #}
+
+ if {$default_auto eq ""} {
+ return
+ }
+ set namedir [file dirname [lindex $default_auto 0]]
+
+ if {$namedir eq $windowsappdir} {
+ if {$can_exec_windowsapp eq "unknown"} {
+ if {[catch {exec [file join $windowsappdir winget.exe] --version}]} {
+ set can_exec_windowsapp 0
+ } else {
+ set can_exec_windowsapp 1
+ }
+ }
+ if {$can_exec_windowsapp} {
+ return [file join $windowsappdir $name]
+ }
+ if {$cmdexedir eq ""} {
+ #cmd.exe very unlikely to move
+ set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]]
+ #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index
+ #anyway.. it has other side effects (affects auto_load)
+ }
+ return "[file join $cmdexedir cmd.exe] /c $name"
+ }
+ return $default_auto
+ }]
+
+
+ }
+
+}
+
+
+
+#repltelemetry cooperation with other packages such as shellrun
+#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists
+namespace eval punk {
+ variable repltelemetry_emmitters
+ #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early
+ if {![info exists repltelemetry_emitters]} {
+ set repltelemetry_emmitters [list]
+ }
+}
+
+namespace eval punk::pipecmds {
+ #where to install proc/compilation artifacts for pieplines
+ namespace export *
+}
+namespace eval punk::pipecmds::split_patterns {}
+namespace eval punk::pipecmds::split_rhs {}
+namespace eval punk::pipecmds::var_classify {}
+namespace eval punk::pipecmds::destructure {}
+namespace eval punk::pipecmds::insertion {}
+
+
+#globals... some minimal global var pollution
+#punk's official silly test dictionary
+set punk_testd [dict create \
+ a0 a0val \
+ b0 [dict create \
+ a1 b0a1val \
+ b1 b0b1val \
+ c1 b0c1val \
+ d1 b0d1val \
+ ] \
+ c0 [dict create] \
+ d0 [dict create \
+ a1 [dict create \
+ a2 d0a1a2val \
+ b2 d0a1b2val \
+ c2 d0a1c2val \
+ ] \
+ b1 [dict create \
+ a2 [dict create \
+ a3 d0b1a2a3val \
+ b3 d0b1a2b3val \
+ ] \
+ b2 [dict create \
+ a3 d0b1b2a3val \
+ bananas "in pyjamas" \
+ c3 [dict create \
+ po "in { }" \
+ b4 ""\
+ c4 "can go boom" \
+ ] \
+ d3 [dict create \
+ a4 "-paper -cuts" \
+ ] \
+ e3 [dict create] \
+ ] \
+ ] \
+ ] \
+ e0 "multi\nline"\
+ ]
+#test dict 2 - uniform structure and some keys with common prefixes for glob matching
+set punk_testd2 [dict create \
+ a0 [dict create \
+ b1 {a b c}\
+ b2 {a b c d}\
+ x1 {x y z 1 2}\
+ y2 {X Y Z 1 2}\
+ z1 {k1 v1 k2 v2 k3 v3}\
+ ] \
+ a1 [dict create \
+ b1 {a b c}\
+ b2 {a b c d}\
+ x1 {x y z 1 2}\
+ y2 {X Y Z 1 2}\
+ z1 {k1 v1 k2 v2 k3 v3}\
+ ] \
+ b1 [dict create \
+ b1 {a b c}\
+ b2 {a b c d}\
+ x1 {x y z 1 2}\
+ y2 {X Y Z 1 2}\
+ z1 {k1 v1 k2 v2 k3 v3}\
+ ] \
+]
+
+#impolitely cooperative with punk repl - todo - tone it down.
+#namespace eval ::punk::repl::codethread {
+# variable running 0
+#}
+package require punk::lib ;# subdependency punk::args
+package require punk::ansi
+if {![llength [info commands ::ansistring]]} {
+ namespace import punk::ansi::ansistring
+}
+#require aliascore after punk::lib & punk::ansi are loaded
+package require punk::aliascore ;#mostly punk::lib aliases
+punk::aliascore::init -force 1
+
+package require punk::repl::codethread
+package require punk::config
+#package require textblock
+package require punk::console ;#requires Thread
+package require punk::ns
+package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
+package require punk::repo
+package require punk::du
+package require punk::mix::base
+package require base64
+
+package require punk::pipe
+
+namespace eval punk {
+ # -- --- ---
+ #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace
+ # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results.
+ #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work.
+ #package require control
+ #control::control assert enabled 1
+
+ #We will use punk::assertion instead
+
+ package require punk::assertion
+ if {[catch {namespace import ::punk::assertion::assert} errM]} {
+ catch {
+ puts stderr "punk error importing punk::assertion::assert\n$errM"
+ puts stderr "punk::a* commands:[info commands ::punk::a*]"
+ }
+ }
+ punk::assertion::active on
+ # -- --- ---
+
+ interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system
+ if {[catch {
+ package require pattern
+ } errpkg]} {
+ catch {puts stderr "Failed to load package pattern error: $errpkg"}
+ }
+ package require shellfilter
+ package require punkapp
+ package require funcl
+
+ package require struct::list
+ package require fileutil
+ #package require punk::lib
+
+ #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition)
+ #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't)
+ package require debug
+
+ debug define punk.unknown
+ debug define punk.pipe
+ debug define punk.pipe.var
+ debug define punk.pipe.args
+ debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation
+ debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc
+
+
+ #-----------------------------------
+ # todo - load initial debug state from config
+ debug off punk.unknown
+ debug level punk.unknown 1
+ debug off punk.pipe
+ debug level punk.pipe 4
+ debug off punk.pipe.var
+ debug level punk.pipe.var 4
+ debug off punk.pipe.args
+ debug level punk.pipe.args 3
+ debug off punk.pipe.rep 2
+ debug off punk.pipe.compile
+ debug level punk.pipe.compile 2
+
+
+ debug header "dbg> "
+
+
+ variable last_run_display [list]
+
+
+ #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$}
+
+
+
+ #-----------------------------------------------------------------------------------
+ #strlen is important for testing issues with string representationa and shimmering.
+ #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed
+ #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour
+ proc strlen {str} {
+ append str2 $str {}
+ string length $str2
+ }
+ #-----------------------------------------------------------------------------------
+
+ #get a copy of the item without affecting internal rep
+ proc objclone {obj} {
+ append obj2 $obj {}
+ }
+ proc set_clone {varname obj} {
+ #maintenance: also punk::lib::set_clone
+ #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val]
+ append obj2 $obj {}
+ uplevel 1 [list set $varname $obj2]
+ }
+
+ interp alias "" strlen "" ::punk::strlen
+ interp alias "" str_len "" ::punk::strlen
+ interp alias "" objclone "" ::punk::objclone
+ #proc ::strlen {str} {
+ # string length [append str2 $str {}]
+ #}
+ #proc ::objclone {obj} {
+ # append obj2 $obj {}
+ #}
+
+ #-----------------------------------------------------------------------------------
+ #order of arguments designed for pipelining
+ #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining
+ #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone.
+ proc piper_append {new base} {
+ append base $new
+ }
+ interp alias "" piper_append "" ::punk::piper_append
+ proc piper_prepend {new base} {
+ append new $base
+ }
+ interp alias "" piper_prepend "" ::punk::piper_prepend
+
+ proc ::punk::K {x y} { return $x}
+
+ #todo ansigrep? e.g grep using ansistripped value
+ proc grepstr1 {pattern data} {
+ set data [string map {\r\n \n} $data]
+ set lines [split $data \n]
+ set matches [lsearch -all -regexp $lines $pattern]
+ set max [lindex $matches end]
+ set w1 [string length $max]
+ set result ""
+ set H [a+ green bold overline]
+ set R \x1b\[m
+ foreach m $matches {
+ set ln [lindex $lines $m]
+ set ln [regsub -all $pattern $ln $H&$R]
+ append result [format %${w1}s $m] " $ln" \n
+ }
+ set result [string trimright $result \n]
+ return $result
+ }
+
+ #----------------------
+ #todo - fix overtype
+ #create test
+ #overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]"
+ #----------------------
+
+
+ punk::args::define {
+ @id -id ::punk::grepstr
+ @cmd -name punk::grepstr\
+ -summary\
+ "Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\
+ -help\
+ "The grepstr command can find strings in ANSI text even if there are interspersed
+ ANSI colour codes etc. Even if a word has different coloured/styled letters, the
+ regex can match the plaintext. (Search is performed on ansistripped text, and then
+ the matched sections are highlighted and overlayed on the original styled/colourd
+ input.
+ If the input string has ANSI movement codes - the resultant text may not be directly
+ searchable because the parts of a word may be separated by various codes and other
+ plain text. To search such an input string, the string should first be 'rendered' to
+ a form where the ANSI only represents SGR styling (and perhaps other non-movement
+ codes) using something like overtype::renderline or overtype::rendertext."
+
+ @leaders -min 0 -max 0
+ @opts
+ -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
+ "matched"\
+ " Return only lines that matched."
+ "breaksandmatches"\
+ " Return configured --break= lines in between non-consecutive matches"
+ "all"\
+ " Return all lines.
+ This has a similar effect to the 'grep' trick of matching on 'pattern|$'
+ (The $ matches all lines that have an end; ie all lines, but there is no
+ associated character to which to apply highlighting)
+ except that when instead using -returnlines all with --line-number, the *
+ indicator after the linenumber will only be highlighted for lines with matches,
+ and the following matchcount will indicate zero for non-matching lines."
+ }
+ -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
+ -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
+ "Print num lines of leading and trailing context surrounding each match."
+ -A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num
+ --break= -type string -default "-- %c%\U2260" -help\
+ "When returning matched lines and there is a break in consecutive output,
+ display the break with the given string. %c% is a placeholder for the
+ number of lines skipped.
+ Use empty-string for an empty line as a break display.
+ grepstr --break= needle $haystacklines
+
+ The unix grep utility commonly uses -- for this indicator.
+ grepstr --break=-- needle $haystacklines
+
+ Customisation example:
+ grepstr -n \"--break=(skipped %c% lines)\" needle $haystacklines
+ "
+ -ansistrip -type none -help\
+ "Strip all ansi codes from the input string before processing.
+ This is not necessary for regex matching purposes, as the matching is always
+ performed on the ansistripped characters anyway, but by stripping ANSI, the
+ result only has the ANSI supplied by the -highlight option."
+
+ #-n|--line-number as per grep utility, except that we include a * for matches
+ -n|--line-number -type none -help\
+ "Each output line is preceded by its relative line number in the file, starting at line 1.
+ For lines that matched the regex, the line number will be suffixed with a * indicator
+ with the same highlighting as the matched string(s).
+ The number of matches in the line immediately follows the *
+ For lines with no matches the * indicator is present with no highlighting and suffixed
+ with zeros."
+ -i|--ignore-case -type none -help\
+ "Perform case insensitive matching."
+ -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\
+ "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?"
+ -- -type none
+ @values
+ pattern -type string -help\
+ "regex pattern to match in plaintext portion of ANSI string"
+ string -type string
+ }
+ proc grepstr {args} {
+ lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received
+ set pattern [dict get $values pattern]
+ set data [dict get $values string]
+ set do_strip 0
+ if {[dict exists $received -ansistrip]} {
+ set data [punk::ansi::ansistrip $data]
+ }
+ set highlight [dict get $opts -highlight]
+ set opt_returnlines [dict get $opts -returnlines]
+ set context [dict get $opts --context] ;#int
+ set beforecontext [dict get $opts --before-context]
+ set beforecontext [expr {max($beforecontext,$context)}]
+ set aftercontext [dict get $opts --after-context]
+ set aftercontext [expr {max($aftercontext,$context)}]
+ set break [dict get $opts --break]
+ set ignorecase [dict exists $received --ignore-case]
+ if {$ignorecase} {
+ set nocase "-nocase"
+ } else {
+ set nocase ""
+ }
+
+
+ if {[dict exists $received --line-number]} {
+ set do_linenums 1 ;#display lineindex+1
+ } else {
+ set do_linenums 0
+ }
+
+ if {[llength $highlight] == 0} {
+ set H ""
+ set R ""
+ } else {
+ set H [a+ {*}$highlight]
+ set R \x1b\[m
+ }
+
+ set data [string map {\r\n \n} $data]
+ if {![punk::ansi::ta::detect $data]} {
+ set lines [split $data \n]
+ set matches [lsearch -all {*}$nocase -regexp $lines $pattern]
+ set result ""
+ if {$opt_returnlines eq "all"} {
+ set returnlines [punk::lib::range 0 [llength $lines]-1]
+ } else {
+ #matches|breaksandmatches
+ set returnlines $matches
+ }
+ set max [lindex $returnlines end]
+ if {[string is integer -strict $max]} {
+ incr max
+ }
+ set w1 [string length $max]
+ #lineindex is zero based - display of linenums is 1 based
+ set resultlines [dict create]
+ foreach lineindex $returnlines {
+ set ln [lindex $lines $lineindex]
+ set col1 ""
+ if {$do_linenums} {
+ set col1 [format "%${w1}s " [expr {$lineindex+1}]]
+ }
+ if {$lineindex in $matches} {
+ set ln [regsub -all {*}$nocase -- $pattern $ln $H&$R] ;#n
+ set matchcount [regexp -all {*}$nocase -- $pattern $ln]
+ if {$do_linenums} {
+ append col1 $H*$R[format %03s $matchcount]
+ }
+ } else {
+ if {$do_linenums} {
+ append col1 "*000"
+ }
+ }
+ #---------------------------------------------------------------
+ set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1]
+ set s [expr {$lineindex-$beforecontext-1}]
+ if {$s < -1} {set s -1}
+ foreach p $prelines {
+ incr s
+ #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n
+ if {![dict exists $resultlines $s]} {
+ if {$do_linenums} {
+ set show "[format "%${w1}s " [expr {$s+1}]]- $p"
+ } else {
+ set show $p
+ }
+ dict set resultlines $s $show
+ }
+ }
+ #---------------------------------------------------------------
+ if {$do_linenums} {
+ set show "$col1 $ln"
+ } else {
+ set show $ln
+ }
+ dict set resultlines $lineindex $show
+ #---------------------------------------------------------------
+ set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext]
+ set s $lineindex
+ foreach p $postlines {
+ incr s
+ if {![dict exists $resultlines $s]} {
+ if {$do_linenums} {
+ set show "[format "%${w1}s " [expr {$s+1}]]- $p"
+ } else {
+ set show $p
+ }
+ dict set resultlines $s $show
+ }
+ }
+ #---------------------------------------------------------------
+
+ }
+ } else {
+ set plain [punk::ansi::ansistrip $data]
+ set plainlines [split $plain \n]
+ set lines [split $data \n]
+ set matches [lsearch -all {*}$nocase -regexp $plainlines $pattern]
+ if {$opt_returnlines eq "all"} {
+ set returnlines [punk::lib::range 0 [llength $lines]-1]
+ } else {
+ set returnlines $matches
+ }
+ set max [lindex $returnlines end]
+ if {[string is integer -strict $max]} {
+ #if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary.
+ incr max
+ }
+ set w1 [string length $max]
+ set result ""
+ set placeholder \UFFEF ;#review
+ set resultlines [dict create]
+ foreach lineindex $returnlines {
+ set ln [lindex $lines $lineindex]
+ set col1 ""
+ if {$do_linenums} {
+ set col1 [format "%${w1}s " [expr {$lineindex+1}]]
+ }
+ if {$lineindex in $matches} {
+ set plain_ln [lindex $plainlines $lineindex]
+ set parts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln]
+ set matchcount [llength $parts]
+ if {$do_linenums} {
+ append col1 $H*$R[format %03s $matchcount]
+ }
+ if {[llength $parts] == 0} {
+ #This probably can't happen (?)
+ #If it does.. it's more likely to be an issue with our line index than with regexp
+ puts stderr "Unexpected regex mismatch in grepstr - line marked with ??? (shouldn't happen)"
+ set matchshow "??? $ln"
+ #dict set resultlines $lineindex $show
+ } else {
+ set overlay ""
+ set i 0
+ foreach prange $parts {
+ lassign $prange s e
+ set prelen [expr {$s - $i}]
+ append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R
+ set i [expr {$e + 1}]
+ }
+ set tail [string range $plain_ln $e+1 end]
+ append overlay [string repeat $placeholder [string length $tail]]
+ #puts "$overlay"
+ #puts "$ln"
+ set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay]
+ if {$do_linenums} {
+ set matchshow "$col1 $rendered"
+ } else {
+ set matchshow $rendered
+ }
+ }
+ #---------------------------------------------------------------
+ set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1]
+ set s [expr {$lineindex-$beforecontext-1}]
+ if {$s < -1} {set s -1}
+ foreach p $prelines {
+ incr s
+ #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n
+ if {![dict exists $resultlines $s]} {
+ if {$do_linenums} {
+ set show "[format "%${w1}s " [expr {$s+1}]]- $p"
+ } else {
+ set show $p
+ }
+ dict set resultlines $s $show
+ }
+ }
+ #---------------------------------------------------------------
+ dict set resultlines $lineindex $matchshow
+ #---------------------------------------------------------------
+ set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext]
+ set s $lineindex
+ foreach p $postlines {
+ incr s
+ if {![dict exists $resultlines $s]} {
+ if {$do_linenums} {
+ set show "[format "%${w1}s " [expr {$s+1}]]- $p"
+ } else {
+ set show $p
+ }
+ dict set resultlines $s $show
+ }
+ }
+ #---------------------------------------------------------------
+ } else {
+ if {$do_linenums} {
+ append col1 "*000"
+ set show "$col1 $ln"
+ } else {
+ set show $ln
+ }
+ dict set resultlines $lineindex $show
+ }
+ }
+ }
+ set ordered_resultlines [lsort -integer [dict keys $resultlines]]
+ set result ""
+ set i -1
+ set do_break 0
+ if {$opt_returnlines eq "breaksandmatches"} {
+ set do_break 1
+ }
+ if {$do_break} {
+ foreach r $ordered_resultlines {
+ incr i
+ if {$r > $i} {
+ set c [expr {$r - $i}]
+ append result [string map [list %c% $c] $break] \n
+ }
+ append result [dict get $resultlines $r] \n
+ set i $r
+ }
+ if {$i<[llength $lines]-1} {
+ set c [expr {[llength $lines]-1-$i}]
+ append result [string map [list %c% $c] $break] \n
+ }
+ } else {
+ foreach r $ordered_resultlines {
+ append result [dict get $resultlines $r] \n
+ }
+ }
+ set result [string trimright $result \n]
+ return $result
+ }
+
+ proc stacktrace {} {
+ set stack "Stack trace:\n"
+ for {set i 1} {$i < [info level]} {incr i} {
+ set lvl [info level -$i]
+ set pname [lindex $lvl 0]
+ append stack [string repeat " " $i]$pname
+
+ if {![catch {info args $pname} pargs]} {
+ foreach value [lrange $lvl 1 end] arg $pargs {
+
+ if {$value eq ""} {
+ if {$arg != 0} {
+ info default $pname $arg value
+ }
+ }
+ append stack " $arg='$value'"
+ }
+ } else {
+ append stack " !unknown vars for $pname"
+ }
+
+ append stack \n
+ }
+ return $stack
+ }
+
+ #review - there are various type of uuid - we should use something consistent across platforms
+ #twapi is used on windows because it's about 5 times faster - but is this more important than consistency?
+ #twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway
+ #(counterpoint: in the case of punk - we currently need twapi anyway on windows)
+ #does tcllib's uuid use the same mechanisms on different platforms anyway?
+ proc ::punk::uuid {} {
+ set has_twapi 0
+ if 0 {
+ if {"windows" eq $::tcl_platform(platform)} {
+ if {![catch {
+ set loader [zzzload::pkg_wait twapi]
+ } errM]} {
+ if {$loader in [list failed loading]} {
+ catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"}
+ }
+ } else {
+ package require twapi
+ }
+ if {[package provide twapi] ne ""} {
+ set has_twapi 1
+ }
+ }
+ }
+ if {!$has_twapi} {
+ if {[catch {package require uuid} errM]} {
+ error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows"
+ }
+ return [uuid::uuid generate]
+ } else {
+ return [twapi::new_uuid]
+ }
+ }
+
+ #get last command result that was run through the repl
+ proc ::punk::get_runchunk {args} {
+ set argd [punk::args::parse $args withdef {
+ @id -id ::punk::get_runchunk
+ @cmd -name "punk::get_runchunk" -help\
+ "experimental"
+ @opts
+ -1 -optional 1 -type none
+ -2 -optional 1 -type none
+ @values -min 0 -max 0
+ }]
+ #todo - make this command run without truncating previous runchunks
+ set runchunks [tsv::array names repl runchunks-*]
+
+ set sortlist [list]
+ foreach cname $runchunks {
+ set num [lindex [split $cname -] 1]
+ lappend sortlist [list $num $cname]
+ }
+ set sorted [lsort -index 0 -integer $sortlist]
+ set chunkname [lindex $sorted end-1 1]
+ set runlist [tsv::get repl $chunkname]
+ #puts stderr "--$runlist"
+ if {![llength $runlist]} {
+ return ""
+ } else {
+ return [lindex [lsearch -inline -index 0 $runlist result] 1]
+ }
+ }
+ interp alias {} _ {} ::punk::get_runchunk
+
+
+ proc ::punk::var {varname {= _=.=_} args} {
+ upvar $varname the_var
+ switch -exact -- ${=} {
+ = {
+ if {[llength $args] > 1} {
+ set the_var $args
+ } else {
+ set the_var [lindex $args 0]
+ }
+ }
+ .= {
+ if {[llength $args] > 1} {
+ set the_var [uplevel 1 $args]
+ } else {
+ set the_var [uplevel 1 [lindex $args 0]]
+ }
+ }
+ _=.=_ {
+ set the_var
+ }
+ default {
+ set the_var [list ${=} {*}$args]
+ }
+ }
+ }
+ proc src {args} {
+ #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args
+ #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename
+ # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here.
+ set cmdargs [list]
+ set scriptargs [list]
+ set inopts 0
+ set i 0
+ foreach a $args {
+ if {$i eq [llength $args]-1} {
+ #reached end without finding end of opts
+ #must be file - even if it does match -* ?
+ break
+ }
+ if {!$inopts} {
+ if {[string match -* $a]} {
+ set inopts 1
+ } else {
+ #leave loop at first nonoption - i should be index of file
+ break
+ }
+ } else {
+ #leave for next iteration to check
+ set inopts 0
+ }
+ incr i
+ }
+ set cmdargs [lrange $args 0 $i]
+ set scriptargs [lrange $args $i+1 end]
+ set argv $::argv
+ set argc $::argc
+ set ::argv $scriptargs
+ set ::argc [llength $scriptargs]
+ set code [catch {uplevel [list source {*}$cmdargs]} return]
+ set ::argv $argv
+ set ::argc $argc
+ return -code $code $return
+ }
+
+
+
+
+ proc varinfo {vname {flag ""}} {
+ upvar $vname v
+ if {[array exists $vname]} {
+ error "can't read \"$vname\": variable is array"
+ }
+ if {[catch {set v} err]} {
+ error "can't read \"$vname\": no such variable"
+ }
+ set inf [shellfilter::list_element_info [list $v]]
+ set inf [dict get $inf 0]
+ if {$flag eq "-v"} {
+ return $inf
+ }
+
+ set output [dict create]
+ dict set output wouldbrace [dict get $inf wouldbrace]
+ dict set output wouldescape [dict get $inf wouldescape]
+ dict set output head_tail_names [dict get $inf head_tail_names]
+ dict set output len [dict get $inf len]
+ return $output
+ }
+
+ #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline.
+ #e.g contrived pipeline example to only allow setting existing keys
+ ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} -1} {
+ #lassign [punk::lib::string_splitbefore $token $first_term] v k
+ set v [string range $token 0 $first_term-1]
+ set k [string range $token $first_term end] ;#key section includes the terminal char
+ lappend varlist [list $v $k]
+ } else {
+ lappend varlist [list $token ""]
+ }
+ set token ""
+ set token_index -1 ;#reduce by 1 because , not included in next token
+ set first_term -1
+ } else {
+ if {$first_term == -1} {
+ if {$c in $var_terminals} {
+ set first_term $token_index
+ }
+ }
+ append token $c
+ if {$c eq "("} {
+ set in_brackets 1
+ }
+ }
+ }
+ incr token_index
+ }
+ if {[string length $token]} {
+ if {$first_term > -1} {
+ set v [string range $token 0 $first_term-1]
+ set k [string range $token $first_term end] ;#key section includes the terminal char
+ lappend varlist [list $v $k]
+ } else {
+ lappend varlist [list $token ""]
+ }
+ }
+ return $varlist
+ }
+
+ proc fp_restructure {selector data} {
+ if {$selector eq ""} {
+ fun=.= {val $input} and always break
+ set lhs ""
+ set rhs ""
+ #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info?
+ foreach index $subindices {
+ set subpath [join [lrange $subindices 0 $i_keyindex] /]
+ set lhs $subpath
+ set assigned ""
+ set get_not 0
+ set already_assigned 0
+ set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning.
+ #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values.
+ #todo - see if 'string is list' improved in tcl9 vs catch {llength $list}
+ switch -exact -- $index {
+ # {
+ set active_key_type "list"
+ if {![catch {llength $leveldata} assigned]} {
+ set already_assigned 1
+ } else {
+ set action ?mismatch-not-a-list
+ break
+ }
+ }
+ ## {
+ set active_key_type "dict"
+ if {![catch {dict size $leveldata} assigned]} {
+ set already_assigned 1
+ } else {
+ set action ?mismatch-not-a-dict
+ break
+ }
+ }
+ #? {
+ #review - compare to %# ?????
+ #seems to be unimplemented ?
+ set assigned [string length $leveldata]
+ set already_assigned 1
+ }
+ @ {
+ upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position
+ set active_key_type "list"
+ #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey
+ #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3
+ #while x@,y@.= is reasonably handy - especially for args e.g $len} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ set assigned [lindex $leveldata $index]
+ set already_assigned 1
+ }
+ @@ - @?@ - @??@ {
+ set active_key_type "dict"
+
+ #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc
+ #x@@ = a {x y}
+ #x@@/@0 = a
+ #x@@/@1 = x y
+ #x@@/a = a {x y}
+ # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group.
+ # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index)
+ # It is analogous to v1@,v2@ for lists.
+ # @pairs is more useful for repeated operations
+
+ #
+ #set subpath [join [lrange $subindices 0 $i_keyindex] /]
+ if {[catch {dict size $leveldata} dsize]} {
+ set action ?mismatch-not-a-dict
+ break
+ }
+ set next_this_level [incr v_dict_idx($subpath)]
+ set keyindex [expr {$next_this_level -1}]
+ if {($keyindex + 1) <= $dsize} {
+ set k [lindex [dict keys $leveldata] $keyindex]
+ if {$index eq "@?@"} {
+ set assigned [dict get $leveldata $k]
+ } else {
+ set assigned [list $k [dict get $leveldata $k]]
+ }
+ } else {
+ if {$index eq "@@"} {
+ set action ?mismatch-dict-index-out-of-range
+ break
+ } else {
+ set assigned [list]
+ }
+ }
+ set already_assigned 1
+ }
+ default {
+ switch -glob -- $index {
+ @@* {
+ set active_key_type "dict"
+ set key [string range $index 2 end]
+ #dict exists test is safe - no need for catch
+ if {[dict exists $leveldata $key]} {
+ set assigned [dict get $leveldata $key]
+ } else {
+ set action ?mismatch-dict-key-not-found
+ break
+ }
+ set already_assigned 1
+ }
+ {@\?@*} {
+ set active_key_type "dict"
+ set key [string range $index 3 end]
+ #dict exists test is safe - no need for catch
+ if {[dict exists $leveldata $key]} {
+ set assigned [dict get $leveldata $key]
+ } else {
+ set assigned [list]
+ }
+ set already_assigned 1
+ }
+ {@\?\?@*} {
+ set active_key_type "dict"
+ set key [string range $index 4 end]
+ #dict exists test is safe - no need for catch
+ if {[dict exists $leveldata $key]} {
+ set assigned [list $key [dict get $leveldata $key]]
+ } else {
+ set assigned [list]
+ }
+ set already_assigned 1
+ }
+ @* {
+ set active_key_type "list"
+ set do_bounds_check 1
+ set index [string trimleft $index @]
+ }
+ default {
+ #
+ }
+ }
+
+ if {!$already_assigned} {
+ if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} {
+ #e.g not-0-end-1 not-end-4-end-2
+ set get_not 1
+ #cherry-pick some easy cases, and either assign, or re-map to corresponding index
+ switch -- $index {
+ not-tail {
+ set active_key_type "list"
+ set assigned [lindex $leveldata 0]; set already_assigned 1
+ }
+ not-head {
+ set active_key_type "list"
+ #set selector "tail"; set get_not 0
+ set assigned [lrange $leveldata 1 end]; set already_assigned 1
+ }
+ not-end {
+ set active_key_type "list"
+ set assigned [lrange $leveldata 0 end-1]; set already_assigned 1
+ }
+ default {
+ #trim off the not- and let the remaining index handle based on get_not being 1
+ set index [string range $index 4 end]
+ }
+ }
+ }
+ }
+ }
+ }
+
+ if {!$already_assigned} {
+
+ #keyword 'pipesyntax' at beginning of error message
+ set listmsg "pipesyntax Unable to interpret subindex $index\n"
+ append listmsg "selector: '$selector'\n"
+ append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n"
+ append listmsg "Additional accepted keywords include: head tail\n"
+ append listmsg "Use var@@key to treat value as a dict and retrieve element at key"
+
+
+ #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against
+ #need to set a corresponding action
+ if {$active_key_type in [list "" "list"]} {
+ set active_key_type "list"
+ #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir)
+ if {$index eq "0"} {
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ set assigned [lindex $leveldata 0]
+ } elseif {$index eq "head"} {
+ #NOTE: /@head and /head both do bounds check. This is intentional
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ if {$len == 0} {
+ set action ?mismatch-list-index-out-of-range-empty
+ break
+ }
+ #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax
+ set assigned [lindex $leveldata 0]
+ } elseif {$index eq "end"} {
+ # @end /end
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ if {$do_bounds_check && $len < 1} {
+ set action ?mismatch-list-index-out-of-range
+ }
+ set assigned [lindex $leveldata end]
+ } elseif {$index eq "tail"} {
+ #NOTE: /@tail and /tail both do bounds check. This is intentional.
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list
+ #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems.
+ #In this way tail is different to @1-end
+ if {$len == 0} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero.
+ } elseif {$index eq "anyhead"} {
+ # @anyhead
+ #allow returning of head or nothing if empty list
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ set assigned [lindex $leveldata 0]
+ } elseif {$index eq "anytail"} {
+ # @anytail
+ #allow returning of tail or nothing if empty list
+ #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead.
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ set assigned [lrange $leveldata 1 end]
+ } elseif {$index eq "init"} {
+ # @init
+ #all but last element - same as haskell 'init'
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ set assigned [lrange $leveldata 0 end-1]
+ } elseif {$index eq "list"} {
+ # @list
+ #allow returning of entire list even if empty
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ set assigned $leveldata
+ } elseif {$index eq "raw"} {
+ #no list checking..
+ set assigned $leveldata
+ } elseif {$index eq "keys"} {
+ #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements
+ if {[catch {dict size $leveldata} dsize]} {
+ set action ?mismatch-not-a-dict
+ break
+ }
+ set assigned [dict keys $leveldata]
+ } elseif {$index eq "values"} {
+ #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements
+ if {[catch {dict size $leveldata} dsize]} {
+ set action ?mismatch-not-a-dict
+ break
+ }
+ set assigned [dict values $leveldata]
+ } elseif {$index eq "pairs"} {
+ if {[catch {dict size $leveldata} dsize]} {
+ set action ?mismatch-not-a-dict
+ break
+ }
+ #set assigned [dict values $leveldata]
+ set pairs [list]
+ tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]}
+ set assigned [lindex [list $pairs [unset pairs]] 0]
+ } elseif {[string is integer -strict $index]} {
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ # only check if @ was directly in original index section
+ if {$do_bounds_check && ($index+1 > $len || $index < 0)} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ if {$get_not} {
+ #already handled not-0
+ set assigned [lreplace $leveldata $index $index]
+ } else {
+ set assigned [lindex $leveldata $index]
+ }
+ } elseif {[string first "end" $index] >=0} {
+ if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} {
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ #leave the - from the end- as part of the offset
+ set offset [expr $endspec] ;#don't brace! (consider: set x --34;puts expr $j;puts expr {$j} )
+ if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ if {$get_not} {
+ set assigned [lreplace $leveldata $index $index]
+ } else {
+ set assigned [lindex $leveldata $index]
+ }
+ } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} {
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ if {$do_bounds_check && [string is integer -strict $start]} {
+ if {$start+1 > $len || $start < 0} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ } elseif {$start eq "end"} {
+ #ok
+ } elseif {$do_bounds_check} {
+ set startoffset [string range $start 3 end] ;#include the - from end-
+ set startoffset [expr $startoffset] ;#don't brace!
+ if {$startoffset > 0 || abs($startoffset) >= $len} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ }
+ if {$do_bounds_check && [string is integer -strict $end]} {
+ if {$end+1 > $len || $end < 0} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ } elseif {$end eq "end"} {
+ #ok
+ } elseif {$do_bounds_check} {
+ set endoffset [string range $end 3 end] ;#include the - from end-
+ set endoffset [expr $endoffset] ;#don't brace!
+ if {$endoffset > 0 || abs($endoffset) >= $len} {
+ set action ?mismatch-list-index-out-of-range
+ break
+ }
+ }
+ if {$get_not} {
+ set assigned [lreplace $leveldata $start $end]
+ } else {
+ set assigned [lrange $leveldata $start $end]
+ }
+ } else {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ } elseif {[string first - $index] > 0} {
+ puts "====> index:$index leveldata:$leveldata"
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ #handle pure int-int ranges separately
+ set testindex [string map [list - "" + ""] $index]
+ if {[string is digit -strict $testindex]} {
+ #don't worry about leading - negative value for indices not valid anyway
+ set parts [split $index -]
+ if {[llength $parts] != 2} {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ lassign $parts start end
+ if {$start+1 > $len || $end+1 > $len} {
+ set action ?mismatch-not-a-list
+ break
+ }
+ if {$get_not} {
+ set assigned [lreplace $leveldata $start $end]
+ } else {
+ set assigned [lrange $leveldata $start $end]
+ }
+ } else {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+
+ } else {
+ #keyword 'pipesyntax' at beginning of error message
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ } else {
+ #treat as dict key
+ set active_key_type "dict"
+ if {[dict exists $leveldata $index]} {
+ set assigned [dict get $leveldata $index]
+ } else {
+ set action ?mismatch-dict-key-not-found
+ break
+ }
+
+ }
+ }
+ set leveldata $assigned
+ set rhs $leveldata
+ #don't break on empty data - operations such as # and ## can return 0
+ #if {![llength $leveldata]} {
+ # break
+ #}
+ incr i_keyindex
+ }
+ #puts stdout "----> destructure rep leveldata: [rep $leveldata]"
+ #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]"
+
+ #maintain key order - caller unpacks using lassign
+ return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]
+
+ }
+ #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script
+ proc destructure_func {selector data} {
+ #puts stderr ".d."
+ set selector [string trim $selector /]
+ #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position
+ #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position
+
+ #map some problematic things out of the way in a manner that maintains some transparency
+ #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]}
+ #The selector forms part of the proc name
+ #review - compare with pipecmd_namemapping
+ set selector_safe [string map [list\
+ ? \
+ * \
+ \\ \
+ {"} \
+ {$} \
+ "\x1b\[" \
+ "\x1b\]" \
+ {[} \
+ {]} \
+ :: \
+ {;} \
+ " " \
+ \t \
+ \n \
+ \r \
+ ] $selector]
+
+ set cmdname ::punk::pipecmds::destructure::_$selector_safe
+ if {[info commands $cmdname] ne ""} {
+ return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context
+ }
+
+ set leveldata $data
+ set body [destructure_func_build_procbody $cmdname $selector $data]
+
+ puts stdout ----
+ puts stderr "proc $cmdname {leveldata} {"
+ puts stderr $body
+ puts stderr "}"
+ puts stdout ---
+ proc $cmdname {leveldata} $body
+ #eval $script ;#create the proc
+ debug.punk.pipe.compile {proc $cmdname} 4
+ #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]
+ #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context
+ return [$cmdname $data]
+ }
+
+ #Builds a *basic* function to do the destructuring.
+ #This is simply a set of steps to destructure each level of the data based on the hierarchical selector.
+ #It just uses intermediate variables and adds some comments to the code to show the indices used at each point.
+ #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script.
+ proc destructure_func_build_procbody {cmdname selector data} {
+ set script ""
+ #place selector in comment in script only - if there is an error in selector we pick it up when building the script.
+ #The script itself should only be returning errors in its action key of the result dictionary
+ append script \n [string map [list $selector] {# set selector {}}]
+ set subindices [split $selector /]
+ append script \n [string map [list [list $subindices]] {# set subindices }]
+ set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break
+ append script \n {set action ?match}
+ #append script \n {set assigned ""} ;#review
+ set active_key_type ""
+ append script \n {# set active_key_type ""}
+ set lhs ""
+ #append script \n [tstr {set lhs ${{$lhs}}}]
+ append script \n {set lhs ""}
+ set rhs ""
+ append script \n {set rhs ""}
+
+ set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope
+
+ #maintain key order - caller unpacks using lassign
+ set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs}
+ set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]}
+ set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ #dict 'index' when using stateful @@ etc to iterate over dict instead of by key
+ set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+ set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]}
+
+
+ if {![string length $selector]} {
+ #just return $leveldata
+ set script {
+ dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata
+ }
+ return $script
+ }
+
+ if {[string is digit -strict [join $subindices ""]]} {
+ #review tip 551 (tcl9+?)
+ #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices"
+ #pure numeric keylist - put straight to lindex
+ #
+ #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @
+ #We will leave this as a syntax for different (more performant) behaviour
+ #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching.
+ #TODO - review and/or document
+ #
+ #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too.
+ #(or more generally - loop until we hit another type of subindex)
+
+ #set assigned [lindex $leveldata {*}$subindices]
+ if {[llength $subindices] == 1} {
+ append script \n "# index_operation listindex" \n
+ lappend INDEX_OPERATIONS listindex
+ } else {
+ append script \n "# index_operation listindex-nested" \n
+ lappend INDEX_OPERATIONS listindex-nested
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {lindex $leveldata ${$subindices}} leveldata]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ }
+ }]
+ # -- --- ---
+ #append script \n $returnline \n
+ append script [tstr -return string $return_template]
+ return $script
+ # -- --- ---
+ }
+ if {[string match @@* $selector]} {
+ #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc
+ set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@'
+ set keypath [string range $selector 2 end]
+ set keylist [split $keypath /]
+ lappend INDEX_OPERATIONS dict_path
+ if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} {
+ #pure keylist for dict - process in one go
+ #dict exists will return 0 if not a valid dict.
+ # is equivalent to {*}keylist when substituted
+ append script \n [tstr -return string -allowcommands {
+ if {[dict exists $leveldata ${$keylist}]} {
+ set leveldata [dict get $leveldata ${$keylist}]
+ } else {
+ #set action ?mismatch-dict-key-not-found
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+ append script [tstr -return string $return_template]
+ return $script
+ # -- --- ---
+ }
+ #else
+ #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access)
+ #process level by level
+ }
+
+
+
+ set i_keyindex 0
+ append script \n {set i_keyindex 0}
+ #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info?
+ foreach index $subindices {
+ #set index_operation "unspecified"
+ set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script
+ set SUBPATH [join [lrange $subindices 0 $i_keyindex] /]
+ append script \n "# ------- START index:$index subpath:$SUBPATH ------"
+ set lhs $index
+ append script \n "set lhs {$index}"
+
+ set assigned ""
+ append script \n {set assigned ""}
+
+ #got_not shouldn't need to be in script
+ set get_not 0
+ if {[tcl::string::index $index 0] eq "!"} {
+ append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key}
+ set index [tcl::string::range $index 1 end]
+ set get_not 1
+ }
+
+ # do_bounds_check shouldn't need to be in script
+ set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning.
+ #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values.
+ #append script \n {set do_boundscheck 0}
+ switch -exact -- $index {
+ # - @# {
+ #list length
+ set active_key_type "list"
+ if {$get_not} {
+ lappend INDEX_OPERATIONS not-list
+ append script \n {# set active_key_type "list" index_operation: not-list}
+ append script \n {
+ if {[catch {llength $leveldata}]} {
+ #not a list - not-length is true
+ set assigned 1
+ } else {
+ #is a list - not-length is false
+ set assigned 0
+ }
+ }
+ } else {
+ lappend INDEX_OPERATIONS list-length
+ append script \n {# set active_key_type "list" index_operation: list-length}
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} assigned]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ ## {
+ #dict size
+ set active_key_type "dict"
+ if {$get_not} {
+ lappend INDEX_OPERATIONS not-dict
+ append script \n {# set active_key_type "dict" index_operation: not-dict}
+ append script \n {
+ if {[catch {dict size $leveldata}]} {
+ set assigned 1 ;#not a dict - not-size is true
+ } else {
+ set assigned 0 ;#is a dict - not-size is false
+ }
+ }
+ } else {
+ lappend INDEX_OPERATIONS dict-size
+ append script \n {# set active_key_type "dict" index_operation: dict-size}
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} assigned]} {
+ #set action ?mismatch-not-a-dict
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ %# {
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%# not string length is not supported"
+ }
+ #string length - REVIEW -
+ lappend INDEX_OPERATIONS string-length
+ append script \n {# set active_key_type "" index_operation: string-length}
+ append script \n {set assigned [string length $leveldata]}
+ set level_script_complete 1
+ }
+ %%# {
+ #experimental
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%%# not string length is not supported"
+ }
+ #string length - REVIEW -
+ lappend INDEX_OPERATIONS ansistring-length
+ append script \n {# set active_key_type "" index_operation: ansistring-length}
+ append script \n {set assigned [ansistring length $leveldata]}
+ set level_script_complete 1
+ }
+ %str {
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%str - not string-get is not supported"
+ }
+ lappend INDEX_OPERATIONS string-get
+ append script \n {# set active_key_type "" index_operation: string-get}
+ append script \n {set assigned $leveldata}
+ set level_script_complete 1
+ }
+ %sp {
+ #experimental
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%sp - not string-space is not supported"
+ }
+ lappend INDEX_OPERATIONS string-space
+ append script \n {# set active_key_type "" index_operation: string-space}
+ append script \n {set assigned " "}
+ set level_script_complete 1
+ }
+ %empty {
+ #experimental
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%empty - not string-empty is not supported"
+ }
+ lappend INDEX_OPERATIONS string-empty
+ append script \n {# set active_key_type "" index_operation: string-empty}
+ append script \n {set assigned ""}
+ set level_script_complete 1
+ }
+ @words {
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%words - not list-words-from-string is not supported"
+ }
+ lappend INDEX_OPERATIONS list-words-from-string
+ append script \n {# set active_key_type "" index_operation: list-words-from-string}
+ append script \n {set assigned [regexp -inline -all {\S+} $leveldata]}
+ set level_script_complete 1
+ }
+ @chars {
+ #experimental - leading character based on result not input(?)
+ #input type is string - but output is list
+ set active_key_type "list"
+ if {$get_not} {
+ error "!%chars - not list-chars-from-string is not supported"
+ }
+ lappend INDEX_OPERATIONS list-from_chars
+ append script \n {# set active_key_type "" index_operation: list-chars-from-string}
+ append script \n {set assigned [split $leveldata ""]}
+ set level_script_complete 1
+ }
+ @join {
+ #experimental - flatten one level of list
+ #join without arg - output is list
+ set active_key_type "string"
+ if {$get_not} {
+ error "!@join - not list-join-list is not supported"
+ }
+ lappend INDEX_OPERATIONS list-join-list
+ append script \n {# set active_key_type "" index_operation: list-join-list}
+ append script \n {set assigned [join $leveldata]}
+ set level_script_complete 1
+ }
+ %join {
+ #experimental
+ #input type is list - but output is string
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%join - not string-join-list is not supported"
+ }
+ lappend INDEX_OPERATIONS string-join-list
+ append script \n {# set active_key_type "" index_operation: string-join-list}
+ append script \n {set assigned [join $leveldata ""]}
+ set level_script_complete 1
+ }
+ %ansiview {
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%# not string-ansiview is not supported"
+ }
+ lappend INDEX_OPERATIONS string-ansiview
+ append script \n {# set active_key_type "" index_operation: string-ansiview}
+ append script \n {set assigned [ansistring VIEW $leveldata]}
+ set level_script_complete 1
+ }
+ %ansiviewstyle {
+ set active_key_type "string"
+ if {$get_not} {
+ error "!%# not string-ansiviewstyle is not supported"
+ }
+ lappend INDEX_OPERATIONS string-ansiviewstyle
+ append script \n {# set active_key_type "" index_operation: string-ansiviewstyle}
+ append script \n {set assigned [ansistring VIEWSTYLE $leveldata]}
+ set level_script_complete 1
+ }
+ @ {
+ #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next)
+ #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2
+
+
+ #append script \n {puts stderr [uplevel 1 [list info vars]]}
+
+ #NOTE:
+ #v_list_idx in context of _multi_bind_result
+ #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run)
+ append script \n {upvar 2 v_list_idx v_list_idx}
+
+ set active_key_type "list"
+ append script \n {# set active_key_type "list" index_operation: list-get-next}
+ #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey
+ #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3
+ #while x@,y@.= is reasonably handy - especially for args e.g $len} {
+ set assigned 1
+ } else {
+ set assigned 0
+ }
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS get-next
+ append script \n [tstr -return string -allowcommands {
+ set index [expr {[incr v_list_idx(@)]-1}]
+
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } elseif {$index+1 > $len} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ } else {
+ set assigned [lindex $leveldata $index]
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ @* {
+ set active_key_type "list"
+ if {$get_not} {
+ lappend INDEX_OPERATIONS list-is-empty
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } elseif {$len == 0} {
+ set assigned 1 ;#list is empty
+ } else {
+ set assigned 0
+ }
+ }]
+ } else {
+ lappend INDEX_OPERATIONS list-get-all
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ set assigned [lrange $leveldata 0 end]
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ @@ {
+ #stateful: tracking of index using v_dict_idx
+ set active_key_type "dict"
+ lappend INDEX_OPERATIONS get-next-value
+ append script \n {# set active_key_type "dict" index_operation: get-next-value}
+ append script \n {upvar v_dict_idx v_dict_idx} ;#review!
+
+ #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc
+ #x@@ = a {x y}
+ #x@@/@0 = a
+ #x@@/@1 = x y
+ #x@@/a = a {x y}
+ # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group.
+ # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index)
+ #review - might be more useful if they shared an index ?
+ # It is analogous to v1@,v2@ for lists.
+ # @pairs is more useful for repeated operations
+
+
+ set indent " "
+ set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] {
+ if {($keyindex + 1) <= $dsize} {
+ set k [lindex [dict keys $leveldata] $keyindex]
+ set assigned [list $k [dict get $leveldata $k]]
+ } else {
+ ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]}
+ }
+ }]
+
+ set assignment_script [tstr -ret string -allowcommands $assignment_script]
+
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} dsize]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ } else {
+ set next_this_level [incr v_dict_idx(${$SUBPATH})]
+ set keyindex [expr {$next_this_level -1}]
+ ${$assignment_script}
+ }
+ }]
+ set level_script_complete 1
+ }
+ @?@ {
+ #stateful: tracking of index using v_dict_idx
+ set active_key_type "dict"
+ lappend INDEX_OPERATIONS get?-next-value
+ append script \n {# set active_key_type "dict" index_operation: get?-next-value}
+ append script \n {upvar v_dict_idx v_dict_idx} ;#review!
+ set indent " "
+ set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] {
+ if {($keyindex + 1) <= $dsize} {
+ set k [lindex [dict keys $leveldata] $keyindex]
+ set assigned [dict get $leveldata $k]
+ } else {
+ set assigned [list]
+ }
+ }]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} dsize]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ } else {
+ set next_this_level [incr v_dict_idx(${$SUBPATH})]
+ set keyindex [expr {$next_this_level -1}]
+ ${$assignment_script}
+ }
+ }]
+ set level_script_complete 1
+ }
+ @??@ {
+ set active_key_type "dict"
+ lappend INDEX_OPERATIONS get?-next-pair
+ append script \n {# set active_key_type "dict" index_operation: get?-next-pair}
+ append script \n {upvar v_dict_idx v_dict_idx} ;#review!
+ set indent " "
+ set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] {
+ if {($keyindex + 1) <= $dsize} {
+ set k [lindex [dict keys $leveldata] $keyindex]
+ set assigned [list $k [dict get $leveldata $k]]
+ } else {
+ set assigned [list]
+ }
+ }]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} dsize]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ } else {
+ set next_this_level [incr v_dict_idx(${$SUBPATH})]
+ set keyindex [expr {$next_this_level -1}]
+ ${$assignment_script}
+ }
+ }]
+ set level_script_complete 1
+ }
+ @vv@ - @VV@ - @kk@ - @KK@ {
+ error "unsupported index $index"
+ }
+ default {
+
+ #assert rules for values within @@
+ #glob search is done only if there is at least one * within @@
+ #if there is at least one ? within @@ - then a non match will not raise an error (quiet)
+
+ #single or no char between @@:
+ #lookup/search is based on key - return is values
+
+ #double char within @@:
+ #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@
+ #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@
+ #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value
+ #e.g @k*@ returns keys - search on values
+ #e.g @*k@ returns keys - search on keys
+ #e.g @v*@ returns values - search on values
+ #e.g @*v@ returns values - search on keys
+
+ switch -glob -- $index {
+ @@* {
+ #exact key match - return value
+ #noisy get value - complain if key non-existent
+ #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped
+ set active_key_type "dict"
+ set key [string range $index 2 end]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS exactkey-get-value-not
+ #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here
+ #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict" index_operation: exactkey-get-value-not
+ if {[dict exists $leveldata ${$key}]} {
+ set assigned [dict values [dict remove $leveldata ${$key}]]
+ } else {
+ #set action ?mismatch-dict-key-not-found
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS exactkey-get-value
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict index_operation: exactkey-get-value"
+ if {[dict exists $leveldata ${$key}]} {
+ set assigned [dict get $leveldata ${$key}]
+ } else {
+ #set action ?mismatch-dict-key-not-found
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ {@\?@*} {
+ #exact key match - quiet get value
+ #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict
+ #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not
+ set active_key_type "dict"
+ set key [string range $index 3 end]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS exactkey?-get-value-not
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict" index_operation: exactkey?-get-value-not
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ set assigned [dict values [dict remove $leveldata ${$key}]]
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS exactkey?-get-value
+ #dict exists test is safe - no need for catch
+ append script \n [string map [list $key] {
+ # set active_key_type "dict" index_operation: exactkey?-get-value
+ if {[dict exists $leveldata ]} {
+ set assigned [dict get $leveldata ]
+ } else {
+ set assigned [dict create]
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ {@\?\?@*} {
+ #quiet get pairs
+ #this is silent too.. so how do we do a checked return of dict key+val?
+ set active_key_type "dict"
+ set key [string range $index 4 end]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS exactkey?-get-pair-not
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict" index_operation: exactkey?-get-pair-not
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ set assigned [dict remove $leveldata ${$key}]
+ }]
+ } else {
+ lappend INDEX_OPERATIONS exactkey?-get-pair
+ append script \n [string map [list $key] {
+ # set active_key_type "dict" index_operation: exactkey?-get-pair
+ if {[dict exists $leveldata ]} {
+ set assigned [dict create [dict get $leveldata ]]
+ } else {
+ set assigned [dict create]
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ @..@* - @kk@* - @KK@* {
+ #noisy get pairs by key
+ set active_key_type "dict"
+ set key [string range $index 4 end]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS exactkey-get-pairs-not
+ #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here
+ #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict" index_operation: exactkey-get-pairs-not
+ if {[dict exists $leveldata ${$key}]} {
+ set assigned [tcl::dict::remove $leveldata ${$key}]
+ } else {
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS exactkey-get-pairs
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict index_operation: exactkey-get-pairs"
+ if {[dict exists $leveldata ${$key}]} {
+ tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}]
+ } else {
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+ }
+ set level_script_complete 1
+
+ }
+ @vv@* - @VV@* {
+ #noisy(?) get pairs by exact value
+ #return mismatch on non-match even when not- specified
+ set active_key_type "dict"
+ set keyglob [string range $index 4 end]
+ set active_key_type "dict"
+ set key [string range $index 4 end]
+ if {$get_not} {
+ #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist
+ #The utility of this is debatable
+ lappend INDEX_OPERATIONS exactvalue-get-pairs-not
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict" index_operation: exactvalue-get-pairs-not
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ set nonmatches [dict create]
+ tcl::dict::for {k v} $leveldata {
+ if {![string equal ${$key} $v]} {
+ dict set nonmatches $k $v
+ }
+ }
+
+ if {[dict size $nonmatches] < [dict size $leveldata]} {
+ #our key matched something
+ set assigned $nonmatches
+ } else {
+ #our key didn't match anything - don't return the nonmatches
+ #set action ?mismatch-dict-key-not-found
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS exactvalue-get-pairs
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict index_operation: exactvalue-get-pairs-not"
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ set matches [list]
+ tcl::dict::for {k v} $leveldata {
+ if {[string equal ${$key} $v]} {
+ lappend matches $k $v
+ }
+ }
+ if {[llength $matches]} {
+ set assigned $matches
+ } else {
+ #set action ?mismatch-dict-key-not-found
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+ }
+ set level_script_complete 1
+
+ }
+ {@\*@*} - {@\*v@*} - {@\*V@*} {
+ #dict key glob - return values only
+ set active_key_type "dict"
+ if {[string match {@\*@*} $index]} {
+ set keyglob [string range $index 3 end]
+ } else {
+ #vV
+ set keyglob [string range $index 4 end]
+ }
+ #if $keyglob eq "" - needs to query for dict key that is empty string.
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globkey-get-values-not
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ # set active_key_type "dict" index_operation: globkey-get-values-not
+ set matched [dict keys $leveldata {${$keyglob}}]
+ set assigned [dict values [dict remove $leveldata {*}$matched]]
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS globkey-get-values
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict" index_operation: globkey-get-values
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ set matched [dict keys $leveldata {${$keyglob}}]
+ set assigned [list]
+ foreach m $matched {
+ lappend assigned [dict get $leveldata $m]
+ }
+ }]
+ }
+ set level_script_complete 1
+
+ }
+ {@\*.@*} {
+ #dict key glob - return pairs
+ set active_key_type "dict"
+ set keyglob [string range $index 4 end]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globkey-get-pairs-not
+ append script \n [string map [list $keyglob] {
+ # set active_key_type "dict" index_operation: globkey-get-pairs-not
+ set matched [dict keys $leveldata {}]
+ set assigned [dict remove $leveldata {*}$matched]
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS globkey-get-pairs
+ append script \n [string map [list $keyglob] {
+ # set active_key_type "dict" index_operations: globkey-get-pairs
+ set matched [dict keys $leveldata {}]
+ set assigned [dict create]
+ foreach m $matched {
+ dict set assigned $m [dict get $leveldata $m]
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ {@\*k@*} - {@\*K@*} {
+ #dict key glob - return keys
+ set active_key_type "dict"
+ set keyglob [string range $index 4 end]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globkey-get-keys-not
+ append script \n [string map [list $keyglob] {
+ # set active_key_type "dict" index_operation: globkey-get-keys-not
+ set matched [dict keys $leveldata {}]
+ set assigned [dict keys [dict remove $leveldata {*}$matched]]
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS globkey-get-keys
+ append script \n [string map [list $keyglob] {
+ # set active_key_type "dict" index_operation: globkey-get-keys
+ set assigned [dict keys $leveldata {}]
+ }]
+ }
+ set level_script_complete 1
+ }
+ {@k\*@*} - {@K\*@*} {
+ #dict value glob - return keys
+ set active_key_type "dict"
+ set valglob [string range $index 4 end]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globvalue-get-keys-not
+ append script \n [string map [list $valglob] {
+ # set active_key_type "dict" index_operation: globvalue-get-keys-not
+ set assigned [list]
+ tcl::dict::for {k v} $leveldata {
+ if {![string match {} $v]} {
+ lappend assigned $k
+ }
+ }
+ }]
+ } else {
+ lappend INDEX_OPERATIONS globvalue-get-keys
+ append script \n [string map [list $valglob] {
+ # set active_key_type "dict" index_operation: globvalue-get-keys
+ set assigned [list]
+ tcl::dict::for {k v} $leveldata {
+ if {[string match {} $v]} {
+ lappend assigned $k
+ }
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ {@.\*@*} {
+ #dict value glob - return pairs
+ set active_key_type "dict"
+ set valglob [string range $index 4 end]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globvalue-get-pairs-not
+ append script \n [string map [list $valglob] {
+ # set active_key_type "dict" index_operation: globvalue-get-pairs-not
+ set assigned [dict create]
+ tcl::dict::for {k v} $leveldata {
+ if {![string match {} $v]} {
+ dict set assigned $k $v
+ }
+ }
+ }]
+ } else {
+ lappend INDEX_OPERATIONS globvalue-get-pairs
+ append script \n [string map [list $valglob] {
+ # set active_key_type "dict" index_operation: globvalue-get-pairs
+ set assigned [dict create]
+ tcl::dict::for {k v} $leveldata {
+ if {[string match {} $v]} {
+ dict set assigned $k $v
+ }
+ }
+ }]
+ }
+ set level_script_complete 1
+ }
+ {@V\*@*} - {@v\*@*} {
+ #dict value glob - return values
+ set active_key_type dict
+ set valglob [string range $index 4 end]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globvalue-get-values-not
+ append script \n [string map [list $valglob] {
+ # set active_key_type "dict" ;# index_operation: globvalue-get-values-not
+ set assigned [list]
+ tcl::dict::for {k v} $leveldata {
+ if {![string match {} $v]} {
+ lappend assigned $v
+ }
+ }
+ }]
+
+ } else {
+ lappend INDEX_OPERATIONS globvalue-get-values
+ append script \n [string map [list $valglob] {
+ # set active_key_type "dict" ;#index_operation: globvalue-get-value
+ set assigned [dict values $leveldata ]
+ }]
+ }
+ set level_script_complete 1
+
+ }
+ {@\*\*@*} {
+ #dict val/key glob return pairs)
+ set active_key_type "dict"
+ set keyvalglob [string range $index 4 end]
+ append script [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata}]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ }
+ }]
+ if {$get_not} {
+ lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not
+ error "globkeyvalue-get-pairs-not todo"
+ } else {
+ lappend INDEX_OPERATIONS globkeyvalue-get-pairs
+ append script \n [string map [list $keyvalglob] {
+ # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not
+ set assigned [dict create]
+ tcl::dict::for {k v} $leveldata {
+ if {[string match {} $k] || [string match {} $v]} {
+ dict set assigned $k $v
+ }
+ }
+ }]
+ }
+ set level_script_complete 1
+ puts stderr "globkeyvalue-get-pairs review"
+ }
+ @* {
+ set active_key_type "list"
+ set do_bounds_check 1
+
+ set index [string trimleft $index @]
+ append script \n [string map [list $index] {
+ # set active_key_type "list" index_operation: ?
+ set index
+ }]
+ }
+ %* {
+ set active_key_type "string"
+ set do_bounds_check 0
+ set index [string range $index 1 end]
+ append script \n [string map [list $index] {
+ # set active_key_type "string" index_operation: ?
+ set index
+ }]
+ }
+ default {
+ puts "destructure_func_build_body unmatched index $index"
+ }
+ }
+ }
+ }
+
+ if {!$level_script_complete} {
+
+
+ #keyword 'pipesyntax' at beginning of error message
+ set listmsg "pipesyntax Unable to interpret subindex $index\n"
+ append listmsg "selector: '$selector'\n"
+ append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n"
+ append listmsg "Additional accepted keywords include: head tail\n"
+ append listmsg "Use var@@key to treat value as a dict and retrieve element at key"
+
+ #append script \n [string map [list $listmsg] {set listmsg ""}]
+
+
+
+ #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against
+ #need to set a corresponding action
+ if {$active_key_type in [list "" "list"]} {
+ set active_key_type "list"
+ append script \n {# set active_key_type "list"}
+ #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir)
+ switch -exact -- $index {
+ 0 {
+ if {$get_not} {
+ append script \n "# index_operation listindex-int-not" \n
+ lappend INDEX_OPERATIONS listindex-zero-not
+ set assignment_script {set assigned [lrange $leveldata 1 end]}
+ } else {
+ lappend INDEX_OPERATIONS listindex-zero
+ set assignment_script {set assigned [lindex $leveldata 0]}
+ if {$do_bounds_check} {
+ append script \n "# index_operation listindex-int (bounds checked)" \n
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } elseif {[llength $leveldata] == 0} {
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ } else {
+ append script \n "# index_operation listindex-int" \n
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ }
+ }
+ head {
+ #NOTE: /@head and /head both do bounds check. This is intentional
+ if {$get_not} {
+ append script \n "# index_operation listindex-head-not" \n
+ lappend INDEX_OPERATIONS listindex-head-not
+ set assignment_script {set assigned [lrange $leveldata 1 end]}
+ } else {
+ append script \n "# index_operation listindex-head" \n
+ lappend INDEX_OPERATIONS listindex-head
+ set assignment_script {set assigned [lindex $leveldata 0]}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } elseif {$len == 0} {
+ #set action ?mismatch-list-index-out-of-range-empty
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]}
+ } else {
+ #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax
+ ${$assignment_script}
+ }
+ }]
+ }
+ end {
+ if {$get_not} {
+ append script \n "# index_operation listindex-end-not" \n
+ lappend INDEX_OPERATIONS listindex-end-not
+ #on single element list Tcl's lrange will do what we want here and return nothing
+ set assignment_script {set assigned [lrange $leveldata 0 end-1]}
+ } else {
+ append script \n "# index_operation listindex-end" \n
+ lappend INDEX_OPERATIONS listindex-end
+ set assignment_script {set assigned [lindex $leveldata end]}
+ }
+ if {$do_bounds_check} {
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } elseif {$len == 0} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ } else {
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ }
+ tail {
+ #NOTE: /@tail and /tail both do bounds check. This is intentional.
+ #
+ #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list
+ #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems.
+ #In this way tail is different to @1-end
+ if {$get_not} {
+ append script \n "# index_operation listindex-tail-not" \n
+ lappend INDEX_OPERATIONS listindex-tail-not
+ set assignment_script {set assigned [lindex $leveldata 0]}
+ } else {
+ append script \n "# index_operation listindex-tail" \n
+ lappend INDEX_OPERATIONS listindex-tail
+ set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } elseif {$len == 0} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ anyhead {
+ #allow returning of head or nothing if empty list
+ if {$get_not} {
+ append script \n "# index_operation listindex-anyhead-not" \n
+ lappend INDEX_OPERATIONS listindex-anyhead-not
+ set assignment_script {set assigned [lrange $leveldata 1 end]}
+ } else {
+ append script \n "# index_operation listindex-anyhead" \n
+ lappend INDEX_OPERATIONS listindex-anyhead
+ set assignment_script {set assigned [lindex $leveldata 0]}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ anytail {
+ #allow returning of tail or nothing if empty list
+ #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead.
+ if {$get_not} {
+ append script \n "# index_operation listindex-anytail-not" \n
+ lappend INDEX_OPERATIONS listindex-anytail-not
+ set assignment_script {set assigned [lindex $leveldata 0]}
+ } else {
+ append script \n "# index_operation listindex-anytail" \n
+ lappend INDEX_OPERATIONS listindex-anytail
+ set assignment_script {set assigned [lrange $leveldata 1 end]}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ init {
+ #all but last element - same as haskell 'init'
+ #counterintuitively, get-notinit can therefore return first element if it is a single element list
+ #does bounds_check for get-not@init make sense here? maybe - review
+ if {$get_not} {
+ append script \n "# index_operation listindex-init-not" \n
+ lappend INDEX_OPERATIONS listindex-init-not
+ set assignment_script {set assigned [lindex $leveldata end]}
+ } else {
+ append script \n "# index_operation listindex-init" \n
+ lappend INDEX_OPERATIONS listindex-init
+ set assignment_script {set assigned [lrange $leveldata 0 end-1]}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ list {
+ #get_not?
+ #allow returning of entire list even if empty
+ if {$get_not} {
+ lappend INDEX_OPERATIONS list-getall-not
+ set assignment_script {set assigned {}}
+ } else {
+ lappend INDEX_OPERATIONS list-getall
+ set assignment_script {set assigned $leveldata}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ raw {
+ #get_not - return nothing??
+ #no list checking..
+ if {$get_not} {
+ lappend INDEX_OPERATIONS getraw-not
+ append script \n {set assigned {}}
+ } else {
+ lappend INDEX_OPERATIONS getraw
+ append script \n {set assigned $leveldata}
+ }
+ }
+ keys {
+ #@get_not??
+ #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements
+ if {$get_not} {
+ lappend INDEX_OPERATIONS list-getkeys-not
+ set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values
+ } else {
+ lappend INDEX_OPERATIONS list-getkeys
+ set assignment_script {set assigned [dict keys $leveldata]}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} dsize]} {
+ #set action ?mismatch-not-a-dict
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ values {
+ #get_not ??
+ #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements
+ if {$get_not} {
+ lappend INDEX_OPERATIONS list-getvalues-not
+ set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys
+ } else {
+ lappend INDEX_OPERATIONS list-getvalues
+ set assignment_script {set assigned [dict values $leveldata]}
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} dsize]} {
+ #set action ?mismatch-not-a-dict
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ } else {
+ ${$assignment_script}
+ }
+ }]
+ }
+ pairs {
+ #get_not ??
+ if {$get_not} {
+ #review - return empty list instead like not-list and not-raw?
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported]
+ } else {
+ lappend INDEX_OPERATIONS list-getpairs
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {dict size $leveldata} dsize]} {
+ #set action ?mismatch-not-a-dict
+ ${[tstr -ret string $tpl_return_mismatch_not_a_dict]}
+ } else {
+ set pairs [list]
+ tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]}
+ set assigned [lindex [list $pairs [unset pairs]] 0]
+ }
+ }]
+ }
+ default {
+ if {[regexp {[?*]} $index]} {
+ if {$get_not} {
+ lappend INDEX_OPERATIONS listsearch-not
+ set assign_script [string map [list $index] {
+ set assigned [lsearch -all -inline -not $leveldata ]
+ }]
+ } else {
+ lappend INDEX_OPERATIONS listsearch
+ set assign_script [string map [list $index] {
+ set assigned [lsearch -all -inline $leveldata ]
+ }]
+ }
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assign_script}
+ }
+ }]
+ } elseif {[string is integer -strict $index]} {
+ if {$get_not} {
+ lappend INDEX_OPERATIONS listindex-not
+ set assign_script [string map [list $index] {
+ #not- was specified (already handled not-0)
+ set assigned [lreplace $leveldata ]
+ }]
+ } else {
+ lappend INDEX_OPERATIONS listindex
+ set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}]
+ }
+
+ if {$do_bounds_check} {
+ if {$index < 0} {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on]
+ }
+ set max [expr {$index + 1}]
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ # bounds_check due to @ directly specified in original index section
+ if {${$max} > $len} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ } else {
+ ${$assign_script}
+ }
+ }
+ }]
+ } else {
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assign_script}
+ }
+ }]
+ }
+ } elseif {[string first "end" $index] >=0} {
+ if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} {
+
+ if {$get_not} {
+ lappend INDEX_OPERATIONS listindex-endoffset-not
+ set assign_script [string map [list $index] {
+ #not- was specified (already handled not-0)
+ set assigned [lreplace $leveldata ]
+ }]
+ } else {
+ lappend INDEX_OPERATIONS listindex-endoffset
+ set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}]
+ }
+
+ if {$do_bounds_check} {
+ #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case.
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ set action ?mismatch-not-a-list
+ } else {
+ #bounds-check is true
+ #leave the - from the end- as part of the offset
+ set offset [expr ${$endspec}] ;#don't brace!
+ if {($offset > 0 || abs($offset) >= $len)} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ } else {
+ ${$assign_script}
+ }
+ }
+ }]
+ } else {
+ append script \n [tstr -ret string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ } else {
+ ${$assign_script}
+ }
+ }]
+ }
+
+ } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} {
+ if {$get_not} {
+ lappend INDEX_OPERATIONS list-range-not
+ set assign_script [string map [list $start $end ] {
+ #not- was specified (already handled not-0)
+ set assigned [lreplace $leveldata ]
+ }]
+ } else {
+ lappend INDEX_OPERATIONS list-range
+ set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}]
+ }
+
+ append script \n [tstr -ret string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ }
+ }]
+
+ if {$do_bounds_check} {
+ if {[string is integer -strict $start]} {
+ if {$start < 0} {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on]
+ }
+ append script \n [tstr -return string -allowcommands {
+ set start ${$start}
+ if {$start+1 > $len} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ }
+ }]
+ } elseif {$start eq "end"} {
+ #noop
+ } else {
+ set startoffset [string range $start 3 end] ;#include the - from end-
+ set startoffset [expr $startoffset] ;#don't brace!
+ if {$startoffset > 0} {
+ #e.g end+1
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on]
+
+ }
+ append script \n [tstr -return string -allowcommands {
+ set startoffset ${$startoffset}
+ if {abs($startoffset) >= $len} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ }
+ }]
+ }
+ if {[string is integer -strict $end]} {
+ if {$end < 0} {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on]
+ }
+ append script \n [tstr -return string -allowcommands {
+ set end ${$end}
+ if {$end+1 > $len} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ }
+ }]
+ } elseif {$end eq "end"} {
+ #noop
+ } else {
+ set endoffset [string range $end 3 end] ;#include the - from end-
+
+ set endoffset [expr $endoffset] ;#don't brace!
+ if {$endoffset > 0} {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on]
+ }
+ append script \n [tstr -return string -allowcommands {
+ set endoffset ${$endoffset}
+ if {abs($endoffset) >= $len} {
+ #set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ }
+ }]
+ }
+ }
+
+ append script \n [string map [list $assign_script] {
+ if {![string match ?mismatch-* $action]} {
+
+ }
+ }]
+
+ } else {
+ #fail now - no need for script
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ } elseif {[string first - $index] > 0} {
+ #e.g @1-3 gets here
+ #JMN
+ if {$get_not} {
+ lappend INDEX_OPERATIONS list-range-not
+ } else {
+ lappend INDEX_OPERATIONS list-range
+ }
+
+ append script \n [tstr -return string -allowcommands {
+ if {[catch {llength $leveldata} len]} {
+ #set action ?mismatch-not-a-list
+ ${[tstr -ret string $tpl_return_mismatch_not_a_list]}
+ }
+ }]
+
+ #handle pure int-int ranges separately
+ set testindex [string map [list - "" + ""] $index]
+ if {[string is digit -strict $testindex]} {
+ #don't worry about leading - negative value for indices not valid anyway
+ set parts [split $index -]
+ if {[llength $parts] != 2} {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ lassign $parts start end
+
+ #review - Tcl lrange just returns nothing silently.
+ #if we don't intend to implement reverse indexing - we should probably not emit an error
+ if {$start > $end} {
+ puts stderr "pipesyntax for selector $selector error - reverse index unimplemented"
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ if {$do_bounds_check} {
+ #append script [string map [list $start $end] {
+ # set start
+ # set end
+ # if {$start+1 > $len || $end+1 > $len} {
+ # set action ?mismatch-list-index-out-of-range
+ # }
+ #}]
+ #set eplusone [expr {$end+1}]
+ append script [tstr -return string -allowcommands {
+ if {$len < ${[expr {$end+1}]}} {
+ set action ?mismatch-list-index-out-of-range
+ ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]}
+ }
+ }]
+ }
+
+
+ if {$get_not} {
+ set assign_script [string map [list $start $end] {
+ #not- was specified (already handled not-0)
+ set assigned [lreplace $leveldata ]
+ }]
+ } else {
+ set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}]
+ }
+
+
+ } else {
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+
+ append script \n [string map [list $assign_script] {
+ if {![string match ?mismatch-* $action]} {
+
+ }
+ }]
+
+ } else {
+ #keyword 'pipesyntax' at beginning of error message
+ #pipesyntax error - no need to even build script - can fail now
+ error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector]
+ }
+ }
+ }
+ } elseif {$active_key_type eq "string"} {
+ if {[string match *-* $index]} {
+ lappend INDEX_OPERATIONS string-range
+ set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$}
+ #todo - support more complex indices: 0-end-1 etc
+
+ lassign [split $index -] a b
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "string"
+ set assigned [string range $leveldata ${$a} ${$b}]
+ }]
+
+ } else {
+ if {$index eq "*"} {
+ lappend INDEX_OPERATIONS string-all
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "string"
+ set assigned $leveldata
+ }]
+ } elseif {[regexp {[?*]} $index]} {
+ lappend INDEX_OPERATIONS string-globmatch
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "string"
+ if {[string match $index $leveldata]} {
+ set assigned $leveldata
+ } else {
+ set assigned ""
+ }
+ }]
+ } else {
+ lappend INDEX_OPERATIONS string-index
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "string"
+ set assigned [string index $leveldata ${$index}]
+ }]
+ }
+ }
+
+ } else {
+ #treat as dict key
+ if {$get_not} {
+ #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence?
+ append script \n [tstr -return string {
+ set assigned [dict remove $leveldata ${$index}]
+ }]
+ } else {
+ append script \n [tstr -return string -allowcommands {
+ # set active_key_type "dict"
+ if {[dict exists $leveldata {${$index}}]} {
+ set assigned [dict get $leveldata {${$index}}]
+ } else {
+ set action ?mismatch-dict-key-not-found
+ ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]}
+ }
+ }]
+ }
+
+ }
+
+
+ } ;# end if $level_script_complete
+
+
+ append script \n {
+ set leveldata $assigned
+ }
+ incr i_keyindex
+ append script \n "# ------- END index $index ------"
+ } ;# end foreach
+
+
+
+ #puts stdout "----> destructure rep leveldata: [rep $leveldata]"
+ #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]"
+
+ #maintain key order - caller unpacks using lassign
+ #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs}
+ append script \n [tstr -return string $return_template] \n
+ return $script
+ }
+
+
+
+
+ #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level
+ #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope
+ #return a dict with keys result, setvars, unsetvars
+ #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar
+ #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?)
+ #e.g x,x@0 will only match a single element list
+ #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline)
+ # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline
+ proc _multi_bind_result {multivar data args} {
+ #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'"
+ #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1
+ if {![string length $multivar]} {
+ #treat the absence of a pattern as a match to anything
+ #JMN2 - changed to list based destructuring
+ return [dict create ismatch 1 result $data setvars {} script {}]
+ #return [dict create ismatch 1 result [list $data] setvars {} script {}]
+ }
+ set returndict [dict create ismatch 0 result "" setvars {}]
+ set script ""
+
+ set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0]
+ set opts [dict merge $defaults $args]
+ set unset [dict get $opts -unset]
+ set lvlup [dict get $opts -levelup]
+ set get_mismatchinfo [dict get $opts -mismatchinfo]
+
+
+
+ #first classify into var_returntype of either "pipeline" or "segment"
+ #segment returntype is indicated by leading %
+
+ set varinfo [punk::pipe::lib::_var_classify $multivar]
+ set var_names [dict get $varinfo var_names]
+ set var_class [dict get $varinfo var_class]
+ set varspecs_trimmed [dict get $varinfo varspecs_trimmed]
+
+ set var_actions [list]
+ set expected_values [list]
+ #e.g {a = abc} {b set ""}
+ foreach classinfo $var_class vname $var_names {
+ lassign [lindex $classinfo 0] v
+ lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version
+ lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default
+ }
+
+ #puts stdout "var_actions: $var_actions"
+ #puts stdout "expected_values: $expected_values"
+
+
+ #puts stdout "\n var_class: $var_class\n"
+ # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2}
+
+ #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}]
+ #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n"
+
+
+ #var names (possibly empty portion to the left of )
+ #debug.punk.pipe.var "varnames: $var_names" 4
+
+ set v_list_idx(@) 0 ;#for spec with single @ only
+ set v_dict_idx(@@) 0 ;#for spec with @@ only
+
+ #jn
+
+ #member lists of returndict which will be appended to in the initial value-retrieving loop
+ set returndict_setvars [dict get $returndict setvars]
+
+ set assigned_values [list]
+
+
+ #varname action value - where value is value to be set if action is set
+ #actions:
+ # "" unconfigured - assert none remain unconfigured at end
+ # noop no-change
+ # matchvar-set name is a var to be matched
+ # matchatom-set names is an atom to be matched
+ # matchglob-set
+ # set
+ # question mark versions are temporary - awaiting a check of action vs var_class
+ # e.g ?set may be changed to matchvar or matchatom or set
+
+
+ debug.punk.pipe.var {initial map expected_values: $expected_values} 5
+
+ set returnval ""
+ set i 0
+ #assertion i incremented at each continue and at each end of loop - at end i == list length + 1
+ #always use 'assigned' var in each loop
+ # (for consistency and to assist with returnval)
+ # ^var means a pinned variable - compare value of $var to rhs - don't assign
+ #
+ # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark.
+ # as well as adding the data values to the var_actions list
+ #
+ # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data!
+ set vkeys_seen [list]
+ foreach v_and_key $varspecs_trimmed {
+ set vspec [join $v_and_key ""]
+ lassign $v_and_key v vkey
+
+ set assigned ""
+ #The binding spec begins at first @ or # or /
+
+ #set firstq [string first "'" $vspec]
+ #set v [lindex $var_names $i]
+ #if v contains any * and/or ? - then it is a glob match - not a varname
+
+ lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs
+ if {$matchaction eq "?match"} {
+ set matchaction "?set"
+ }
+ lset var_actions $i 1 $matchaction
+ lset var_actions $i 2 $assigned
+
+ #update the setvars/unsetvars elements
+ if {[string length $v]} {
+ dict set returndict_setvars $v $assigned
+ }
+
+ #JMN2
+ #special case expansion for empty varspec (e.g , or ,,)
+ #if {$vspec eq ""} {
+ # lappend assigned_values {*}$assigned
+ #} else {
+ lappend assigned_values $assigned
+ #}
+ incr i
+ }
+
+ #todo - fix! this isn't the actual tclvars that were set!
+ dict set returndict setvars $returndict_setvars
+
+ #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec
+ #For booleans the final val may later be normalised to 0 or 1
+
+
+ #assertion all var_actions were set with leading question mark
+ #perform assignments only if matched ok
+
+
+ #0 - novar
+ #1 - atom '
+ #2 - pin ^
+ #3 - boolean &
+ #4 - integer
+ #5 - double
+ #6 - var
+ #7 - glob (no classifier and contains * or ?)
+ if 0 {
+ debug.punk.pipe.var {VAR_CLASS: $var_class} 5
+ debug.punk.pipe.var {VARACTIONS: $var_actions} 5
+ debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5
+
+ debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5
+ debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5
+ debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5
+ debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5
+ debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5
+ debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5
+ debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5
+ }
+
+ set match_state [lrepeat [llength $var_names] ?]
+ unset -nocomplain v
+ unset -nocomplain nm
+ set mismatched [list]
+ set i 0
+ #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern)
+ foreach va $var_actions {
+ #val comes from -assigned
+ lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var"
+ set varname [lindex $var_names $i]
+
+ if {[string match "?mismatch*" $act]} {
+ #already determined a mismatch - e.g list or dict key not present
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val]
+ break
+ }
+
+
+ set class_key [lindex $var_class $i 1]
+ lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan
+ foreach ck $class_key {
+ switch -- $ck {
+ 1 {set isatom 1}
+ 2 {set ispin 1}
+ 3 {set isbool 1}
+ 4 {set isint 1}
+ 5 {set isdouble 1}
+ 6 {set isvar 1}
+ 7 {set isglob 1}
+ 8 {set isnumeric 1}
+ 9 {set isgreaterthan 1}
+ 10 {set islessthan 1}
+ }
+ }
+
+
+ #set isatom [expr {$class_key == 1}]
+ #set ispin [expr {2 in $class_key}]
+ #set isbool [expr {3 in $class_key}]
+ #set isint [expr {4 in $class_key}]
+ #set isdouble [expr {5 in $class_key}]
+ #set isvar [expr {$class_key == 6}]
+ #set isglob [expr {7 in $class_key}]
+ #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present)
+ ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only?
+ #set isgreaterthan [expr {9 in $class_key}]
+ #set islessthan [expr {10 in $class_key}]
+
+
+
+ if {$isatom} {
+ #puts stdout "==>isatom $lhsspec"
+ set lhs [string range $lhsspec 1 end]
+ if {[string index $lhs end] eq "'"} {
+ set lhs [string range $lhs 0 end-1]
+ }
+ lset var_actions $i 1 matchatom-set
+ if {$lhs eq $val} {
+ lset match_state $i 1
+ lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val]
+ incr i
+ continue
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val]
+ break
+ }
+ }
+
+
+
+
+ # - should set expected_values in each branch where match_state is not set to 1
+ # - setting expected_values when match_state is set to 0 is ok except for performance
+
+
+ #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or
+ #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling)
+ if {$ispin} {
+ #puts stdout "==>ispin $lhsspec"
+ if {$act in [list "?set" "?matchvar-set"]} {
+ lset var_actions $i 1 matchvar-set
+ #attempt to read
+ upvar $lvlup $varname the_var
+ #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {}
+ if {![catch {set the_var} existingval]} {
+
+ if {$isbool} {
+ #isbool due to 2nd classifier i.e ^&
+ lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val]
+ #normalise to LHS!
+ lset assigned_values $i $existingval
+ } elseif {$isglob} {
+ #isglob due to 2nd classifier ^*
+ lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val]
+ } elseif {$isnumeric} {
+ #flagged as numeric by user using ^# classifiers
+ set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .)
+ if {[string is integer -strict $testexistingval]} {
+ set isint 1
+ lset assigned_values $i $existingval
+ lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val]
+ } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} {
+ #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval)
+ set isdouble 1
+ #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var
+ lset assigned_values $i $existingval
+
+ lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val]
+ } else {
+ #user's variable doesn't seem to have a numeric value
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val]
+ break
+ }
+
+ } else {
+ #standard pin - single classifier ^var
+ lset match_state $i [expr {$existingval eq $val}]
+ if {![lindex $match_state $i]} {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val]
+ break
+ } else {
+ lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val]
+ }
+ }
+
+ } else {
+ #puts stdout "pinned var $varname result:$result vs val:$val"
+ #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val]
+ break
+ }
+ }
+ }
+
+
+
+ if {$isint} {
+ #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so.
+ #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val]
+
+ if {$ispin} {
+ set existing_expected [lindex $expected_values $i]
+ set lhs [dict get $existing_expected lhs]
+ } else {
+ set lhs $lhsspec ;#literal integer in the pattern
+ }
+ if {$isgreaterthan || $islessthan} {
+ set lhs [string range $lhsspec 0 end-1]
+ set testlhs $lhs
+ }
+ if {[string index $lhs 0] eq "."} {
+ set testlhs $lhs
+ } else {
+ set testlhs [join [scan $lhs %lld%s] ""]
+ }
+ if {[string index $val 0] eq "."} {
+ set testval $val
+ } else {
+ set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .)
+ }
+ if {[string is integer -strict $testval]} {
+ if {$isgreaterthan} {
+ #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval"
+ if {$testlhs <= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val]
+ break
+ }
+ } elseif {$islessthan} {
+ if {$testlhs >= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val]
+ break
+ }
+ } else {
+ if {$testlhs == $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val]
+ break
+ }
+ }
+ } elseif {[string is double -strict $testval]} {
+ #dragons. (and shimmering)
+ if {[string first "e" $val] != -1} {
+ #scientific notation - let expr compare
+ if {$isgreaterhthan} {
+ if {$testlhs <= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val]
+ break
+ }
+ } elseif {$islessthan} {
+ if {$testlhs >= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val]
+ break
+ }
+ } else {
+ if {$testlhs == $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val]
+ break
+ }
+ }
+ } elseif {[string is digit -strict [string trim $val -]] } {
+ #probably a wideint or bignum with no decimal point
+ #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side .
+ #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end.
+ #2 values further apart can compare equal while int-like ones closer together can compare different.
+ #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in.
+ #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison.
+ #string comparison can presumably always be used as an alternative.
+ #
+ #let expr compare
+ if {$isgreaterthan} {
+ if {$testlhs <= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val]
+ break
+ }
+ } elseif {$islessthan} {
+ if {$testlhs >= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val]
+ break
+ }
+ } else {
+ if {$testlhs == $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val]
+ break
+ }
+ }
+ } else {
+ if {[punk::pipe::float_almost_equal $testlhs $testval]} {
+ lset match_state $i 1
+ } else {
+ if {$isgreaterthan} {
+ if {$testlhs <= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val]
+ break
+ }
+ } elseif {$islessthan} {
+ if {$testlhs >= $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val]
+ break
+ }
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val]
+ break
+ }
+ }
+ }
+ } else {
+ #e.g rhs not a number..
+ if {$testlhs == $testval} {
+ lset match_state $i 1
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val]
+ break
+ }
+ }
+ } elseif {$isdouble} {
+ #dragons (and shimmering)
+ #
+ #
+ if {$ispin} {
+ set existing_expected [lindex $expected_values $i]
+ set lhs [dict get $existing_expected lhs]
+ } else {
+ set lhs $lhsspec ;#literal integer in the pattern
+ }
+ if {$isgreaterthan || $islessthan} {
+ error "+/- not yet supported for lhs float"
+ set lhs [string range $lhsspec 0 end-1]
+ set testlhs $lhs
+ }
+ if {[string index $val 0] eq "."} {
+ set testval $val ;#not something with some number of leading zeros
+ } else {
+ set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .)
+ }
+ #expr handles leading 08.1 0009.1 etc without triggering octal
+ #so we don't need to scan lhs
+ if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} {
+ if {$lhs == $testval} {
+ lset match_state $i 1
+ lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val]
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val]
+ break
+ }
+ } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} {
+ #both look like big whole numbers.. let expr compare using it's bignum capability
+ if {$lhs == $testval} {
+ lset match_state $i 1
+ lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val]
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val]
+ break
+ }
+ } else {
+ #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch
+ if {[punk::pipe::float_almost_equal $lhs $testval]} {
+ lset match_state $i 1
+ lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val]
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val]
+ break
+ }
+ }
+ } elseif {$isbool} {
+ #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches.
+ #e.g &x/0,&x/1,&x/2= {1 2 yes}
+ # all resolve to true so the cross-binding is ok.
+ # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.)
+ # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering?
+ #
+ #punk::pipe::boolean_equal $a $b
+ set extra_match_info "" ;# possible crossbind indication
+ set is_literal_boolean 0
+ if {$ispin} {
+ #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review!
+ #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful
+ set existing_expected [lindex $expected_values $i]
+ set lhs [dict get $existing_expected lhs]
+ } else {
+ set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix
+
+ if {![string length $lhs]} {
+ #empty varname - ok
+ if {[string is boolean -strict $val] || [string is double -strict $val]} {
+ lset match_state $i 1
+ lset var_actions $i 1 "return-normalised-value"
+ lset assigned_values $i [expr {bool($val)}]
+ lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val]
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val]
+ break
+ }
+ } elseif {$lhs in [list 0 1]} {
+ #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test.
+ set is_literal_boolean 1
+ } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} {
+ #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern
+ #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean.
+ set is_literal_boolean 1
+ set lhs [string range $lhs 1 end-1] ;#strip off squotes
+ } else {
+ #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes.
+ set tclvar $lhs
+ if {[string is double $tclvar]} {
+ error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar]
+ #proc _multi_bind_result {multivar data args}
+ }
+ #treat as variable - need to check cross-binding within this pattern group
+ set first_bound [lsearch -index 0 $var_actions $lhsspec]
+ if {$first_bound == $i} {
+ #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed)
+ if {[string is boolean -strict $val] || [string is double -strict $val]} {
+ lset match_state $i 1
+ lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound
+ #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline
+ #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval
+ #puts stderr "==========[lindex $assigned_values $i]"
+ lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0
+ lset assigned_values $i [lindex $var_actions $i 2]
+ #puts stderr "==========[lindex $assigned_values $i]"
+ lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics.
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val]
+ break
+ }
+ } else {
+ set expectedinfo [lindex $expected_values $first_bound]
+ set expected_earlier [dict get $expectedinfo rhs]
+ set extra_match_info "-crossbind-first"
+ set lhs $expected_earlier
+ }
+ }
+ }
+
+
+ #may have already matched above..(for variable)
+ if {[lindex $match_state $i] != 1} {
+ if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} {
+ if {$ismatch} {
+ lset match_state $i 1
+ lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val]
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val]
+ break
+ }
+ } else {
+ #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val]
+ break
+ }
+ }
+
+ } elseif {$isglob} {
+ if {$ispin} {
+ set existing_expected [lindex $expected_values $i]
+ set lhs [dict get $existing_expected lhs]
+ } else {
+ set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix
+ }
+ if {[string match $lhs $val]} {
+ lset match_state $i 1
+ lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val]
+ } else {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val]
+ break
+ }
+
+ } elseif {$ispin} {
+ #handled above.. leave case in place so we don't run else for pins
+
+ } else {
+ #puts stdout "==> $lhsspec"
+ #NOTE - pinned var of same name is independent!
+ #ie ^x shouldn't look at earlier x bindings in same pattern
+ #unpinned non-atoms
+ #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern)
+ #
+ switch -- $varname {
+ "" {
+ #don't attempt cross-bind on empty-varname
+ lset match_state $i 1
+ #don't change var_action $i 1 to set
+ lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val]
+ }
+ "_" {
+ #don't cross-bind on the special 'don't-care' varname
+ lset match_state $i 1
+ lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set
+ lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val]
+ }
+ default {
+ set first_bound [lsearch -index 0 $var_actions $varname]
+ #assertion first_bound >=0, we will always find something - usually self
+ if {$first_bound == $i} {
+ lset match_state $i 1
+ lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set
+ lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val]
+ } else {
+ assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i]
+ set expectedinfo [lindex $expected_values $first_bound]
+ set expected_earlier [dict get $expectedinfo rhs]
+ if {$expected_earlier ne $val} {
+ lset match_state $i 0
+ lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val]
+ break
+ } else {
+ lset match_state $i 1
+ #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example
+ #lset var_actions $i 1 [string range $act 1 end]
+ lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val]
+ }
+ }
+ }
+ }
+ }
+
+ incr i
+ }
+
+ #JMN2 - review
+ #set returnval [lindex $assigned_values 0]
+ if {[llength $assigned_values] == 1} {
+ set returnval [join $assigned_values]
+ } else {
+ set returnval $assigned_values
+ }
+ #puts stdout "----> > rep returnval: [rep $returnval]"
+
+
+
+
+
+ #--------------------------------------------------------------------------
+ #Variable assignments (set) should only occur down here, and only if we have a match
+ #--------------------------------------------------------------------------
+ set match_count_needed [llength $var_actions]
+ #set match_count [expr [join $match_state +]] ;#expr must be unbraced here
+ set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?"
+ set match_count [llength $matches]
+
+
+ debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4
+ debug.punk.pipe.var {VARACTIONS2: $var_actions} 5
+ debug.punk.pipe.var {EXPECTED : $expected_values} 4
+
+ #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join
+ if {$match_count == $match_count_needed} {
+ #do assignments
+ for {set i 0} {$i < [llength $var_actions]} {incr i} {
+ if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} {
+ #isvar
+ if {[lindex $var_actions $i 1] eq "set"} {
+ upvar $lvlup $varname the_var
+ set the_var [lindex $var_actions $i 2]
+ }
+ }
+ }
+ dict set returndict ismatch 1
+ #set i 0
+ #foreach va $var_actions {
+ # #set isvar [expr {[lindex $var_class $i 1] == 6}]
+ # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} {
+ # #isvar
+ # lassign $va lhsspec act val
+ # upvar $lvlup $varname the_var
+ # if {$act eq "set"} {
+ # set the_var $val
+ # }
+ # #if {[lindex $var_actions $i 1] eq "set"} {
+ # # set the_var $val
+ # #}
+ # }
+ # incr i
+ #}
+ } else {
+ #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message
+ #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly
+ set vidx 0
+ #set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}]
+ set mismatches [lmap m $match_state v $var_names {expr {$m == 0 ? [list mismatch $v] : [list match $v]}}]
+ set var_display_names [list]
+ foreach v $var_names {
+ if {$v eq ""} {
+ lappend var_display_names {{}}
+ } else {
+ lappend var_display_names $v
+ }
+ }
+ #REVIEW 2025
+ #set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}]
+ set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0 ? $v : [expr {$m eq "?" ? "?[string repeat { } [expr {[string length $v] -1}]]" : [string repeat " " [string length $v]] }]}}]
+ set msg "\n"
+ append msg "Unmatched\n"
+ append msg "Cannot match right hand side to pattern $multivar\n"
+ append msg "vars/atoms/etc: $var_names\n"
+ append msg "mismatches: [join $mismatches_display { } ]\n"
+ set i 0
+ #0 - novar
+ #1 - atom '
+ #2 - pin ^
+ #3 - boolean &
+ #4 - integer
+ #5 - double
+ #6 - var
+ #7 - glob (no classifier and contains * or ?)
+ foreach mismatchinfo $mismatches {
+ lassign $mismatchinfo status varname
+ if {$status eq "mismatch"} {
+ # varname can be empty string
+ set varclass [lindex $var_class $i 1]
+ set val [lindex $var_actions $i 2]
+ set e [dict get [lindex $expected_values $i] lhs]
+ set type ""
+ if {2 in $varclass} {
+ append type "pinned "
+ }
+
+ if {$varclass == 1} {
+ set type "atom"
+ } elseif {$varclass == 2} {
+ set type "pinned var"
+ } elseif {3 in $varclass} {
+ append type "boolean"
+ } elseif {4 in $varclass} {
+ append type "int"
+ } elseif {5 in $varclass} {
+ append type "double"
+ } elseif {$varclass == 6} {
+ set type "var"
+ } elseif {7 in $varclass} {
+ append type "glob"
+ } elseif {8 in $varclass} {
+ append type "numeric"
+ }
+ if {$type eq ""} {
+ set type ""
+ }
+
+ set lhs_tag "- [dict get [lindex $expected_values $i] info]"
+ set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range
+ set tag "?mismatch-"
+ if {[string match $tag* $mmaction]} {
+ set mismatch_reason [string range $mmaction [string length $tag] end]
+ } else {
+ set mismatch_reason $mmaction
+ }
+ append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n"
+ }
+ incr i
+ }
+ #error $msg
+ dict unset returndict result
+ #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*"
+ dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data]
+ return $returndict
+ }
+
+ if {![llength $var_names]} {
+ #var_name entries can be blank - but it will still be a list
+ #JMN2
+ #dict set returndict result [list $data]
+ dict set returndict result $data
+ } else {
+ assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]}
+ dict set returndict result $returnval
+ }
+ return $returndict
+ }
+
+ ########################################################
+ # dragons.
+ # using an error as out-of-band way to signal mismatch is the easiest.
+ # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up)
+ # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right.
+ # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch!
+ # A proper solution may involve a callback? tailcall some_mismatch_func?
+ # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ??
+ # make sure there is good test coverage before experimenting with this
+ proc _handle_bind_result {d} {
+ #set match_caller [info level 2]
+ #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9
+ if {![dict exists $d result]} {
+ #uplevel 1 [list error [dict get $d mismatch]]
+ #error [dict get $d mismatch]
+ return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch]
+ } else {
+ return [dict get $d result]
+ }
+ }
+ # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch
+ proc _handle_bind_result_experimental1 {d} {
+ #set match_caller [info level 2]
+ #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9
+ if {![dict exists $d result]} {
+ tailcall return [dict get $d mismatch]
+ } else {
+ return [dict get $d result]
+ }
+ }
+ ########################################################
+
+ #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions.
+ #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]'
+ #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first.
+ #proc listset1 {listvarname args} {
+ # tailcall set $listvarname $args
+ #}
+ #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}}
+ #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}}
+ proc pipeset {pipevarname args} {
+ upvar $pipevarname the_pipe
+ set the_pipe $args
+ }
+
+ #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created
+ proc pipealias {targetcmd args} {
+ set cmdcopy [punk::objclone $args]
+ set nscaller [uplevel 1 [list namespace current]]
+ tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller]
+ }
+ proc pipealias_extract {targetcmd} {
+ set applybody [lindex [interp alias "" $targetcmd] 1 1]
+ #strip off trailing " {*}$args"
+ return [lrange [string range $applybody 0 end-9] 0 end]
+ }
+ #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower
+ proc pipealias2 {targetcmd args} {
+ set cmdcopy [punk::objclone $args]
+ set nscaller [uplevel 1 [list namespace current]]
+ tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller]
+ }
+
+
+ #same as used in unknown func for initial launch
+ #variable re_assign {^([^\r\n=\{]*)=(.*)}
+ #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)}
+ variable re_assign {^([^ \t\r\n=\{]*)=(.*)}
+ variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)}
+ #match_assign is tailcalled from unknown - uplevel 1 gets to caller level
+ proc match_assign {scopepattern equalsrhs args} {
+ #review - :: is legal in atoms!
+ if {[string match "*::*" $scopepattern]} {
+ error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid."
+ }
+ #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args"
+ set fulltail $args
+ set cmdns ::punk::pipecmds
+ set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs]
+
+ #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW
+ #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace))
+
+ set pipecmd ${cmdns}::$scopepattern=$namemapping
+
+ #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results.
+ if {$pipecmd in [info commands $pipecmd]} {
+ #puts "==nscaller: '[uplevel 1 [list namespace current]]'"
+ #uplevel 1 [list ::namespace import $pipecmd]
+ set existing_path [uplevel 1 [list ::namespace path]]
+ if {$cmdns ni $existing_path} {
+ uplevel 1 [list ::namespace path [concat $existing_path $cmdns]]
+ }
+ tailcall $pipecmd {*}$args
+ }
+
+
+ #NOTE:
+ #we need to ensure for case:
+ #= x=y
+ #that the second arg is treated as a raw value - never a pipeline command
+
+ #equalsrhs is set if there is a segment-insertion-pattern *directly* after the =
+ #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4
+ #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data.
+
+ # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c
+ #
+ #to assign an entire pipeline to a var - use pipeset varname instead.
+
+ # in our script's handling of args:
+ #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists
+ #same with lsearch with a string pattern -
+ #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps
+ set script [string map [list $scopepattern $equalsrhs] {
+ #script built by punk::match_assign
+ if {[llength $args]} {
+ #scan for existence of any pipe operator (|*> or <*|) only - we don't need position
+ #all pipe operators must be a single element
+ #we don't first check llength args == 1 because for example:
+ # x= <|
+ # x= |>
+ #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>)
+ foreach a $args {
+ if {![catch {llength $a} sublen]} {
+ #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >}
+ if {[string match |*> $a] || [string match <*| $a]} {
+ tailcall punk::pipeline = "" "" {*}$args
+ }
+ }
+ }
+ if {[llength $args] == 1} {
+ set segmenttail [lindex $args 0]
+ } else {
+ error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =]
+ }
+ } else {
+ #set segmenttail [purelist]
+ set segmenttail [lreplace x 0 0]
+ }
+ }]
+
+
+
+
+ if {[string length $equalsrhs]} {
+ # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax.
+ # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose.
+ # We are probably only here if testing in the repl - in which case the error messages are important.
+ set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs]
+ #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok"
+ # x='ok'>0/0 data
+ # => {ok data}
+ # we won't examine for vars as there is no pipeline - ignore
+ # also ignore trailing * (indicator for variable data to be expanded or not - ie {*})
+ # we will differentiate between / and @ in the same way that general pattern matching works.
+ # /x will simply call linsert without reference to length of list
+ # @x will check for out of bounds
+ #
+ # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly?
+
+
+
+ foreach v_pos $var_index_position_list {
+ lassign $v_pos v indexspec positionspec
+ #e.g =v1/1>0 A pattern predator system)
+ #
+ #todo - review
+ #
+ #
+ #for now - the script only needs to handle the case of a single segment pipeline (no |> <|)
+
+
+ #temp - needs_insertion
+ #we can safely output no script for variable insertions for now - because if there was data available,
+ #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway.
+ #tag: positionspechandler
+ if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} {
+ #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense
+ #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0"
+ #review
+ if {[string length $indexspec]} {
+ error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal]
+ }
+ if {[string index $v 0] eq "'" && [string index $v end] eq "'"} {
+ set datasource [string range $v 1 end-1]
+ } elseif {[string is integer -strict $v]} {
+ set datasource $v
+ }
+ append script [string map [list $datasource] {
+ set insertion_data "" ;#atom could have whitespace
+ }]
+
+ set needs_insertion 1
+ } elseif {$v eq ""} {
+ #default variable is 'data'
+ set needs_insertion 0
+ } else {
+ append script [string map [list $v] {
+ #uplevel?
+ #set insertion_data [set ]
+ }]
+ set needs_insertion 0
+ }
+ if {$needs_insertion} {
+ set script2 [punk::list_insertion_script $positionspec segmenttail ]
+ set script2 [string map [list "\$insertion_data" ] $script2]
+ append script $script2
+ }
+
+
+ }
+
+
+ }
+
+ if {![string length $scopepattern]} {
+ append script {
+ return $segmenttail
+ }
+ } else {
+ append script [string map [list $scopepattern] {
+ #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail
+ set d [punk::_multi_bind_result {} $segmenttail]
+ #return [punk::_handle_bind_result $d]
+ #maintenance: inlined
+ if {![dict exists $d result]} {
+ #uplevel 1 [list error [dict get $d mismatch]]
+ #error [dict get $d mismatch]
+ return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch]
+ } else {
+ return [dict get $d result]
+ }
+ }]
+ }
+
+ debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2
+ uplevel 1 [list ::proc $pipecmd args $script]
+ set existing_path [uplevel 1 [list ::namespace path]]
+ if {$cmdns ni $existing_path} {
+ uplevel 1 [list ::namespace path [concat $existing_path $cmdns]]
+ }
+ tailcall $pipecmd {*}$args
+ }
+
+ #return a script for inserting data into listvar
+ #review - needs updating for list-return semantics of patterns?
+ proc list_insertion_script {keyspec listvar {data }} {
+ set positionspec [string trimright $keyspec "*"]
+ set do_expand [expr {[string index $keyspec end] eq "*"}]
+ if {$do_expand} {
+ set exp {{*}}
+ } else {
+ set exp ""
+ }
+ #NOTE: linsert and lreplace can take multiple values at tail ie expanded data
+
+ set ptype [string index $positionspec 0]
+ if {$ptype in [list @ /]} {
+ set index [string range $positionspec 1 end]
+ } else {
+ #the / is optional (default) at first position - and we have already discarded the ">"
+ set ptype "/"
+ set index $positionspec
+ }
+ #puts stderr ">> >> $index"
+ set script ""
+ set isint [string is integer -strict $index]
+ if {$index eq "."} {
+ #do nothing - this char signifies no insertion
+ } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} {
+ if {$ptype eq "@"} {
+ #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index)
+ if {$isint} {
+ append script [string map [list $listvar $index] {
+ if {( > [llength $])} {
+ #not a pipesyntax error
+ error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds]
+ }
+ }]
+ }
+ #todo check end-x bounds?
+ }
+ if {$isint} {
+ append script [string map [list $listvar $index $exp $data] {
+ set [linsert [lindex [list $ [unset ]] 0] ]
+ }]
+ } else {
+ append script [string map [list $listvar