Tcl Library Source Code

Artifact 5a90907466d206929201b6dd023385d46f45926b:

Attachment "command.tcl" to ticket [02970aa767] added by anonymous 2013-08-28 16:40:42. (unpublished)

---

#!/usr/bin/tclsh
# This is a Tcl Library for eggdrop or similar bots
# It creates a safe, empty Tcl interpreter to which commands can be added.
# The commands are parsed and interpreded by Tcl's parser and can be nested, but dangerous operations are not allowed.
# This module might be relatively awkward to use (interpreter name as the last parameter because I'm lazy)

# This software was written by Moritz Wilhelmy in 2013.  No copyright is
# claimed, and the software is hereby placed in the public domain.
# In case this attempt to disclaim copyright and place the software in the
# public domain is deemed null and void, then the software is
# Copyright (c) 2013 Moritz Wilhelmy and it is hereby released to the
# general public under the following terms:
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted.
#
# There's ABSOLUTELY NO WARRANTY, express or implied.
#
# (This is a heavily cut-down "BSD license".)
#
# Contact: mw wzff de, insert an at and a dot

namespace eval ::command {
variable ns [namespace current]
variable interpns ${ns}::interps
namespace eval ${interpns} {}

variable interps;
array set interps {}

# helper to check whether an interpreter exists and return its name
proc get_interp {{name ""}} {
	variable interps

	if {![info exists interps($name)]} {
		error "Interpreter '$name' does not exist"
	}
	return $interps($name)
}

proc make_interp {{name ""} {safe yes}} {
	variable interps; variable interpns;

	set safe [expr {$safe ne "-unsafe" ? "-safe" : "--"}]

	if {![info exists interps($name)]} {
		set fullname [interp create $safe ${interpns}::${name}]
		interp hide $fullname namespace
		interp invokehidden $fullname -global namespace delete ::
		set interps($name) $fullname
		return $name
	}
	error "Interpreter '$name' already exists"
}

# Delete an interpreter. If it's the default inteprreter, create a replacement
proc delete_interp {{name ""}} {
	interp delete [get_interp $name]
	if {$name == ""} make_interp ;# ensure the default interpreter always exists
}

# clear all commands and variables from the interpreter by deleteing the global
# namespace using the hidden namespace command
proc clear_interp {{name ""}} {
	interp invokehidden [get_interp $name] -global namespace delete ::
}

# register a command in an interpreter
proc register {cmd {newcmd ""} {name ""}} {
	if {$newcmd == ""} { set newcmd $cmd }
	uplevel 1 [list ::interp alias [get_interp $name] $newcmd {} $cmd]
}

# drop command from interpreter
proc unregister {cmd {name ""}} {
	interp alias [get_interp $name] $cmd {}
}

# add an alias $cmd2 for $cmd which is already in interp
# syntax is like cp <src> <dst>, interp alias does it the other way around
proc alias {cmd cmd2 {name ""}} {
	set name [get_interp $name]
	interp alias $name $cmd2 $name $cmd
}

make_interp ;# create default interpreter, $interps("")
}

if {1} {
#!/usr/bin/tclsh
# test.tcl

#source command.tcl

proc foo {} {return "test passed"}
command::register foo ;# register foo in the interpreter
command::register incr
puts [[command::get_interp] eval foo]

command::unregister foo ;# unregister foo
command::register foo bar ;# register foo as bar in the default interpreter

puts [[command::get_interp] eval bar]
if [catch {puts [[command::get_interp] eval foo]} err] {
	puts "foo not found after unregistering, test passed: '$err'"
}

}