###### pgetlist
# 1. It returns a list of all id's in a proc with lindex relative to its code
# 2. Creates a list to varname with the body of a proc split at prior id's
# 3. If the proc has no pinsert id's it tags the existing body with null
# This means you can easily refer to the initial code in a proc by using id null
######
proc pgetlist {name {varname ""}} {
set c1 [format %c 1]
set code [split [string trim [info body $name]] \n]
set pattern "\#$c1\*$c1\#"
lappend code $pattern
set newlist [list]
set idlist [list]
set tmp [list]
foreach {line} $code {
if {[string match $pattern $line]} {
set tmp [join $tmp \n]
lappend idlist [string map [list $c1 "" "\#" ""] $line]
if {$tmp != {}} { lappend newlist $tmp }
set tmp [list]
}
lappend tmp $line
}
if {[llength $idlist] == 1} {
set id "null"
set newlist [linsert $newlist 0 "\#$c1$id$c1\#"]
set idlist [linsert $idlist 0 $id]
}
if {$varname != ""} { uplevel 1 [list set $varname $newlist] }
return [lrange $idlist 0 [expr [llength $idlist] - 2]]
}
###
###### pinsert
# Inserts code at index position under id
# if proc does not exist it creates it.
# returns 1 if id already exists
######
proc pinsert {name index id code} {
set c1 [format %c 1]
if {![llength [info procs $name]]} {
set bodylist [list]
set idlist [list]
set pargs {}
} else {
set idlist [pgetlist $name bodylist]
set pargs [info args $name]
}
foreach {oid} $idlist { if { [string match $oid $id] } { return 1 } }
set code "\#$c1$id$c1\#\n[string trim $code \n\r]"
set bodylist [linsert $bodylist $index $code]
proc ::$name $pargs [join $bodylist \n]
return 0
}
###
##### preplace
# removes id from proc optionally replaces it with a new id and newcode
# if newcode is specified and newid is "" it reuses the old id
#####
proc preplace {name id {newid ""} {newcode ""}} {
set c1 [format %c 1]
set idlist [pgetlist $name bodylist]
set pargs [info args $name]
set tmp [lsearch $idlist "$id"]
if { $tmp < 0 } { return 1 }
if {$newid == ""} { set newid $id }
if {$newcode == ""} {
set bodylist [lreplace $bodylist $tmp $tmp]
} else {
if {$newid != $id && [lsearch $idlist $newid] >= 0} { return 1 }
set code "\#$c1$newid$c1\#\n[string trim $newcode \n\r]"
set bodylist [lreplace $bodylist $tmp $tmp $code]
}
proc ::$name $pargs [join $bodylist \n]
return 0
}
###### pargs
# Sets the args of a proc
######
proc pargs {name parg} {
if {[llength [info procs $name]]} { proc ::$name $parg [info body $name] }
}
###
############ for debug
#! DEBUG
proc proc_view {name} {
set tmp [split [info body $name] \n]
set tmpa [info args $name]
set tmpres "proc $name \{$tmpa\} \{\n"
foreach {line} $tmp { set tmpres "$tmpres $line\n" }
set tmpres "$tmpres\}\n"
puts "\n############################\n### DEBUG - proc view ###"
puts "$tmpres"
puts "#Tags: [join [pgetlist MyProc] " & "]\n###########################\n"
}
#####Syntax:pinsert proc_name index id script- Inserts script at a list index position tagged as id. It creates the proc if it doesn't exist. If proc exists it returns 1 if id is already in use. If proc was created by other means it tags all script in it as "null". An ID can be virtually any string as long as it doesn't start or end with # or char /001pgetlist proc_name ?varname?- Returns a list of all id's in a proc. Optionally sets varname to a list where each list item is a id tag with its script.preplace proc_name id ?newid? ?newscript?- Replaces, Removes, script under id. If newid is "" it uses old id when replacing.proc_view proc_name- Not all that useful, heh, just something I used to see my results.Example: - Create and manipulate MyProcCreate proc MyProc and insert some code into it
pinsert MyProc end mycode1 {puts "First Added"}
pinsert MyProc end mycode2 {puts "Second Added"}Notice linsert functionality, lets go between our first two pinsert MyProc 1 mycode3 {puts "Third Added"}Replace a chunk of script but use the same id preplace MyProc mycode1 "" {puts "Hello world"}Replace a chunk of script with a new id notice an id can be any string, providing it doesnt start with pound or char 1 preplace MyProc mycode1 "king of the mountain" {puts "I WIN"}Lets try it outproc_view MyProc MyProcAdd some args to the proc
pargs MyProc {x y}Get a list of all the procs id'sset myIDs [pgetlist MyProc]Search for an ID and use its index
set i [lsearch $myIDs "king of the mountain"]
set myCode {
puts "$x is FUN"
puts "$y"
}
if {[pinsert MyProc $i mycode2 $myCode]} { puts "mycode2 exists use preplace for that" }
if {![pinsert MyProc $i newking $myCode]} { puts "newking works" }With pgetlist you can get pretty advanced, using either an items index or the id itself foreach {id} [pgetlist MyProc] {
if {$id != "newking"} { preplace MyProc $id }
}
proc_view MyProc
MyProc "TCL" "THE END"This could be used for a lot of things. I'll be using it for a tcl irc bot, all my added script is evaluated in one proc. This will make it easy for me to load/unload script from it. It'll also make it easy to keep track of it because i can use the file it came from to tag it. If anybody's interested in doing something similar this is about what it'll consist of.
proc loadscript {file} {
set fsize [file size $file]
set fin [open $file r]
set script [read $fin $fsize]
close $fin
if {[pinsert ScriptEval end $file $script]} {
puts "$file has been loaded"
} else {
puts "Error: $file is already loaded" }
}
loadscript "LuckyNumber.tcl"file: LuckyNumber.tcl
if {$event == "PRIVMSG" && [string toupper $text] == "!LUCKYNUMBERS"} {
set n 0
while {$n < 10} { set lucky "$lucky [expr {int(rand()*9)}]" ; incr n }
puts $ircSocket "PRIVMSG $chan :$nick's LuCkYnUmBeRs - $lucky"
}I hope somebody finds this as nifty as I do.- David Myers aka xonecubed