main.tcl (4522B)
1 #!/usr/bin/env tclsh 2 # Basic tcl services program. 3 4 package require tie 5 package require base64 6 package require sha1 7 #set b64 [split "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789[]" {}] 8 9 source b64.tcl 10 set alwayssave 0 11 12 proc pwhash.SHA1 {pass {salt "a"}} { 13 global b64 14 set hash [::sha1::sha1 -hex $pass] 15 return "SHA1//$hash" 16 } 17 18 proc rand {minn {maxx 0}} { 19 if {$minn==$maxx} {return $maxx} 20 if {$minn > $maxx} {set omx $maxx; set maxx $minn ; set minn $omx} 21 set maxnum [expr {$maxx - $minn}] 22 set fp [open /dev/urandom r] 23 set bytes [read $fp 6] 24 close $fp 25 scan $bytes %c%c%c%c%c%c ca co ce cu ci ch 26 set co [expr {$co + pow(2,8)}] 27 set ce [expr {$ce + pow(2,16)}] 28 set cu [expr {$cu + pow(2,24)}] 29 set ci [expr {$ci + pow(2,32)}] 30 set ch [expr {$ch + pow(2,40)}] 31 return [expr {$minn+(int($ca+$co+$ce+$cu+$ci+$ch)%$maxnum)}] 32 } 33 34 proc mysrc {script} { 35 set fp [open $script r] 36 set ev [read $fp] 37 close $fp 38 uplevel "#0" $ev 39 } 40 41 proc readfile {script} { 42 set fp [open $script r] 43 chan configure $fp -encoding utf-8 44 set ev [read $fp] 45 close $fp 46 return $ev 47 } 48 49 proc readbfile {script} { 50 set fp [open $script rb] 51 set ev [read $fp] 52 close $fp 53 return $ev 54 } 55 56 proc loadmodule {script} { 57 set ismodule 0 58 foreach {file} [lsort [glob ./modules/*.tcl]] { 59 if {$file == [format "./modules/%s.tcl" $script]} {set ismodule 1} 60 } 61 if {!$ismodule} { 62 putloglev o * "MODULE $script DOES NOT EXIST; CONTINUING (or attempting to) ANYWAY" 63 return 64 } 65 set fp [open [format "./modules/%s.tcl" $script] r] 66 set ev [read $fp] 67 close $fp 68 uplevel "#0" $ev 69 } 70 71 proc save.db {name var no oper {apres 1}} { 72 upvar $var db 73 global lastsave alwayssave 74 if {$alwayssave != 1 && $apres != 1 && ($lastsave + 40 > [set now [clock seconds]])} {return} ;#save IO time by not always saving DB. integrity problems may result 75 # but do not save CPU time if we are apres=0 or alwayssave=1 76 # ensure DB save is atomic, so if tclserv is killed during or under 12.5 seconds after save 77 catch [list file rename $name [format "%s.bk%s" $name $now]] 78 set there [open $name [list WRONLY CREAT TRUNC]] 79 # I've learned from my time in qmail land - blocking I/O is probably better. 80 # might be even better if we can fire off a thread to do this for us. 81 chan configure $there -encoding utf-8 -blocking 1 -buffering full -buffersize 8192 82 # should not block for long 83 puts -nonewline $there $db 84 flush $there 85 close $there 86 # if {$apres == 1} { ;# the french word for "after", apres (from après) is the variable we use to say we want to repeat. on by default. 87 after 12500 [list catch [list file delete -- [format "%s.bk%s" $name $now]]] 88 # } 89 return 90 } 91 92 mysrc nda.tcl 93 # every 40sec, save, but not if never written 94 95 set lastsave [clock seconds] 96 97 if {[file exists services.db]} { 98 #puts stdout "reading the nda dict" 99 set nd [readbfile services.db] 100 #puts stdout $nd 101 } 102 103 set globwd [pwd] 104 set gettext [list] 105 106 proc outputbotnick {var no oper} { 107 upvar $var v 108 # depends on 4000-convenience. luckily not used before that's loaded or we'd be issue. 109 set v [curctx user] 110 } 111 112 proc showcontexts {var no oper} { 113 upvar $var v 114 # puts stdout "curctx is [curctx unum]@[curctx net]" 115 } 116 117 # eventually we need to change services.db to SERVICESDBNAME or something. 118 trace add variable nd [list write unset] [list save.db [set sdbname [format "%s/%s" [pwd] services.db]]] 119 trace add variable botnick [list read] [list outputbotnick] 120 trace add variable globuctx [list read write] [list showcontexts] 121 122 proc force_save_db {dbname {d ::nd}} { 123 # the fifth variable is "après", which refers to whether the save is a one-off, or whether it's ongoing. it defaults to 1, which means ongoing. this is a one-off save. 124 save.db $dbname $d 0 write 0 125 } 126 127 #::tie::tie nd file services.db 128 129 source openconf2.tcl 130 #mysrc services.conf 131 132 133 proc svc.rehash {} { 134 global gettext 135 tnda set rehashing 1 136 foreach {file} [lsort [glob ./core/*.tcl]] { 137 mysrc $file 138 } 139 force_save_db $::sdbname 140 if {[file exists $::globwd/language.txt]} { 141 set languagefile [split [readfile [format "%s/%s" $::globwd language.txt]] "\n"] 142 foreach {line} $languagefile { 143 set ll [split $line " "] 144 set ltext [join [lrange $ll 1 end] " "] 145 dict set gettext [lindex $ll 0] $ltext 146 } 147 } 148 tnda set "openconf" [list] 149 mysrc $::globwd/services.conf 150 tnda set rehashing 0 151 firellbind - evnt - "confloaded" loaded 152 } 153 154 svc.rehash 155 #by now we've loaded everything 156 #firellbind - evnt - "confloaded" loaded 157 158 #load from cfg file, not here 159 160 #foreach {file} [lsort [glob ./modules/*.tcl]] { 161 # mysrc $file 162 #} 163 164 vwait forever