tclserv

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

0000-callbacks.tcl (4054B)

      1 # This portion, of course, is available under the MIT license if not bundled with the rest of TclServ.
      2 
      3 # just to have sanity here. don't want a {} dict or a bum array
      4 # this is for the logging algorithm to work once implemented, too, among other important things
      5 set ::netname(-) -
      6 #set ::nettype(-) -
      7 #set ::sock(-) -
      8 
      9 set globctx ""
     10 set globuctx ""
     11 
     12 proc curctx {args} {return "-"}
     13 
     14 tnda set "llbinds" [list]
     15 
     16 proc llbind {sock type client comd script} {
     17 	set moretodo 1
     18 	while {0!=$moretodo} {
     19 		set llbindnum [rand 1 100000000]
     20 		if {[tnda get "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]/$llbindnum"]!=""} {} {set moretodo 0}
     21 	}
     22 	tnda set "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]/$llbindnum" $script
     23 	puts stdout "llbind $sock $type $client $comd $script"
     24 	return $llbindnum
     25 }
     26 
     27 proc unllbind {sock type client comd id} {
     28 	tnda set "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]/$id" ""
     29 	tnda unset "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]/$id"
     30 }
     31 proc unllbindall {sock type client comd} {
     32 	tnda set "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]" ""
     33 	tnda unset "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]"
     34 }
     35 proc firellbind {sock type client comd args} {
     36 #	Warn: will be noisy
     37 #	puts stdout [cdbase get llbinds]
     38 #	puts stdout "$sock $type $client $comd $args"
     39 	global globuctx globctx
     40 	if {$sock == "-"} {} {set globctx $::netname($sock)}
     41 	set oldglobuctx $globuctx
     42 	if {$client == "-"} {set globuctx ""} {set globuctx $client}
     43 	if {""!=[cdbase get llbinds $::netname($sock) $type $client [ndcenc $comd]]} {
     44 		foreach {id script} [cdbase get llbinds $::netname($sock) $type $client [ndcenc $comd]] {
     45 			if {$script != ""} {
     46 				set scr [string range $script 0 120]
     47 #				lappend $scr $sock
     48 				foreach {a} $args {
     49 					lappend scr $a
     50 				}
     51 				if {[set errcode [catch {eval $scr} erre]] > 0} {
     52 					foreach logline [split [format "in script %s:\n\nerror code %s, %s\nerror info:\n%s\ncontact script developer for assistance\n" $scr $errcode $::errorInfo $erre] "\n"] {
     53 						putloglev o * $logline
     54 					}
     55 					firellbind $sock evnt - error $erre {*}$scr
     56 				}
     57 			}
     58 		};return
     59 	} {
     60 #		puts stdout "didn't find one"
     61 	}
     62 	set globuctx $oldglobuctx
     63 	#if {""!=[tnda get "llbinds/$type/-/[ndcenc $comd]"]} {foreach {id script} [tnda get "llbinds/$type/-/[ndcenc $comd]"] {$script [lindex $args 0] [lrange $args 1 end]};return}
     64 }
     65 
     66 proc firellmbind {sock type client comd args} {
     67 #	puts stdout "$sock $type $client [ndcenc $comd] $args"
     68 	global globuctx globctx
     69 	if {$sock == "-"} {} {set globctx $::netname($sock)}
     70 	set oldglobuctx $globuctx
     71 	if {$client == "-"} {set globuctx ""} {set globuctx $client}
     72 	foreach {comde scripts} [tnda get "llbinds/$::netname($sock)/$type/$client"] {
     73 		set text [ndadec $comde]
     74 		if {[string match $text $comd]} {
     75 			foreach {id script} $scripts {
     76 				if {$script != ""} {
     77 					set scr $script
     78 #					lappend $scr $sock
     79 					foreach {a} $args {
     80 						lappend scr $a
     81 					}
     82 					if {[set errcode [catch {eval $scr} erre]] > 0} {
     83 						foreach logline [split [format "in script (#%s) %s:\n\nerror code %s, %s\nerror info:\n%s\ncontact script developer for assistance\n" $id $scr $errcode $::errorInfo $erre] "\n"] {
     84 							putloglev o * $logline
     85 						}
     86 						firellbind $sock evnt - error $erre {*}$scr
     87 					}
     88 				}
     89 			}
     90 		}
     91 	}
     92 	set globuctx $oldglobuctx
     93 	#if {""!=[tnda get "llbinds/$type/-/[ndcenc $comd]"]} {foreach {id script} [tnda get "llbinds/$type/-/[ndcenc $comd]"] {$script [lindex $args 0] [lrange $args 1 end]};return}
     94 }
     95 proc putloglev {lev ch msg} {
     96 	global globuctx globctx
     97 	set oldglobuctx $globuctx
     98 	# punt
     99     foreach level [split $lev {}] {
    100 		catch {firellmbind [curctx sock] log - [format "%s %s" $ch $level] [curctx net] $level $ch $msg}
    101 		catch {firellbind [curctx sock] logall - - [curctx net] $level $ch $msg}
    102 		catch {firellmbind - log - [format "%s %s" $ch $level] [curctx net] $level $ch $msg}
    103 		catch {firellbind - logall - - [curctx net] $level $ch $msg}
    104 	}
    105 	set globuctx $oldglobuctx
    106 }
    107 proc putlog {msg} {putloglev o * $msg}