71 changed files with 3720 additions and 851 deletions
@ -0,0 +1,166 @@
|
||||
# AGENTS.md |
||||
|
||||
Agent handbook for the ShellSpy (Punk Shell) repository. These guidelines cover builds, linting, testing, code style, and day-to-day conventions for all contributors and agentic assistants. Always check for nested `AGENTS.md` files before editing subdirectories—this root spec applies repo-wide unless overridden deeper in the tree. |
||||
|
||||
## Quickstart Checklist |
||||
- Confirm Windows-friendly Tcl toolchain (8.6+ required, 9.0 supported). |
||||
- Run `tclsh make.tcl` once after cloning to populate generated assets. |
||||
- Keep edits within the scoped instructions of any nested `AGENTS.md`. |
||||
- Use `tclint` before submitting code to align formatting and structure. |
||||
- Execute at least one relevant test script (`tclsh scriptlib/tests/<file>.tcl`). |
||||
- Document changes impacting build, tooling, or developer workflow. |
||||
|
||||
## Build & Bootstrap Commands |
||||
- **Primary build**: `tclsh make.tcl` (Windows default) or `punk make.tcl` inside Punk shell. |
||||
- **Alt entry point**: `punk build.tcl` or `tclsh build.tcl` for kettle-style builds. |
||||
- **Bootstrap shell**: `pmix KettleShell` from inside Punk shell for advanced packaging tasks. |
||||
- **Clean/resync**: Remove `build/` artifacts then rerun `tclsh make.tcl`; avoid partial cleans that break boot modules. |
||||
- **Binary images**: Use `punk make.tcl --target <name>` when producing platform-specific bundles (see script comments for targets). |
||||
|
||||
## Testing Strategy |
||||
- **Test location**: `scriptlib/tests/` holds all Tcl test scripts; keep new tests there. |
||||
- **Run entire suite**: Iterate with `for /r scriptlib\tests %f in (*.tcl) do tclsh %f` (Windows) or a similar shell loop on POSIX. |
||||
- **Run single test**: `tclsh scriptlib/tests/<test_name>.tcl` (e.g., `tclsh scriptlib/tests/json.tcl`). |
||||
- **Focused verification**: Mirror production pipelines inside tests using Punk pipeline syntax for parity. |
||||
- **Test dependencies**: Every test must `package require punk`; declare extra packages explicitly to avoid hidden dependencies. |
||||
- **Failure triage**: Capture stderr logs; prefer `try/on error` blocks inside tests for clearer diagnostics. |
||||
|
||||
## Linting & Formatting |
||||
- **Command**: `tclint` (configured via `tclint.toml` in repo root). |
||||
- **Files covered**: `.tcl`, `.tm`, `.sdc`; extend config if new extensions appear. |
||||
- **Line length**: Hard cap at 400 characters; wrap pipelines thoughtfully instead of exceeding. |
||||
- **Blank lines**: No more than 10 consecutive blanks. |
||||
- **Indentation**: 4 spaces; tabs are disallowed in Tcl sources except inside string literals. |
||||
- **Auto-fixes**: Run `tclint --fix` only when you have reviewed the resulting diff. |
||||
|
||||
## Toolchain & Dependencies |
||||
- Prefer the provided vendor modules under `src/vendor*` before fetching new dependencies. |
||||
- Use `tcl::tm::path add <dir>` to surface project modules when writing new tooling. |
||||
- Keep compatibility with Tcl 8.6+; gate 9.0-specific features behind version checks. |
||||
- When optional compiled extensions (e.g., `twapi`, `tdom`) are necessary, guard `package require` calls with fallback messaging. |
||||
|
||||
## Repository Layout Primer |
||||
``` |
||||
src/ |
||||
bootsupport/modules/ # Early-load modules with minimal deps |
||||
modules/ # Main Punk modules (.tm) |
||||
lib/ # Classic Tcl libraries |
||||
scriptapps/ # Entry-point scripts for Punk apps |
||||
vendormodules*/ # Third-party modules bundled with repo |
||||
scriptlib/ # Shared utilities + tests |
||||
bin/ # Helper binaries/scripts |
||||
callbacks/, plugj.tcl, etc # Integration glue for host environments |
||||
src/vfs/* # Virtual file system images for builds |
||||
``` |
||||
Treat VFS directories as generated artifacts; edit them only when updating runtime payloads. |
||||
|
||||
## Imports & Package Management |
||||
- Always declare dependencies explicitly using `package require <name>` near file tops. |
||||
- Prefer fully-qualified namespaces when referencing external packages (`package require tcl::zlib`, `package require TclOO`). |
||||
- Organize custom modules as `namespace eval punk::<segment>` with filenames like `src/modules/punk/<segment>-<version>.tm`. |
||||
- Use semantic versions that `package vcompare` can interpret; strip leading zeros. |
||||
- For optional features, probe with `if {[catch {package require foo}]} { ... }` and degrade gracefully. |
||||
|
||||
## Formatting & Layout Rules |
||||
- Opening braces stay on the same line for procs; multiline control structures may place braces on new lines for readability. |
||||
- Align continuations under their opening command; use explicit `\` when mapping to pipeline syntax is unclear. |
||||
- Keep pipelines readable by aligning `% var = ...` and `pipecase` segments vertically when possible. |
||||
- Document non-trivial procedures and exports with the standard header template (see below). |
||||
|
||||
## Naming Conventions |
||||
- **Procedures**: `lowercase_with_underscores` for internals, `camelCase` allowed for public APIs where existing patterns fit. |
||||
- **Variables**: `lowercase_with_underscores`; avoid single-letter names except for loop indices. |
||||
- **Namespaces**: Mirror directory structure; nested modules should reflect filesystem hierarchy. |
||||
- **Private helpers**: Prefix with `_` (e.g., `_resolve_stream`); do not export them. |
||||
- **Constants**: `UPPER_CASE_WITH_UNDERSCORES` declared via `namespace eval { variable CONSTANT value }` when practical. |
||||
|
||||
## Procedure Documentation Template |
||||
```tcl |
||||
# <Procedure summary> |
||||
# Args: |
||||
# arg1 - description |
||||
# arg2 - description |
||||
# Returns: |
||||
# Description of return value |
||||
proc procedure_name {arg1 arg2} { |
||||
# Implementation |
||||
} |
||||
``` |
||||
Update the template with concrete details whenever functions are user-facing or complex. |
||||
|
||||
## Error Handling & Logging |
||||
- Prefer `try { ... } on error {result options} { ... }` (Tcl 8.6+) for structured handling. |
||||
- Fallback pattern: |
||||
```tcl |
||||
if {[catch {some_command} result]} { |
||||
puts stderr "Error: $result" |
||||
return -code error $result |
||||
} |
||||
``` |
||||
- For Punk pipelines, wrap risky commands inside `pipecase` blocks and emit descriptive messages via `puts stderr` or Punk logging helpers. |
||||
- Never swallow errors silently; propagate with context so shell users see actionable details. |
||||
|
||||
## Pipeline & Functional Style Notes |
||||
- Use `% var = ...` bindings to capture intermediate values; keep names meaningful. |
||||
- `pipecase` should list specific patterns before catch-alls to avoid hidden matches. |
||||
- `fun name pattern { ... }` definitions should remain side-effect light; treat them as pure functions unless otherwise documented. |
||||
- Keep pipelines short and composable; extract into helper procs or `fun` definitions when they exceed ~10 logical steps. |
||||
|
||||
## Module Structure Expectations |
||||
```tcl |
||||
# Module description |
||||
package require <dependencies> |
||||
|
||||
namespace eval <module_namespace> { |
||||
variable version <semver> |
||||
namespace export public_proc1 public_proc2 |
||||
|
||||
proc public_proc1 {args} { |
||||
# Implementation |
||||
} |
||||
|
||||
proc _private_helper {} { |
||||
# Private implementation |
||||
} |
||||
} |
||||
``` |
||||
Ensure module filenames include the version (`punk/console-0.1.1.tm`), and keep `namespace export` lists alphabetized for clarity. |
||||
|
||||
## Type & Data Handling |
||||
- Tcl is dynamically typed; emulate structural typing via argument validation at proc boundaries. |
||||
- Validate user inputs with `switch -exact`, `regexp`, or Punk pipeline predicates before mutation. |
||||
- Use dictionaries for structured data; avoid parallel lists. |
||||
- When bridging to binary data (e.g., ANSI/xbin parsing), document expected encodings and conversions. |
||||
|
||||
## Versioning & Releases |
||||
- Stick to semantic versioning (`major.minor.patch`). |
||||
- When referencing ranges, use bounded specs (e.g., `1.2.3-2.0.0`). |
||||
- Convert loose versions to bounded form in module metadata; helper utilities exist in boot modules for this purpose. |
||||
- Update `punk::libunknown` registries whenever adding/removing modules to keep discovery accurate. |
||||
|
||||
## Platform & Performance Notes |
||||
- Primary target: Windows (win32-x86_64). Validate code paths that rely on Windows-only packages. |
||||
- Secondary targets: Linux/macOS/FreeBSD; guard platform-specific calls with `if {$tcl_platform(os) eq "Windows"} {...}`. |
||||
- Favor compiled extensions (tcllibc, twapi) when available, but always provide scripted fallbacks. |
||||
- Be mindful of long-running pipelines; chunk work and avoid blocking the Punk shell UI thread. |
||||
|
||||
## Documentation & Comments |
||||
- Keep inline comments concise; describe intent, not mechanics. |
||||
- Update any relevant docs or usage notes in `scriptapps` when behavior changes. |
||||
- Mention environment variables or flags required to run new features. |
||||
|
||||
## Agent Workflow Tips |
||||
- No `.cursor/rules/`, `.cursorrules`, or `.github/copilot-instructions.md` files exist as of this update. If they appear later, integrate their instructions here. |
||||
- Always re-run `tclint` and the most specific test affected by your changes before committing. |
||||
- When touching VFS payloads, describe regeneration steps inside commit messages and this guide if persistent. |
||||
- Favor incremental commits tied to logical units of work; avoid monolithic diffs mixing tooling and feature changes. |
||||
|
||||
## Final Submission Checklist |
||||
- [ ] Nested `AGENTS.md` files checked for scope-specific rules. |
||||
- [ ] `tcllint` (and `tcllint --fix` if needed) executed with clean results. |
||||
- [ ] Relevant tests (`tclsh scriptlib/tests/<file>.tcl`) executed and passing. |
||||
- [ ] Build step (`tclsh make.tcl`) verified when touching build-critical code. |
||||
- [ ] Documentation/comments updated for new behavior or flags. |
||||
- [ ] Diffs reviewed to ensure no stray whitespace or debugging output remains. |
||||
|
||||
Adhering to these conventions keeps the ShellSpy/Punk Shell ecosystem consistent, portable, and friendly for future agentic collaborators. Happy hacking! |
||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,139 @@
|
||||
-*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# 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) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application %pkg% 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
tcl::namespace::eval %pkg% { |
||||
variable PUNKARGS |
||||
variable pkg %pkg% |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
|
||||
package require packagetest |
||||
packagetest::makeAPI %pkg% $version %pkgunprefixed%; #will package provide %pkg% $version |
||||
package forget %pkgunprefixed% |
||||
package require %pkgunprefixed% |
||||
} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval %pkg% { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)%pkg%" |
||||
@package -name "%pkg%" -help\ |
||||
"Test suites for %pkgunprefixed% module" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return %pkg% |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package %pkg% |
||||
test suite for %pkgunprefixed% module |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::%pkg%::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com> Julian Noble}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::%pkg%::about" |
||||
dict set overrides @cmd -name "%pkg%::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About %pkg% module |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[%pkg%::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [%pkg%::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::%pkg%::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::%pkg%::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::%pkg% |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
package provide %pkg% [tcl::namespace::eval %pkg% { |
||||
variable pkg %pkg% |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
## Ready |
||||
return |
||||
@ -0,0 +1,365 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||
# |
||||
# 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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::net::vxlan 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::net::vxlan { |
||||
variable PUNKARGS |
||||
|
||||
#todo - ipv6 - rename functions ipv4_vni_to_mcast ipv6_vni_to_mcast etc? |
||||
#IPv6 uses FF00::/8 |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::net::vxlan::vni_to_mcast" |
||||
@cmd -name "punk::net::vxlan::vni_to_mcast" -help\ |
||||
"Map a VXLAN VNI to a unique multicast address. |
||||
|
||||
The entire IPv4 multicast range is 224.0.0.0 - 239.255.255.255, |
||||
The upper end 239.0.0.0 - 239.255.255.255 is classified by |
||||
IANA as 'administratively scoped' (RFC 2365). |
||||
|
||||
The 239.0.0.0/8 range is 24 bits and *may* be available for VXLANs. |
||||
vni_to_mcast will map the VNI into an address in this /8 range. |
||||
|
||||
The range 239.192.0.0/14 is defined by RFC 2365 to be the |
||||
'IPv4 Organization Local Scope' and it may be desirable to use |
||||
mappings that fall only within this range. |
||||
|
||||
Some vendors put restrictions on acceptable VNI values e.g |
||||
Cisco supports VNI values from 4096 to 16,777,215. |
||||
|
||||
2 ranges within 239.0.0.0/8 are best avoided if it is desired |
||||
to reduce flooding by layer 2 switches and possible additional |
||||
processor load at VTEPs. |
||||
These are: |
||||
239.0.0.0/24 (VNI 0 - 255) |
||||
and |
||||
239.128.0.0/24 (VNI 8388608 - 8388863) |
||||
These happen to map to the same MAC address range (01:00:5e:00:00:xx) |
||||
as multicast addresses in the Link-Local Block (224.0.0.0/24) |
||||
These are commonly flooded to all ports on the switch even when IGMP |
||||
snooping is enabled (protocols such as OSPF would break if such flooding |
||||
wasn't done, as IGMP Membership Reports are normally not sent for multicast |
||||
traffic in the Link-Local Block). |
||||
" |
||||
@leaders -min 0 -max 0 |
||||
@opts -min 0 -max 0 |
||||
@values -min 1 -max 1 |
||||
vni -type integer -range {0 16777215} -help\ |
||||
"Integer representing a 24 bit VNI" |
||||
}] |
||||
proc vni_to_mcast {vni} { |
||||
if {![string is integer -strict $vni] || $vni < 0 || $vni > (2**24-1)} { |
||||
error "vni_to_mcast: VNI must be a 24bit integer i.e the range is 0 to 16777215" |
||||
} |
||||
set hex6 [format %6.6llx $vni] |
||||
set mcast "239." |
||||
foreach {h1 h2} [split $hex6 ""] { |
||||
append mcast [scan $h1$h2 %llx] . |
||||
} |
||||
set mcast [string range $mcast 0 end-1] |
||||
return $mcast |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::net::vxlan::mcast_to_vni" |
||||
@cmd -name "punk::net::vxlan::mcast_to_vni" -help\ |
||||
"Return an integer VNI in the range 0 to 16777215" |
||||
@leaders -min 0 -max 0 |
||||
@opts -min 0 -max 0 |
||||
@values -min 1 -max 1 |
||||
mcastaddress -type string -help\ |
||||
"Multicast address within the 239.0.0.0/8 range. |
||||
See vni_to_mcast for notes about possible values |
||||
within the range to avoid." |
||||
}] |
||||
proc mcast_to_vni {mcastaddress} { |
||||
#todo - validate ipv4 |
||||
set addrparts [split $mcastaddress .] |
||||
set tailparts [lassign $addrparts p1] |
||||
if {$p1 ne "239"} { |
||||
error "mcast_to_vni: mcastaddress must be of the form 239.x.x.x" |
||||
} |
||||
#e.g mcastaddress: 239.188.97.78 |
||||
set hex "" |
||||
foreach tp $tailparts { |
||||
append hex [format %2.2llx $tp] |
||||
} |
||||
#e.g hex: bc614e |
||||
#e.g return: 12345678 |
||||
return [scan $hex %llx] |
||||
} |
||||
|
||||
#reference |
||||
#https://networklessons.com/multicast/multicast-ip-address-to-mac-address-mapping |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::net::vxlan::mcast_to_mac" |
||||
@cmd -name "punk::net::vxlan::mcast_to_mac" -help\ |
||||
"Return the MAC address this IPv4 multicast address |
||||
maps to. |
||||
Note that there will be a total of 32 addresses that |
||||
map to this same MAC address. |
||||
(see mac_to_mcast_list)" |
||||
@leaders -min 0 -max 0 |
||||
@opts -min 0 -max 0 |
||||
@values -min 1 -max 1 |
||||
mcastaddress -type string -help\ |
||||
"Multicast IPv4 address. |
||||
224.0.0.0 to 239.255.255.255 |
||||
(224.0.0.0/4" |
||||
}] |
||||
proc mcast_to_mac {mcastaddress} { |
||||
set mac "01:00:5e:" ;#prefix for IANA reserved OUI covering the first 24 bits of 48bit mac address |
||||
#we can only use the last 23 bits from the mcastaddress |
||||
set addrparts [split $mcastaddress .] |
||||
set tailbin "" ;#binary representation of last 3 dotted parts |
||||
set p1 [lindex $addrparts 0] |
||||
if {$p1 < 224 || $p1 > 239} { |
||||
error "mcast_to_mac: address $mcastaddress does not seem to be an IPv4 multicast address" |
||||
} |
||||
foreach p [lrange $addrparts 1 end] { |
||||
append tailbin [format %8.8b $p] |
||||
} |
||||
# |
||||
set last23bits [string range $tailbin 1 end] |
||||
set tailbits "0$last23bits" |
||||
foreach {b0 b1 b2 b3 b4 b5 b6 b7} [split $tailbits ""] { |
||||
set nibble1 [scan $b0$b1$b2$b3 %b] |
||||
set nibble2 [scan $b4$b5$b6$b7 %b] |
||||
append mac "[format %x $nibble1][format %x $nibble2]:" |
||||
} |
||||
set mac [string range $mac 0 end-1] |
||||
#e.g mcastaddress: 224.132.6.17 |
||||
#result: 01:00:5e:04:06:11 |
||||
return $mac |
||||
} |
||||
#This is not a unique mapping there is 1:32 overlap |
||||
#because 5 bits are lost in the mapping |
||||
#ie there 32 multicast addresses mapping to the same mac |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::net::vxlan::mac_to_mcast_list" |
||||
@cmd -name "punk::net::vxlan::mac_to_mcast_list" -help\ |
||||
"Return a list of the 32 multicast IPv4 addresses that |
||||
correspond to a multicast MAC address. |
||||
This is not a unique mapping because 5 bits are lost in |
||||
the process. |
||||
If a host is on a network with a lot of multicast traffic in |
||||
groups that happen to overlap with the same multicast address to MAC |
||||
mapping - there may be some additional overhead in ignoring non-relevant |
||||
frames." |
||||
@leaders -min 0 -max 0 |
||||
@opts -min 0 -max 0 |
||||
@values -min 1 -max 1 |
||||
mac -type string -help\ |
||||
"Mac address in the form 01:00:5e:xx:xx:xx or 01005exxxxxx. |
||||
The prefix 01:00:5e is the IANA reserved OUI for multicast MAC addresses. |
||||
(upper case versions of hex are also accepted)" |
||||
}] |
||||
proc mac_to_mcast_list {mac} { |
||||
#e.g 01:00:5e:0b:01:02 or 01005e0b0101 |
||||
#set bin_OUI "00000010000000001011110" |
||||
if {[string is xdigit -strict $mac] && [string length $mac] == 12} { |
||||
set mac_oui [string range $mac 0 5] |
||||
set mactailhex [string range $mac 6 end] |
||||
} else { |
||||
if {[string first : $mac] >=0} { |
||||
set macparts [split $mac :] |
||||
if {[llength $macparts] != 6} { |
||||
error "mac_to_mcast_list: mac address must have 6 parts (48bit mac address)" |
||||
} |
||||
set mac_oui [join [lrange $macparts 0 2] ""] |
||||
set mactailhex [join [lrange $macparts 3 end] ""] |
||||
} else { |
||||
error "mac_to_mcast_list: mac address must be in the form 01:00:5e:xx:xx:xx or 01005exxxxxx" |
||||
} |
||||
} |
||||
if {![string match -nocase 01005e* $mac_oui]} { |
||||
error "mac_to_mcast_list: mac address must begin with the reserved OUI 01:00:5e (or 01005e) for multicast adddresses" |
||||
} |
||||
set bin_tail "" |
||||
catch { |
||||
foreach hexdigit [split $mactailhex ""] { |
||||
set dec [scan $hexdigit %llx] |
||||
append bin_tail [format %4.4b $dec] |
||||
} |
||||
} |
||||
set last23bits [string range $bin_tail 1 end] |
||||
if {[string length $last23bits] != 23} { |
||||
error "mac_to_mcast_list: failed to convert mac:$mac to binary - check it is a properly formatted mac address" |
||||
} |
||||
#consider bytes b0 b1 b2 b3 |
||||
#last 2 bytes (b2, b3) will be the same for each resulting address |
||||
set last16bits [string range $last23bits 7 end] |
||||
set b2 [string range $last16bits 0 7] |
||||
set b3 [string range $last16bits 8 end] |
||||
set a2 [scan $b2 %b] |
||||
set a3 [scan $b3 %b] |
||||
|
||||
set top7of23 [string range $last23bits 0 6] |
||||
#first 2 bytes are 1110xxxx xnnnnnnn where the 7 n bits are the first 7 of the 23bits used from the tail, giving 32 possible values |
||||
set mcast_list [list] |
||||
for {set i 0} {$i <=31} {incr i} { |
||||
set varbits [format %5.5b $i] |
||||
set first2bytesbin "1110$varbits$top7of23" |
||||
set b0 [string range $first2bytesbin 0 7] |
||||
set b1 [string range $first2bytesbin 8 end] |
||||
lappend mcast_list "[scan $b0 %b].[scan $b1 %b].$a2.$a3" |
||||
} |
||||
if {[llength $mcast_list] != 32} { |
||||
error "mac_to_mcast_list: failed to properly calculate the 32 corresponding multicast addresses (length [llength $mcast_list] should be 32)" |
||||
} |
||||
return $mcast_list |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::net::vxlan::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::net::vxlan::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::net::vxlan { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::net::vxlan" |
||||
@package -name "punk::net::vxlan" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::net::vxlan |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::net::vxlan |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::net::vxlan::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::net::vxlan::about" |
||||
dict set overrides @cmd -name "punk::net::vxlan::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::net::vxlan |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::net::vxlan::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::net::vxlan::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::net::vxlan::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::net::vxlan::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::net::vxlan |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::net::vxlan [tcl::namespace::eval punk::net::vxlan { |
||||
variable pkg punk::net::vxlan |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,14 @@
|
||||
# test module information |
||||
--- |
||||
subfolders (that don't begin with a # or _ character) within this test folder form part of the Tcl namespace of the resulting modules that are produced from running '<tclshbinary> src/make.tcl modules' |
||||
|
||||
The #modpod- folder for a module contain files that will stored in the final module's .tm file (zip based) which is built by make.tcl into the <projectroot>/modules/test folder (again with further subfolders depending on whether the module is namespaced) |
||||
|
||||
The final version of the built modules are determined from corresponding <tailname>-buildversion.txt files placed at the same level as the corresponding #modpod-<tailname>-999999.0a1.0 folder |
||||
|
||||
example: A final installed module <projectroot>/modules/test/foo/baz/foobazzer-1.1.tm corresponds to the tcl module test::foo::baz::foobazzer and will have its source tests and associated files in the folder <projectroot>/src/modules/test/foo/baz/#modpod-foobazzer-999999.0a1.0 with a corresponding version number file at <projectroot>/src/modules/test/foo/baz/foobazzer-buildversion.txt |
||||
|
||||
A new testmodule for a package can be generated from the template template_test built into the punk::mix::templates package which is referenced as 'punk.test' when creating a new module using the 'dev module.new' command. This command is an alias for punk::mix::commandset::module::new. |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,166 @@
|
||||
#!punk902testrunner shellspy |
||||
#This script uses shellfilter::run calls under the hood - which probably requires a built punkshell binary to function properly. |
||||
#(plain tclsh may stall - todo - review reasons for this and whether shellfilter can be modified to support ordinary tclsh) |
||||
#A known working copy of a punk shell executable should be placed on the path and the shebang line updated to reflect this |
||||
|
||||
|
||||
package require punk |
||||
package require punk::args |
||||
punk::args::define { |
||||
@id -id (script)::runtestmodules |
||||
@cmd -name runtestmodules -help\ |
||||
"Run test:: modules that support the packagetest api |
||||
(have RUN command)" |
||||
-tcltestoptions -type list -default "" -help\ |
||||
"arguments that will be left in ::argv for tcltest |
||||
to handle" |
||||
@values -min 0 -max -1 |
||||
glob -type string -multiple 1 -optional 1 -help\ |
||||
" names or glob patterns of test modules to run. |
||||
Note that this script will search for all modules |
||||
within the test namespace that are known to the |
||||
current interpreter - not just those within the |
||||
current project." |
||||
} |
||||
set argd [punk::args::parse $::argv withid (script)::runtestmodules] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set tcltestoptions [dict get $opts -tcltestoptions] |
||||
if {![dict exists $received glob]} { |
||||
set pkg_globs [list *] |
||||
} else { |
||||
set pkg_globs [dict get $values glob] |
||||
} |
||||
|
||||
set ::argv $tcltestoptions |
||||
set ::argc [llength $tcltestoptions] |
||||
|
||||
|
||||
#bogus require to ensure modules within path test have been scanned to be in Tcl's 'package ifneeded' in-memory database |
||||
catch {package require test::bogus666} |
||||
set tmlist [tcl::tm::list] |
||||
foreach tmfolder $tmlist { |
||||
set tfolder [file join $tmfolder test] |
||||
if {[file exists $tfolder]} { |
||||
puts stdout "checking tm test folder $tfolder" |
||||
set subfolders [glob -nocomplain -dir $tfolder -type d -tail *] |
||||
foreach sub $subfolders { |
||||
if {[string match #* $sub]} { |
||||
continue |
||||
} |
||||
puts stdout "bogus require of test::${sub}::bogus666" |
||||
catch {package require test::${sub}::bogus666} |
||||
} |
||||
} |
||||
} |
||||
set alltestpkgs [lsearch -all -inline [package names] test::*] |
||||
if {![llength $alltestpkgs]} { |
||||
puts stder "No packages matching test::* found" |
||||
exit 1 |
||||
} |
||||
if {[llength $pkg_globs] == 1 && [lindex $pkg_globs 0] eq "*"} { |
||||
set matchedtestpkgs $alltestpkgs |
||||
} else { |
||||
set matchedtestpkgs [list] |
||||
foreach pkg $alltestpkgs { |
||||
foreach g $pkg_globs { |
||||
if {[string match $g $pkg]} { |
||||
lappend matchedtestpkgs $pkg |
||||
break |
||||
} |
||||
} |
||||
} |
||||
} |
||||
if {![llength $matchedtestpkgs]} { |
||||
puts stderr "No test packages matched supplied glob patterns" |
||||
exit 1 |
||||
} |
||||
puts "matchedtestpkgs: $matchedtestpkgs" |
||||
set punktestpkgs [list] |
||||
foreach pkg $matchedtestpkgs { |
||||
if {![catch {package require $pkg}]} { |
||||
if {[info commands ::${pkg}::RUN] ne ""} { |
||||
lappend punktestpkgs $pkg |
||||
} |
||||
} else { |
||||
puts stderr "failed to load test package $pkg" |
||||
} |
||||
} |
||||
if {![llength $punktestpkgs]} { |
||||
puts stderr "No test packages with RUN command were able to be loaded" |
||||
exit 1 |
||||
} |
||||
set scriptname [file tail [info script]] |
||||
set results [dict create] |
||||
dict set results total 0 |
||||
dict set results passed 0 |
||||
dict set results skipped 0 |
||||
dict set results failed 0 |
||||
set pkgs_with_fails [list] |
||||
set pkgs_without_fails [list] |
||||
package require shellrun |
||||
puts "running tests in [llength $punktestpkgs] packages $punktestpkgs" |
||||
flush stderr |
||||
flush stdout |
||||
package require punk::ansi |
||||
foreach pkg $punktestpkgs { |
||||
puts stdout "running test pkg $pkg" |
||||
if {[catch { |
||||
#set result [shellrun::runout -tcl ${pkg}::RUN] |
||||
set result [shellrun::runx -tcl ${pkg}::RUN] |
||||
#set result [shellrun::runx ls] |
||||
} errM]} { |
||||
puts stderr "error calling 'runout -tcl ${pkg}::RUN' $errM"; flush stderr |
||||
set result {none ""} |
||||
} |
||||
puts stdout "executed ${pkg}::RUN" |
||||
flush stdout |
||||
set i 0 |
||||
dict for {what chunk} $result { |
||||
set chunk [string map [list \r\n \n] $chunk] |
||||
switch -- $what { |
||||
stdout { |
||||
foreach ln [split $chunk \n] { |
||||
incr i |
||||
if {[string match "Tests ended at*" $ln]} { |
||||
puts stdout "<stdout> [punk::ansi::ansistring VIEW -lf 2 -cr 1 "$pkg $ln"]" |
||||
} elseif {[string match "*:*Total*Passed*Skipped*Failed*" $ln]} { |
||||
set fields [lrange $ln 1 end] |
||||
dict for {K v} $fields { |
||||
set k [string tolower $K] |
||||
dict incr results $k $v |
||||
if {$k eq "failed"} { |
||||
if {$v == 0} { |
||||
lappend pkgs_without_fails $pkg |
||||
} elseif {$v > 0} { |
||||
lappend pkgs_with_fails $pkg |
||||
} |
||||
} |
||||
} |
||||
puts stdout "<stdout>$pkg $ln" |
||||
} else { |
||||
puts stdout "<stdout> $ln" |
||||
#puts stdout "$i" |
||||
} |
||||
} |
||||
flush stdout |
||||
} |
||||
stderr { |
||||
puts stderr "<stderr> [punk::ansi::ansistring VIEW -lf 2 -cr 1 $chunk]" |
||||
flush stderr |
||||
} |
||||
default { |
||||
puts stderr "<${what}> $chunk" |
||||
flush stderr |
||||
} |
||||
} |
||||
} |
||||
puts stdout "completed pkg test ${pkg}" |
||||
} |
||||
puts stdout "packages without failures: $pkgs_without_fails" |
||||
puts stdout "packages with failures: $pkgs_with_fails" |
||||
puts stdout "results: Total [dict get $results total] Passed [dict get $results passed] Skipped [dict get $results skipped] Failed [dict get $results failed]" |
||||
#after 5000 {set ::done true} |
||||
#vwait ::done |
||||
puts stdout "DONE" |
||||
#exit 0 |
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -0,0 +1,326 @@
|
||||
package provide pattern::IPatternBuilder 2.0 |
||||
|
||||
#Definition of pattern interface with interface ID 'PatternBuilder' |
||||
#Execution context: pp::Obj${OID}::_meta namespace (varspace _meta) |
||||
|
||||
namespace eval pattern { |
||||
} |
||||
|
||||
package require TclOO |
||||
|
||||
oo::class create ::pattern::IPatternBuilder |
||||
oo::define ::pattern::IPatternBuilder { |
||||
variable o_OID |
||||
} |
||||
|
||||
oo::define ::pattern::IPatternBuilder method ID {} { |
||||
my variable o_OID |
||||
puts "IPatternBuilder returning id $o_OID" |
||||
return $o_OID |
||||
} |
||||
oo::define ::pattern::IPatternBuilder method do {script} { |
||||
eval $script |
||||
} |
||||
oo::define ::pattern::IPatternBuilder method test {} { |
||||
return [my ID] |
||||
} |
||||
oo::define ::pattern::IPatternBuilder method test2 {} { |
||||
return [my PatternBuilder.ID] |
||||
} |
||||
oo::define ::pattern::IPatternBuilder method test3 {} { |
||||
return "info level 0 = \[[info level 0]\]" |
||||
} |
||||
|
||||
oo::define ::pattern::IPatternBuilder forward test4 my API(varspace_meta)getmap |
||||
|
||||
#gather all varspaces from interfaces on this object |
||||
oo::define ::pattern::IPatternBuilder method (GET)Varspaces {} { |
||||
my variable o_OID |
||||
#set builtin_varspaces [list _ref _meta _main _iface _apimanager] |
||||
set raw_nslist [namespace children ::pp::Obj${o_OID}] |
||||
set spaces [list] |
||||
foreach ns $raw_nslist { |
||||
lappend spaces [namespace tail $ns] |
||||
} |
||||
return [concat main $spaces] |
||||
} |
||||
|
||||
#gather all varspaces from patterns |
||||
oo::define ::pattern::IPatternBuilder method (GET)PatternVarspaces {} { |
||||
|
||||
} |
||||
|
||||
|
||||
oo::define ::pattern::IPatternBuilder method Constructor {arglist body} { |
||||
my variable o_OID _ID_ o_pattern_apis o_interface_default_api |
||||
set invocants [dict get $_ID_ i] |
||||
|
||||
set apiname [set ::pp::Obj${o_OID}::_meta::o_interface_default_api] |
||||
|
||||
set istack [dict get $o_pattern_apis $apiname] |
||||
|
||||
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 [::pp::>interface .. Create ::pp::ifaces::>$iid_top [set usedby [list $OID]] ] |
||||
|
||||
dict set o_pattern_apis $apiname [concat $patterns $iid_top] |
||||
} |
||||
set IID $iid_top |
||||
|
||||
namespace upvar ::pp::Obj${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace |
||||
|
||||
|
||||
# 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 explicitvars]]} { |
||||
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 @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 body [string map [::list @OID@ "\[dict get \[lindex \[dict get \$_ID_ i this\] 0\] id\]" @this@ "\[dict get \[lindex \[dict get \$_ID_ i this\] 0\] id\]" @next@ error] $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 |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
oo::define ::pattern::IPatternBuilder method Method {method arglist bodydef args} { |
||||
my variable o_OID _ID_ |
||||
|
||||
set invocants [dict get $_ID_ i] |
||||
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') |
||||
|
||||
set IID [::pp::predator::get_possibly_new_open_interface $o_OID] |
||||
|
||||
error "unimplemented" |
||||
|
||||
} |
||||
|
||||
oo::define ::pattern::IPatternBuilder method INFO {INVOCANTS} { |
||||
my variable _ID_ o_interface_apis o_pattern_apis o_invocantrecord o_interface_default_api o_pattern_default_api |
||||
|
||||
puts stderr "\tINVOCANTS:$INVOCANTS\n" |
||||
puts stderr "\t[info level 0]\n" |
||||
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] |
||||
set OID [dict get $member id] |
||||
append result "\t\tOID: $OID\n" |
||||
#lassign $o_invocantrecord _OID namespace default_method cmd _wrapped |
||||
dict update o_invocantrecord id _OID ns namespace defaultmethod default_method object cmd {} |
||||
append result "\t\tNamespace: $namespace\n" |
||||
append result "\t\tDefault method: $default_method\n" |
||||
append result "\t\tCommand: $cmd\n" |
||||
append result "\t\tClass: [info object class $cmd]\n" |
||||
|
||||
append result "\t\tDefault API: $o_interface_default_api\n" |
||||
append result "\t\tinterface apis: \n" |
||||
foreach key [dict keys $o_interface_apis] { |
||||
append result "\t\t\tapi:'$key'\n" |
||||
append result "\t\t\t\t[dict get $o_interface_apis $key]\n" |
||||
} |
||||
#append result "\t\tDefault pattern API: $o_pattern_default_api\n" |
||||
append result "\t\tpattern apis: \n" |
||||
foreach key [dict keys $o_pattern_apis] { |
||||
append result "\t\t\tapi:'$key'\n" |
||||
append result "\t\t\t\t[dict get $o_pattern_apis $key]\n" |
||||
} |
||||
|
||||
} |
||||
append result "\n" |
||||
append result "\t-------------------------------\n" |
||||
} |
||||
|
||||
|
||||
|
||||
return $result |
||||
} |
||||
|
||||
oo::define ::pattern::IPatternBuilder method IFINFO {{api "default"}} { |
||||
my variable _ID_ o_OID o_interface_apis o_pattern_apis o_interface_default_api |
||||
if {$api eq "default"} { |
||||
set api $o_interface_default_api} |
||||
|
||||
if {$api eq "*"} { |
||||
set apilist [dict keys $o_interface_apis] |
||||
} else { |
||||
set apilist [list $api] |
||||
} |
||||
|
||||
puts stderr "\t _ID_ --$_ID_--" |
||||
set invocants [dict get $_ID_ i] |
||||
|
||||
foreach a $apilist { |
||||
puts stderr "\t------------------------------\n" |
||||
puts stderr "\t API:'$a'\n" |
||||
puts stderr "\t------------------------------\n" |
||||
set interfaces [dict get $o_interface_apis $a] |
||||
set IFID [lindex $interfaces 0] |
||||
if {![llength $interfaces]} { |
||||
puts stderr "No interfaces present for api:'$a'" |
||||
} else { |
||||
foreach IFID $interfaces { |
||||
set iface ::pp::ifaces::>$IFID |
||||
puts stderr "$iface : [$iface --]" |
||||
puts stderr "\tis open: [set ::pp::I${IFID}::_iface::o_open]" |
||||
set variables [set ::pp::I${IFID}::_iface::o_variables] |
||||
puts stderr "\tvariables: $variables" |
||||
} |
||||
} |
||||
puts stderr "\t------------------------------\n" |
||||
} |
||||
} |
||||
|
||||
|
||||
oo::define ::pattern::IPatternBuilder method Create {target_spec args} { |
||||
my variable _ID_ o_OID o_invocantrecord o_interface_apis o_pattern_apis o_interface_default_api |
||||
set invocants [dict get $_ID_ i] |
||||
set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) |
||||
|
||||
set api $o_interface_default_api |
||||
lassign $o_invocantrecord o_OID parent_ns parent_defaultmethod parent_object_command |
||||
set interfaces [dict get $o_interface_apis $api] ;#level-0 interfaces |
||||
set patterns [dict get $o_pattern_apis $api] ;#level-1 interfaces |
||||
|
||||
#set parent_patterndefaultmethod [dict get $map patterndata patterndefaultmethod] |
||||
|
||||
#todo - change to dict of interface stacks |
||||
set IFID0 [lindex $interfaces 0] |
||||
set IFID1 [lindex $patterns 0] ;#1st pattern |
||||
|
||||
if {[llength $target_spec] ==1} { |
||||
set child $target_spec |
||||
set targets [list $child {}] |
||||
} else { |
||||
set targets $target_spec |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set target_objects [list] |
||||
foreach child [dict keys $targets] { |
||||
set target_spec_dict [dict get $targets $child] |
||||
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] >] |
||||
|
||||
#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 $parent_object_command when creating $child" |
||||
set patterns [list [set iid [::pp::get_new_object_id]]] |
||||
lappend new_interfaces [::pp::func::new_object ::pp::ifaces::>$iid $iid] |
||||
} |
||||
|
||||
if {![llength [info commands $child]]} { |
||||
#usual case - target/child does not exist |
||||
set is_new_object 1 |
||||
if {[dict exists $target_spec_dict -id]} { |
||||
::pp::func::new_object $child [dict get $target_spec_dict -id] |
||||
} else { |
||||
::pp::func::new_object $child |
||||
} |
||||
set child_ID [$child ## varspace_meta . ID] |
||||
#set childmapdata [set ::pp::Obj${child_ID}::_meta::map] |
||||
#upvar #0 ::pp::Obj${child_ID}::_meta::map CHILDMAP |
||||
|
||||
$child ## varspace_meta . (SET)interfaces $patterns |
||||
|
||||
set ifaces_added $patterns |
||||
} else { |
||||
#child exists - overlay |
||||
set is_new_object 0 |
||||
set existing_interfaces [$child ## varspace_meta . (GET)interfaces] |
||||
set ifaces_added [list] |
||||
foreach p $patterns { |
||||
if {$p ni $existing_interfaces} { |
||||
lappend ifaces_added $p |
||||
} |
||||
} |
||||
if {[llength $ifaces_added]} { |
||||
$child ## varspace_meta . (SET)interfaces [concat $existing_interfaces $ifaces_added] |
||||
} |
||||
} |
||||
|
||||
#only set the child's defaultmethod value if the parent_patterndefaultmethod is not empty |
||||
#if {$parent_patterndefaultmethod ne ""} { |
||||
# $child ## PatternInternal . (SET)default_method $parent_patterndefaultmethod |
||||
#} |
||||
|
||||
lappend target_objects $child |
||||
} |
||||
return $target_objects |
||||
} |
||||
|
||||
|
||||
namespace eval ::pattern { |
||||
set tmp_methods [info class methods ::pattern::IPatternBuilder -private] ;#-private returns all user-defined methods above |
||||
oo::define ::pattern::IPatternBuilder export {*}$tmp_methods |
||||
unset tmp_methods |
||||
} |
||||
@ -0,0 +1,43 @@
|
||||
package provide pattern::IPatternInterface 2.0 |
||||
|
||||
#Definition of pattern interface with interface ID 'Define' |
||||
#Execution context: pp::Obj${OID}::_meta namespace (varspace _meta) |
||||
|
||||
namespace eval pattern { |
||||
} |
||||
|
||||
package require TclOO |
||||
|
||||
oo::class create ::pattern::IPatternInterface |
||||
|
||||
oo::define ::pattern::IPatternInterface { |
||||
variable o_open |
||||
} |
||||
|
||||
oo::define ::pattern::IPatternInterface method isOpen {} { |
||||
my variable o_open |
||||
return $o_open |
||||
} |
||||
oo::define ::pattern::IPatternInterface method isClosed {} { |
||||
my variable o_open |
||||
return [expr {!$o_open}] |
||||
} |
||||
|
||||
oo::define ::pattern::IPatternInterface method getcmd {args} { |
||||
return $args |
||||
} |
||||
oo::define ::pattern::IPatternInterface method run {args} { |
||||
uplevel 1 {*}$args |
||||
} |
||||
|
||||
#this is not the object's implemented varspaces - it is the varspace list for the interface specification this object represents |
||||
oo::define ::pattern::IPatternInterface method Varspaces {args} { |
||||
tailcall my API(varspace_iface)(GET)interface_varspaces |
||||
} |
||||
|
||||
|
||||
namespace eval ::pattern { |
||||
set tmp_methods [info class methods ::pattern::IPatternInterface -private] ;#-private returns all user-defined methods above |
||||
oo::define ::pattern::IPatternInterface export {*}$tmp_methods |
||||
unset tmp_methods |
||||
} |
||||
@ -0,0 +1,122 @@
|
||||
|
||||
# |
||||
# |
||||
package provide pattern::IPatternSystem 2.0 |
||||
|
||||
#Definition of pattern interface with interface ID 'PatternSystem' |
||||
#Execution context: pp::Obj${OID}::_meta namespace (varspace _meta) |
||||
|
||||
namespace eval pattern { |
||||
} |
||||
|
||||
package require TclOO |
||||
|
||||
oo::class create ::pattern::IPatternSystem |
||||
|
||||
oo::define ::pattern::IPatternSystem { |
||||
variable o_OID |
||||
} |
||||
|
||||
oo::define ::pattern::IPatternSystem method ID {} { |
||||
my variable o_OID |
||||
puts "IPatternSystem returning id $o_OID" |
||||
return $o_OID |
||||
} |
||||
|
||||
|
||||
oo::define ::pattern::IPatternSystem method get_possibly_new_open_interface {{apiname default}} { |
||||
my variable o_OID _ID_ o_interface_apis |
||||
|
||||
|
||||
if {$apiname eq "default"} { |
||||
set apiname [set ::pp::Obj${o_OID}::_meta::o_default_interface_api] |
||||
} |
||||
if {![dict exists $o_interface_apis $apiname]} { |
||||
error "get_possibly_new_open_interface Unable to find api:'$apiname'" |
||||
} |
||||
|
||||
set interfaces [dict get $o_interface_apis $apiname] |
||||
set iid_top [lindex $interfaces end] |
||||
set iface ::pp::ifaces::>$iid_top |
||||
if {(![string length $iid_top]) || ([$iface . isClosed])} { |
||||
#no existing pattern - create a new interface |
||||
set iid_top [expr {$::pp::ID + 1}] ;#PREDICT the next object's id |
||||
#puts stderr ">>>>creating new interface $iid_top" |
||||
set iface [::pp::>interface .. Create ::pp::ifaces::>$iid_top $o_OID] |
||||
|
||||
dict set o_interface_apis $apiname [concat $interfaces $iid_top] |
||||
} |
||||
return $iid_top |
||||
} |
||||
|
||||
|
||||
oo::define ::pattern::IPatternSystem method add_pattern_interface {iid {apiname default}} { |
||||
my variable _ID_ o_pattern_apis |
||||
#puts stderr "!!!!!!!!!!!!!!! add_pattern_interface $iid" |
||||
if {![string is integer -strict $iid]} { |
||||
error "add_pattern_interface adding interface by name not yet supported. Please use integer id" |
||||
} |
||||
|
||||
|
||||
if {$apiname eq "default"} { |
||||
set apiname [set ::pp::Obj${o_OID}::_meta::o_default_pattern_api] |
||||
} |
||||
if {![dict exists $o_pattern_apis $apiname]} { |
||||
error "add_interface Unable to find api:'$apiname'" |
||||
} |
||||
|
||||
|
||||
#set invocants [dict get $_ID_ i] |
||||
|
||||
set istack [dict get $o_pattern_apis $apiname] |
||||
|
||||
#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? |
||||
dict set o_pattern_apis $apiname [concat $istack $iid] |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
#!todo - update usedby ?? |
||||
oo::define ::pattern::IPatternSystem method add_interface {iid {apiname default}} { |
||||
my variable o_OID _ID_ o_interface_apis |
||||
if {![string is integer -strict $iid]} { |
||||
error "adding interface by name not yet supported. Please use integer id" |
||||
} |
||||
|
||||
|
||||
if {$apiname eq "default"} { |
||||
set apiname [set ::pp::Obj${o_OID}::_meta::o_default_interface_api] |
||||
} |
||||
if {![dict exists $o_interface_apis $apiname]} { |
||||
error "add_interface Unable to find api:'$apiname'" |
||||
} |
||||
|
||||
|
||||
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 |
||||
|
||||
set istack [dict get $o_interface_apis $apiname] |
||||
dict set o_interface_apis $apiname [concat $istack $iid] |
||||
|
||||
return [dict get $o_interface_apis $apiname] |
||||
} |
||||
|
||||
|
||||
oo::define ::pattern::IPatternSystem method INVOCANTDATA {} { |
||||
my variable _ID_ |
||||
#same as a call to: >object .. |
||||
return $_ID_ |
||||
} |
||||
|
||||
|
||||
namespace eval ::pattern { |
||||
set tmp_methods [info class methods ::pattern::IPatternSystem -private] ;#-private returns all user-defined methods above |
||||
oo::define ::pattern::IPatternSystem export {*}$tmp_methods |
||||
unset tmp_methods |
||||
} |
||||
@ -0,0 +1,330 @@
|
||||
#JMN 2007 |
||||
#public domain |
||||
|
||||
#experimental |
||||
#VERY incomplete |
||||
|
||||
package require pattern |
||||
package require patternlib |
||||
package require struct::set |
||||
|
||||
package provide pattern::ms [namespace eval ::pattern::ms { |
||||
variable version |
||||
set version 1.0.12 |
||||
}] |
||||
|
||||
|
||||
#-------------------------------------------------- |
||||
namespace eval ::pattern::ms { |
||||
::>pattern .. Create >IEnumerable |
||||
>IEnumerable .. PatternVariable i ;#current index |
||||
>IEnumerable .. PatternProperty Current |
||||
>IEnumerable .. PatternPropertyRead Current {} { |
||||
var o_list i |
||||
return [lindex $o_list $i] |
||||
} |
||||
>IEnumerable .. PatternMethod MoveNext {} { |
||||
var i |
||||
incr i |
||||
} |
||||
>IEnumerable .. PatternMethod Reset {} { |
||||
var i |
||||
set i 0 |
||||
} |
||||
} |
||||
|
||||
#-------------------------------------------------- |
||||
namespace eval ::pattern::ms { |
||||
::>pattern .. Create >Enumerator |
||||
>Enumerator .. PatternVariable o_enumerable |
||||
|
||||
>Enumerator .. Constructor {IEnumerable_object} { |
||||
var o_enumerable |
||||
set o_enumerable $IEnumerable_object |
||||
} |
||||
|
||||
>Enumerator .. PatternMethod atEnd {} { |
||||
var i o_list |
||||
return [expr {$i >= ([llength $o_list] -1)} ] |
||||
} |
||||
>Enumerator .. PatternMethod moveNext {} { |
||||
var i |
||||
incr i |
||||
} |
||||
>Enumerator .. PatternMethod moveFirst {} { |
||||
var i |
||||
set i 0 |
||||
} |
||||
>Enumerator .. PatternMethod item {} { |
||||
var i o_list |
||||
return [lindex $o_list $i] |
||||
} |
||||
} |
||||
|
||||
|
||||
#-------------------------------------------------- |
||||
namespace eval ::pattern::ms { |
||||
::>pattern .. Create >textstream |
||||
>textstream .. PatternVariable o_fd ;#file descriptor |
||||
|
||||
>textstream .. Constructor {args} { |
||||
set opts [dict merge { |
||||
-mode r |
||||
} $args] |
||||
|
||||
if {([dict get $opts -mode] eq "r") && ![file exists [dict get $opts -path]]} { |
||||
error "file [dict get $opts -path] not found" |
||||
} |
||||
|
||||
set o_fd [open [dict get $opts -path] [dict get $opts -mode]] |
||||
return |
||||
} |
||||
|
||||
>textstream .. PatternMethod Write {data} { |
||||
var o_fd |
||||
puts -nonewline $o_fd $data |
||||
} |
||||
>textstream .. PatternMethod WriteLine {{line ""}} { |
||||
var o_fd |
||||
puts $o_fd $line |
||||
} |
||||
>textstream .. PatternMethod WriteBlankLines {howmany} { |
||||
var o_fd |
||||
#!todo - work out proper line-ending and write in single call. |
||||
if {$howmany > 0} { |
||||
for {set i 0} {$i < $howmany} {incr i} { |
||||
puts $o_fd "" |
||||
} |
||||
} |
||||
} |
||||
>textstream .. PatternMethod Read {{numbytes ""}} { |
||||
var o_fd |
||||
if {[string length $numbytes]} { |
||||
return [read $o_fd $numbytes] |
||||
} else { |
||||
return [read $o_fd] |
||||
} |
||||
} |
||||
>textstream .. PatternMethod ReadLine {} { |
||||
var o_fd |
||||
return [gets $o_fd] |
||||
} |
||||
>textstream .. PatternMethod ReadAll {} { |
||||
var o_fd |
||||
return [read $o_fd] ;#don't use size argument - we can't be sure it hasn't changed since opening (?) |
||||
} |
||||
>textstream .. PatternMethod Skip {numchars} { |
||||
var o_fd |
||||
seek $o_fd $numchars current |
||||
} |
||||
>textstream .. PatternMethod SkipLine {} { |
||||
var o_fd |
||||
gets $o_fd |
||||
return |
||||
} |
||||
|
||||
>textstream .. PatternMethod Close {} { |
||||
var o_fd |
||||
close $o_fd |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
# https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/file-object |
||||
namespace eval ::pattern::ms { |
||||
::>pattern .. Create >fso_file |
||||
>fso_file .. PatternVariable o_path |
||||
>fso_file .. Constructor {args} { |
||||
var this o_path |
||||
set this @this@ |
||||
|
||||
set opts [dict merge { |
||||
|
||||
} $args] |
||||
|
||||
if {![file exists [dict get $opts -path]]} { |
||||
error "cannot find file '[dict get $opts -path]'" |
||||
} |
||||
if {![file isfile [dict get $opts -path]]} { |
||||
error "path '[dict get $opts -path]' does not appear to be a file" |
||||
} |
||||
|
||||
set o_path [dict get $opts -path] |
||||
|
||||
return |
||||
} |
||||
>fso_file .. PatternProperty Name |
||||
>fso_file .. PatternPropertyRead Name {} { |
||||
var o_path |
||||
return [file tail $o_path] ;#??? |
||||
} |
||||
>fso_file .. PatternPropertyWrite Name {newname} { |
||||
var o_path |
||||
file rename $o_path [file dirname $o_path]/$newname |
||||
return |
||||
} |
||||
>fso_file .. PatternProperty Path |
||||
>fso_file .. PatternPropertyRead Path {} { |
||||
var o_path |
||||
return $o_path |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
#------------------------------------------------------------------------------ |
||||
namespace eval ::pattern::ms { |
||||
::>pattern .. Create >fso_folder |
||||
>fso_folder .. PatternVariable o_path |
||||
>fso_folder .. PatternVariable o_files ;#collection |
||||
|
||||
>fso_folder .. Constructor {args} { |
||||
var this ns o_path o_files |
||||
|
||||
set this @this@ |
||||
set ns [$this .. Namespace] |
||||
|
||||
set opts [dict merge { |
||||
|
||||
} $args] |
||||
|
||||
if {![file exists [dict get $opts -path]]} { |
||||
error "cannot find folder '[dict get $opts -path]'" |
||||
} |
||||
if {![file isdirectory [dict get $opts -path]]} { |
||||
error "path '[dict get $opts -path]' does not appear to be a folder" |
||||
} |
||||
|
||||
set o_path [dict get $opts -path] |
||||
|
||||
set o_files [::patternlib::>collection .. Create ${ns}::>col_files] |
||||
|
||||
return |
||||
} |
||||
|
||||
|
||||
#!todo - what happens to the object? destroy it? |
||||
>fso_folder .. PatternMethod Delete {{force 0}} { |
||||
var this o_path |
||||
if {$force} { |
||||
file delete -force $o_path |
||||
} else { |
||||
file delete $o_path |
||||
} |
||||
|
||||
#?? |
||||
# $this .. Destroy |
||||
return |
||||
} |
||||
|
||||
>fso_folder .. PatternProperty DateCreated |
||||
>fso_folder .. PatternPropertyRead DateCreated {} { |
||||
var o_path |
||||
file stat $o_path info |
||||
return $info(ctime) |
||||
} |
||||
>fso_folder .. PatternProperty DateLastAccessed |
||||
>fso_folder .. PatternPropertyRead DateLastAccessed {} { |
||||
var o_path |
||||
return [file atime $o_path] |
||||
} |
||||
>fso_folder .. PatternProperty DateLastModified |
||||
>fso_folder .. PatternPropertyRead DateLastModified {} { |
||||
var o_path |
||||
return [file mtime $o_path] |
||||
} |
||||
|
||||
>fso_folder .. PatternProperty Files |
||||
>fso_folder .. PatternPropertyRead Files {} { |
||||
var ns o_path objectcounter o_files |
||||
set filenames [glob -dir $o_path -type f -tail *] |
||||
lappend filenames {*}[glob -dir $o_path -types {f hidden} -tail *] |
||||
|
||||
set NEW [::pattern::ms::>fso_file .. Create .] |
||||
set files [list] |
||||
|
||||
set superfluous [struct::set difference [$o_files . names] $filenames] |
||||
foreach doomed $superfluous { |
||||
set f [$o_files . item $doomed] |
||||
$f .. Destroy |
||||
$o_files . del $doomed |
||||
} |
||||
|
||||
set missing [struct::set difference $filenames [$o_files . names]] |
||||
foreach fname $missing { |
||||
if {[catch { |
||||
set fobj [$NEW ${ns}::>fl_[incr objectcounter] -path $o_path/$fname] |
||||
} errM]} { |
||||
#There can exist characterSpecial files such as 'nul' that aren't identified as file or directory by Tcl 'file isfile' or 'file isdirectory' |
||||
# yet were picked up by glob |
||||
#(these shouldn't really exist - but can be accidentally created) |
||||
#we don't want an error in creating an >fso_file for this to stop us accessing any other files in the folder |
||||
#but we should at least be loud about it by emitting the error to stderr |
||||
puts stder " |
||||
} |
||||
$o_files . add [$NEW ${ns}::>fl_[incr objectcounter] -path $o_path/$fname] $fname |
||||
} |
||||
|
||||
return [$o_files . items] |
||||
} |
||||
} |
||||
|
||||
|
||||
#------------------------------------------------------------------------------ |
||||
#vba and vb6 File System Object (used the same COM component - Microsoft Scripting Runtime library scrrun.dll) |
||||
namespace eval ::pattern::ms { |
||||
::>pattern .. Create >fso |
||||
|
||||
>fso .. PatternVariable objectcounter ;# |
||||
>fso .. Constructor {args} { |
||||
var this ns objectcounter |
||||
set this @this@ |
||||
set ns [$this .. Namespace] |
||||
|
||||
set objectcounter 0 |
||||
} |
||||
|
||||
>fso .. PatternMethod CreateTextFile {path {bool 1}} { |
||||
var ns objectcounter |
||||
set ts [::pattern::ms::>textstream .. Create ${ns}::>ts_[incr objectcounter] -path $path -mode w] |
||||
return $ts |
||||
} |
||||
|
||||
>fso .. PatternMethod OpenTextFile {path mode {bool 1}} { |
||||
var ns objectcounter |
||||
|
||||
switch -- [string tolower $mode] { |
||||
1 - |
||||
forreading { |
||||
set md r |
||||
} |
||||
2 - |
||||
forwriting { |
||||
set md w |
||||
} |
||||
8 - |
||||
forappending { |
||||
set md a |
||||
} |
||||
default { |
||||
error "unknown file mode - $mode" |
||||
} |
||||
} |
||||
set ts [::pattern::ms::>textstream .. Create ${ns}::>ts_[incr objectcounter] -mode $md -path $path] |
||||
return $ts |
||||
} |
||||
|
||||
>fso .. PatternMethod GetFolder {path} { |
||||
var ns objectcounter |
||||
|
||||
set fld [::pattern::ms::>fso_folder .. Create ${ns}::>fld_[incr objectcounter] -path $path] |
||||
return $fld |
||||
} |
||||
>fso .. PatternProperty Drives |
||||
>fso .. PatternPropertyRead Drives {} { |
||||
var ns |
||||
error "unimplemented" |
||||
#todo >fso_drive object and collection |
||||
} |
||||
} |
||||
|
||||
@ -0,0 +1,911 @@
|
||||
#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. |
||||
#------------------------------------------------------------ |
||||
#::pp::Obj-1 ::p::internals::>metaface |
||||
#::pp::Obj0 ::p::ifaces::>null |
||||
#::pp::Obj1 ::>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::<id>:: instead of seperate ::p::IFACE::<id>:: |
||||
# - 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 <value>? |
||||
# |
||||
#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 pattern2 [namespace eval pattern {variable version; set version 2.0}] |
||||
package require patterncmd ;#utility/system diagnostic commands (may be used by metaface lib etc) |
||||
package require cmdline |
||||
|
||||
package require patterndispatcher |
||||
|
||||
namespace eval pattern { |
||||
variable initialised 0 |
||||
} |
||||
|
||||
|
||||
|
||||
namespace eval pp { |
||||
#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 func {} |
||||
} |
||||
|
||||
|
||||
#!store all interface objects here? |
||||
namespace eval ::pp::ifaces {} |
||||
|
||||
|
||||
proc ::pp::assert {condition errmsg} { |
||||
if {![uplevel 1 expr $condition]} { |
||||
return -code error "assertion failed. condition:'$condition' msg:'$errmsg'" |
||||
} |
||||
} |
||||
#proc ::pp::assert args {} |
||||
|
||||
proc ::pp::get_new_object_id {} { |
||||
tailcall incr ::pp::ID |
||||
#tailcall ::pattern::new_uuid |
||||
} |
||||
|
||||
|
||||
#create a new minimal object - with no interfaces or patterns. |
||||
proc ::pp::func::new_object {obj {OID ""}} { |
||||
puts stderr "(::pp::func::new_object) obj:$obj OID:$OID" |
||||
|
||||
if {[string range $obj 0 1] ne "::"} { |
||||
set nsbase [uplevel 1 [list namespace current]] |
||||
if {$nsbase eq "::"} { |
||||
set obj ::$obj |
||||
} else { |
||||
set obj ${nsbase}::$obj |
||||
} |
||||
} |
||||
|
||||
if {[info object isa object $obj]} { |
||||
puts stderr "(::pp::func::new_object) Object $obj already exists " |
||||
} |
||||
|
||||
if {$OID eq ""} { |
||||
set OID [::pp::get_new_object_id] |
||||
} |
||||
|
||||
set main_ns ::pp::Obj${OID} |
||||
if {[namespace exists $main_ns]} { |
||||
error "(::pp::func::new_object) Cannot create Object with id:'$OID' - corresponding namespace already exists" |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set default_method {} |
||||
set object_command $obj |
||||
#set INVOCANTRECORD [list $OID $main_ns $default_method $object_command {}] |
||||
|
||||
set invocantD [list id $OID ns $main_ns defaultmethod $default_method object $object_command] |
||||
|
||||
# _ID_ structure |
||||
#set _InvocantData_ [dict create i [dict create this [list $INVOCANTRECORD]] context ""] |
||||
set _InvocantData_ [dict create i [dict create this [list $invocantD]] context ""] |
||||
|
||||
#must create main varspace first as it is also the parent namespace for all varspaces |
||||
set vs_main [::pp::varspace_main create ::pp::Obj${OID} [set varspacename ""] $_InvocantData_] |
||||
|
||||
set vs_meta [::pp::varspace_meta create ::pp::Obj${OID}::_meta _meta $_InvocantData_] |
||||
|
||||
|
||||
puts stderr "\t(::pp::func::new_object) --- about to call pp::dispatcher create $obj $_InvocantData_ main" |
||||
pp::dispatcher create $obj $_InvocantData_ "main" |
||||
|
||||
return $obj |
||||
} |
||||
|
||||
proc ::pp::func::new_dispatcher {obj _InvocantData_ apiname} { |
||||
pp::dispatcher create $obj $_InvocantData_ $apiname |
||||
} |
||||
|
||||
|
||||
|
||||
#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 ::pp::func::no_default_method {_ID_ args} { |
||||
puts stderr "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?)" |
||||
} |
||||
|
||||
|
||||
|
||||
#>x .. Create >y |
||||
# ".." is special case equivalent to "._." |
||||
# (whereas in theory it would be ".default.") |
||||
# "." is equivalent to ".default." is equivalent to ".default.default." (.<iStack>.<iFace>.) |
||||
|
||||
#>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 |
||||
# |
||||
|
||||
|
||||
|
||||
|
||||
if {[namespace which ::pp::ifaces>null] eq ""} { |
||||
set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface |
||||
|
||||
#OID = 0 |
||||
::pp::func::new_object ::pp::ifaces::>null 0 |
||||
|
||||
::pp::func::new_object ::>pattern 1 |
||||
|
||||
#'class' for ::pp::ifaces::>x instances |
||||
::pp::func::new_object ::pp::>interface 3 |
||||
|
||||
} |
||||
|
||||
#NOOP - for compatibility with libraries which still call it |
||||
proc ::pattern::init {args} { |
||||
} |
||||
|
||||
|
||||
proc ::pattern::initXXX {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 |
||||
} |
||||
} |
||||
set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface |
||||
|
||||
#OID = 0 |
||||
::pp::func::new_object ::pp::ifaces::>null 0 |
||||
|
||||
::pp::func::new_object ::>pattern 1 |
||||
|
||||
#'class' for ::pp::ifaces::>x instances |
||||
::pp::func::new_object ::pp::>interface 3 |
||||
|
||||
#::pp::>interface ## PatternSystem . add_pattern_interface 2 |
||||
|
||||
#add to constructor? |
||||
#::pp::Obj${o_OID}::_iface API(PatternInternal)add_tcloo_interface_on_api "varspace_iface" "pattern::IPatternInterface" |
||||
|
||||
set ::pattern::initialised 1 |
||||
} |
||||
|
||||
|
||||
# >pattern has object ID 1 |
||||
# meta interface has object ID 0 |
||||
proc ::pattern::init2 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 |
||||
} |
||||
} |
||||
set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface |
||||
|
||||
#create metaface - IID = -1 - also OID = -1 |
||||
# all objects implement this special interface - accessed via the .. operator. |
||||
package require metaface |
||||
|
||||
|
||||
|
||||
#OID = 0 |
||||
::pp::func::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 |
||||
############################### |
||||
::pp::func::new_object ::>pattern 1 |
||||
|
||||
|
||||
|
||||
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 |
||||
|
||||
|
||||
#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 mmm} |
||||
return $mmm |
||||
} |
||||
::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 {package require patternlib} |
||||
return 1 |
||||
} |
||||
|
||||
|
||||
|
||||
#detect attempt to treat a reference to a method as a property |
||||
proc ::pp::func::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 ::pp::func::commandrefMisuse_TraceHandler $OID $field $args] |
||||
|
||||
#!todo - don't use vtraced! |
||||
trace add variable $vtraced {read write unset array} [concat ::pp::func::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 |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
################################################################################################################################################ |
||||
################################################################################################################################################ |
||||
################################################################################################################################################ |
||||
|
||||
|
||||
#force 1 will extend an interface even if shared. (??? why is this necessary here?) |
||||
#if IID empty string - create the interface. |
||||
proc ::pp::func::expand_interface {IID {force 0}} { |
||||
#puts stdout ">>> expand_interface $IID [info level -1]<<<" |
||||
if {![string length $IID]} { |
||||
set iid [expr {$::p::ID + 1}] |
||||
::pp::>interface .. Create ::pp::ifaces::>$iid |
||||
return $iid |
||||
} else { |
||||
if {[set ::pp::Obj${IID}::_iface::o_open]} { |
||||
#interface open for extending - shared or not! |
||||
return $IID |
||||
} |
||||
error "temporary error. Interface can't be expanded. Not implemented" |
||||
if {[array size ::pp::Obj${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 [expr {$::pp::ID + 1}] |
||||
::pp::>interface .. Create ::pp::ifaces::>$IID |
||||
|
||||
::pp::func::linkcopy_interface $prev_IID $IID |
||||
#assert: prev_usedby contains at least one other element. |
||||
} |
||||
#whether copied or not - mark as open for extending. |
||||
set ::pp::Obj${IID}::_iface::o_open 1 |
||||
return $IID |
||||
} |
||||
} |
||||
|
||||
#params: old - old (shared) interface ID |
||||
# new - new interface ID |
||||
proc ::pp::func::linkcopy_interface {old new} { |
||||
#puts stderr " ** ** ** linkcopy_interface $old $new" |
||||
set ns_old ::pp::Obj${old}::_iface |
||||
set ns_new ::pp::Obj${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 ::pp::${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 |
||||
|
||||
proc pp::repl {} { |
||||
set command "" |
||||
set prompt "% " |
||||
puts -nonewline stdout $prompt |
||||
flush stdout |
||||
while {[gets stdin line] >=0} { |
||||
append command "\n$line" |
||||
if {[info complete $command]} { |
||||
catch {uplevel #0 $command} result |
||||
puts stdout $result |
||||
set command "" |
||||
set prompt "% " |
||||
} else { |
||||
set prompt "(cont)% " |
||||
} |
||||
puts -nonewline stdout $prompt |
||||
flush stdout |
||||
} |
||||
} |
||||
|
||||
if {[info exists ::argv0] && [file dirname [file normalize [info script]/ ]] eq [file dirname [file normalize $argv0/]]} { |
||||
pp::repl |
||||
} |
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Loading…
Reference in new issue