move plugins into submodules..

.gitmodules

@@ -0,0 +1,12 @@
+[submodule "tclcurl-fa"]
+	path = tclcurl-fa
+	url = git@github.com:flightaware/tclcurl-fa.git
+[submodule "tclx"]
+	path = tclx
+	url = git@github.com:flightaware/tclx.git
+[submodule "tcllib"]
+	path = tcllib
+	url = git@github.com:tcltk/tcllib.git
+[submodule "state"]
+	path = state
+	url = git@bitbucket.org:hastur666/fountain-of-wisdom.git

GypsFulvus.cabal

@@ -14,7 +14,7 @@ cabal-version:       >=1.10
 extra-source-files:  README.md
 
 library
-         exposed-modules: GypsFulvus, Carrion.Plugin.IO.STDIO
+         exposed-modules: GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL
          other-modules:   GypsFulvus.PluginStuff
          default-language:    Haskell2010
          hs-source-dirs:      src
@@ -27,14 +27,16 @@ library
                        directory,
                        hashable,
                        monad-parallel,
-                       haskeline
+                       haskeline,
+                       unix
+         extra-libraries:     tcl8.6
+         Includes:            /usr/include/tcl.h,
+                              src/tclstubswrapper/tclstubs.h
          ghc-options:
             -O2
             -threaded
             -with-rtsopts=-N
             -g
-            -keep-o-files
-            -keep-hi-files
 
 executable GypsFulvus
          default-language:    Haskell2010
@@ -53,11 +55,13 @@ executable GypsFulvus
             -threaded
             -with-rtsopts=-N
             -g
-            -keep-o-files
-            -keep-hi-files
          hs-source-dirs:      src
          other-modules: GypsFulvus.PluginStuff,GypsFulvus, Carrion.Plugin.IO.STDIO
          exposed-modules: GypsFulvus
+         extra-libraries:     tcl8.6
+         Includes:            /usr/include/tcl.h,
+                              src/tclstubswrapper/tclstubs.h
+
          main-is:             Main.hs
 
 executable Test-Carrion-Plugin-IO-STDIO
@@ -81,3 +85,28 @@ executable Test-Carrion-Plugin-IO-STDIO
             -threaded
             -with-rtsopts=-N
             -g
+
+executable Test-Carrion-Plugin-TCL
+           hs-source-dirs: src
+           main-is: Test-Carrion-TCL.hs
+           other-modules: Carrion.Plugin.TCL, GypsFulvus.PluginStuff
+           build-depends:       base >= 4.7 && < 5,
+                                stm,
+                                text >= 1.2.4.0,
+                                unix,
+                                plugins,
+                                haskeline,
+                                containers,
+                                directory,
+                                hashable,
+                                monad-parallel
+           default-language:    Haskell2010
+           extra-libraries:     tcl8.6
+           Includes:            /usr/include/tcl.h,
+                                src/tclstubswrapper/tclstubs.h
+           C-Sources:           src/tclstubswrapper/tclstubs.c
+           ghc-options:
+            -O2
+            -threaded
+            -with-rtsopts=-N
+            -g

src/Carrion/Plugin/TCL.hs

@@ -0,0 +1,188 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Carrion.Plugin.TCL
+    ( initPlugin,
+      processCommand,
+      testThing
+    ) where
+import Control.Monad
+import Control.Concurrent(forkIO)
+import Control.Concurrent.STM
+import System.Posix.DynamicLinker
+import System.Environment
+import Foreign.Ptr
+import Foreign.C.String
+import qualified Data.Text as T
+import GypsFulvus.PluginStuff(Manhole(..),Sewage(..), InitStatus(..),SewageAutorInfo(..),genericAutorToNSAutor, stripCommandPrefix', regift)
+data Tcl_Interp = Tcl_Interp deriving Show
+type Tcl_Interp_Ptr = Ptr Tcl_Interp
+type TCL_Actual_Version = CString
+type TCL_Wanted_Version = CString
+type TclScriptString = CString
+type TclScriptStringByteLen = Int
+type TclEvalFlags = Int
+type WantExact = Int
+type TclScriptFilename = CString
+data TCLCommand = TCLCommand {getTCLCNick :: String,
+                              getTCLCMask :: String,
+                              getTCLCHandle_o_O:: String,
+                              getTCLCChannel :: String,
+                              getTCLCActualCommand :: String
+                             }
+
+foreign import ccall "dynamic" mkTcl_CreateInterp :: FunPtr (IO Tcl_Interp_Ptr) -> IO (Tcl_Interp_Ptr)
+
+
+
+foreign import ccall "&Tcl_InitStubs_wrap" tcl_InitStubs :: FunPtr (Tcl_Interp_Ptr -> TCL_Wanted_Version -> WantExact -> IO TCL_Actual_Version)
+foreign import ccall "dynamic" mkTcl_InitStubs :: FunPtr (Tcl_Interp_Ptr -> TCL_Wanted_Version -> WantExact -> IO TCL_Actual_Version) -> (Tcl_Interp_Ptr -> TCL_Wanted_Version -> WantExact -> IO TCL_Actual_Version)
+foreign import ccall "dynamic" mkTcl_FindExecutable :: FunPtr (CString -> IO CString) -> (CString -> IO CString)
+foreign import ccall "dynamic" mkTcl_InitMemory :: FunPtr (Tcl_Interp_Ptr -> IO ()) -> (Tcl_Interp_Ptr -> IO ())
+foreign import ccall "dynamic" mkTcl_Init :: FunPtr (Tcl_Interp_Ptr -> IO Int) -> (Tcl_Interp_Ptr -> IO Int)
+foreign import ccall "dynamic" mkTcl_EvalFile :: FunPtr (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int) -> (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int)
+foreign import ccall "dynamic" mkTcl_GetStringResult :: FunPtr (Tcl_Interp_Ptr -> IO CString) -> (Tcl_Interp_Ptr -> IO CString)
+foreign import ccall "dynamic" mkTcl_EvalEx :: FunPtr (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int) -> (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int)
+type Tcl_EvalFile_Sig = (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int)
+type Tcl_EvalEx_Sig = (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int)
+type Tcl_GetStringResult_Sig = (Tcl_Interp_Ptr -> IO CString)
+tu :: T.Text -> String
+tu = T.unpack
+tellCommands = map T.pack ["tcl"]
+myPluginName = T.pack "TCL smeggdrop"
+tl = T.pack "local"
+mySignature = GenericStyleAutor myPluginName tl tl
+stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
+fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
+  :: SewageAutorInfo -> String -> TCLCommand
+fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson b = case b of
+  GenericStyleAutor a b c -> fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson . genericAutorToNSAutor $ GenericStyleAutor a b c
+  NetworkIdentStyleAutor a b c -> TCLCommand (tu a) (show b) "" (tu c)
+
+
+mkTCLCommandFromAIAndMsg :: SewageAutorInfo -> String -> TCLCommand
+mkTCLCommandFromAIAndMsg = fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
+
+data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: Tcl_Interp_Ptr,
+                                                    getEvalFile :: Tcl_EvalFile_Sig,
+                                                    getEvalEx :: Tcl_EvalEx_Sig,
+                                                    getGetStringResult :: Tcl_GetStringResult_Sig
+                                                    
+                                                   }
+
+lEN_AUTO :: Int
+lEN_AUTO = -1
+eVAL_FLAGS_CLEAR :: Int
+eVAL_FLAGS_CLEAR = 0
+testThing :: IO ()
+testThing = do
+  myFakeArg0 <- getExecutablePath >>= newCString
+  myTCLDl <- dlopen "/usr/lib/libtcl8.6.so" [RTLD_NOW]
+  myFunTcl_CreateInterp <- dlsym myTCLDl "Tcl_CreateInterp"
+  let tcl_CreateInterp = mkTcl_CreateInterp myFunTcl_CreateInterp 
+  interp <- tcl_CreateInterp
+  let tcl_InitStubs' = mkTcl_InitStubs tcl_InitStubs
+  wanted_interp_version <- newCString "8.6"
+  actual_version_c <- tcl_InitStubs' interp wanted_interp_version 0
+  actual_version <- peekCString actual_version_c
+  putStrLn actual_version
+  myFunTcl_FindExecutable <- dlsym myTCLDl "Tcl_FindExecutable"
+  let tcl_FindExecutable = mkTcl_FindExecutable myFunTcl_FindExecutable
+  theComputedExecutablePath <- tcl_FindExecutable $ myFakeArg0
+  if nullPtr == theComputedExecutablePath then
+    putStrLn "Couldn't Tcl_FindExecutable()"
+  else
+    peekCString theComputedExecutablePath >>= putStrLn
+  myFunTcl_InitMemory <- dlsym myTCLDl "Tcl_InitMemory"
+  let tcl_InitMemory = mkTcl_InitMemory myFunTcl_InitMemory
+  tcl_InitMemory interp
+  myFunTcl_Init <- dlsym myTCLDl "Tcl_Init"
+  let tcl_Init = mkTcl_Init myFunTcl_Init
+  tcl_Init_status <- tcl_Init interp
+  myFunTcl_EvalEx <- dlsym myTCLDl "Tcl_EvalEx"
+  let tcl_EvalEx = mkTcl_EvalEx myFunTcl_EvalEx
+  testScript <- newCString "set a [expr 2 + 2]; puts $a;"
+  let runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
+  let runTclCommand s = newCString s >>= runscript
+  testScriptStatus <- runscript testScript
+  putStrLn $ show testScriptStatus
+  newCString "puts \"test persistence [expr $a +2]\";" >>= runscript >>= putStrLn . show  
+  let bless name convf = dlsym myTCLDl name >>= \fp -> return . convf $ fp
+  tcl_GetStringResult <- bless "Tcl_GetStringResult" mkTcl_GetStringResult
+  let errorInfo = runTclCommand "puts $errorInfo"
+      doTheTCL c = runTclCommand c >>= \st ->
+        case st of
+          0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then putStrLn ("Command: " ++ c ++" ; returned a null pointer result.") else peekCString rs >>= \nrs -> putStrLn ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";")
+          _ -> errorInfo>> return ()
+      fakeFromIRC c = doTheTCL $ "return [pub:tcl:perform root test!test@test.org test #test {" ++ c ++ "}]"
+  tcl_EvalFile <- bless "Tcl_EvalFile" mkTcl_EvalFile
+  smeginitstatus <- newCString "/home/pszczola/Carrion-Plugin-TCL/src/smeggdrop/smeggdrop.tcl" >>= \fn -> tcl_EvalFile interp fn
+  --newCString "puts $errorInfo;" >>= runscript >>= putStrLn . show
+  errorInfo
+  runTclCommand "puts $SMEGGDROP_ROOT"
+  putStrLn $ show $ smeginitstatus
+--  fakeFromIRC "proc testo4444 args {return \"booboo\n\"}"
+
+dumpDebug = putStrLn
+
+initPlugin :: Manhole -> IO InitStatus
+initPlugin manhole = do
+  myFakeArg0 <- getExecutablePath >>= newCString
+  myTCLDl <- dlopen "/usr/lib/libtcl8.6.so" [RTLD_NOW]
+  let bless name convf = dlsym myTCLDl name >>= \fp -> return $ convf $ fp
+  tcl_CreateInterp <- bless "Tcl_CreateInterp" mkTcl_CreateInterp
+  interp <- tcl_CreateInterp
+  let tcl_InitStubs' = mkTcl_InitStubs tcl_InitStubs
+  wanted_interp_version <- newCString "8.6"
+  actual_version <- tcl_InitStubs' interp wanted_interp_version 0 >>= peekCString
+  dumpDebug actual_version
+  tcl_FindExecutable <- bless "Tcl_FindExecutable" mkTcl_FindExecutable
+  theComputedExecutablePath <- tcl_FindExecutable $ myFakeArg0
+  if nullPtr == theComputedExecutablePath then
+    dumpDebug "Couldn't Tcl_FindExecutable()"
+  else
+    peekCString theComputedExecutablePath >>= dumpDebug
+  tcl_InitMemory <- bless "Tcl_InitMemory" mkTcl_InitMemory
+  tcl_InitMemory interp
+  tcl_Init <- bless "Tcl_Init" mkTcl_Init
+  tcl_Init_status <- tcl_Init interp
+  dumpDebug $ show tcl_Init_status
+  if (tcl_Init_status /= 0) then
+    return $ BadInitStatus $ T.pack "non-zero return"
+  else do
+    tcl_EvalEx <- bless "Tcl_EvalEx" mkTcl_EvalEx
+    tcl_GetStringResult <- bless "Tcl_GetStringResult" mkTcl_GetStringResult
+    tcl_EvalFile <- bless "Tcl_EvalFile" mkTcl_EvalFile
+    smeginitstatus <- newCString "./src/smeggdrop/smeggdrop.tcl" >>= \fn -> tcl_EvalFile interp fn
+    let wrappedinterp = TCLInterpreterWrapper interp tcl_EvalFile tcl_EvalEx tcl_GetStringResult
+    forkIO $ rEPL wrappedinterp manhole
+    return GoodInitStatus
+
+
+processCommand wi s = do
+  let tcl_EvalEx = getEvalEx wi
+      tcl_GetStringResult = getGetStringResult wi
+      interp = getInterp wi
+      runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
+      runTclCommand s = newCString s >>= runscript
+      errorInfo = runTclCommand "return $errorInfo"
+      autInfo = getSewageAutor s
+      sewCmd = T.unpack $ getSewage s
+      autDefNS = genericAutorToNSAutor autInfo
+      sewNick = T.unpack $ getNick autDefNS
+      sewMask = show $ getMask autDefNS
+      sewChan = T.unpack $ getChannel autDefNS
+      doTheTCL c = runTclCommand c >>= \st ->
+        case st of
+          0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then dumpDebug ("Command: " ++ c ++" ; returned a null pointer result.") >> return "FAILED" else peekCString rs >>= \nrs -> dumpDebug ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";") >> return nrs
+          _ -> errorInfo >> tcl_GetStringResult interp >>= peekCString
+      performFromIRC = doTheTCL $ "return [pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}]"
+  performFromIRC
+
+rEPL wrappedtclinterp manhole =
+  let inspectManhole = atomically . readTChan . getInputChan
+      regift g = atomically . (flip writeTChan g) . getOutputChan in
+  forever $ do
+    newGift <- inspectManhole manhole
+    processedGift <- processCommand wrappedtclinterp newGift
+    regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) (T.pack processedGift)) manhole
+    return ()

src/Test-Carrion-TCL.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Main where
+import GypsFulvus.PluginStuff
+import Carrion.Plugin.TCL
+import Control.Concurrent.STM
+import Control.Concurrent
+import Control.Monad
+import qualified Data.Text as T
+main = do
+  inchan <- atomically $ newTChan
+  outchan <- atomically $ newTChan
+  let mymanhole = Manhole inchan outchan
+  initPlugin mymanhole
+  let testCommand = Sewage (GenericStyleAutor (T.pack "Test Bin") (T.pack "local") (T.pack "local")) (T.pack "inspect inspect")
+  atomically $ writeTChan inchan testCommand
+  forever $ do
+    newstuff <- atomically $ readTChan outchan
+    putStrLn $ "Backend " ++ (show $ getSewageAutor newstuff) ++ " returned " ++ (T.unpack $ getSewage newstuff)

src/smeggdrop/smeggdrop.conf.default

@@ -0,0 +1,20 @@
+# smeggdrop.conf.default
+#
+# HTTP limits
+#
+set smeggdrop_http_requests_per_eval  5                     ;# Maximum number of requests per eval per channel
+set smeggdrop_http_request_interval   60                    ;# Interval for the smeggdrop_http_request_limit setting, in seconds
+set smeggdrop_http_request_limit      25                    ;# Maximum number of requests per interval per channel
+set smeggdrop_http_post_limit         150000                ;# Maximum POST body size
+set smeggdrop_http_transfer_limit     150000                ;# Maximum GET response size
+set smeggdrop_http_time_limit         5000                  ;# Maximum execution time, in milliseconds
+set smeggdrop_log_max_lines           20                    ;# Maximum lines to record per channel
+
+#
+# Publish settings - comment these out if you don't want [publish]
+#
+# set smeggdrop_publish_url             http://www.example.org/           ;# URL to publish to
+# set smeggdrop_publish_hostname        example.org                       ;# SSH hostname
+# set smeggdrop_publish_username        myusername                        ;# SSH username
+# set smeggdrop_publish_password        mypassword                        ;# SSH password
+# set smeggdrop_publish_filename        /home/example/htdocs/index.txt    ;# Filename to write to

src/smeggdrop/smeggdrop.tcl

@@ -0,0 +1,6 @@
+# smeggdrop.tcl
+encoding system utf-8
+set SMEGGDROP_ROOT [file dirname [info script]]
+proc putlog args {}
+if [file exists smeggdrop.conf] {source smeggdrop.conf}
+source $SMEGGDROP_ROOT/smeggdrop/smeggdrop.tcl

src/smeggdrop/smeggdrop/commands.tcl

@@ -0,0 +1,42 @@
+source $SMEGGDROP_ROOT/smeggdrop/meta_proc.tcl
+
+foreach script [glob -nocomplain $SMEGGDROP_ROOT/smeggdrop/commands/*.tcl] {
+  source $script
+}
+
+namespace eval commands {
+  variable nick
+  variable mask
+  variable hand
+  variable channel
+  variable line
+  variable eval_count -1
+  variable hidden_procs hidden
+  
+  proc hidden {proc name args body} {
+    variable hidden_procs
+    uplevel [list proc $name $args $body]
+    lappend hidden_procs $name
+  }
+  
+  hidden proc configure args {
+    foreach var $args {
+      variable $var
+      set $var [uplevel [list set $var]]
+    }
+  }
+
+  hidden proc increment_eval_count {} {
+    variable eval_count
+    incr eval_count
+  }
+  
+  hidden proc get var {
+    variable $var
+    set $var
+  }
+  
+  hidden proc apply {command arguments} {
+    uplevel [concat $command $arguments]
+  }
+}

src/smeggdrop/smeggdrop/commands/cache.tcl

@@ -0,0 +1,56 @@
+namespace eval cache {
+  namespace eval buckets {
+    proc import {bucket_name {as bucket}} {
+      variable ::cache::buckets::$bucket_name
+      if ![info exists ::cache::buckets::$bucket_name] {
+        array set ::cache::buckets::$bucket_name {}
+      }
+      uplevel [list upvar ::cache::buckets::$bucket_name $as]
+    }
+  }
+  
+  proc keys bucket_name {
+    buckets::import $bucket_name
+    array names bucket
+  }
+  
+  proc exists {bucket_name key} {
+    buckets::import $bucket_name
+    info exists bucket($key)
+  }
+  
+  proc get {bucket_name key} {
+    buckets::import $bucket_name
+    ensure_key_exists $bucket_name $key
+    set bucket($key)
+  }
+
+  proc put {bucket_name key value} {
+    buckets::import $bucket_name
+    set bucket($key) $value
+  }
+
+  proc fetch {bucket_name key script} {
+    if [exists $bucket_name $key] {
+      get $bucket_name $key
+    } else {
+      put $bucket_name $key [interp_eval $script]
+    }
+  }
+  
+  proc delete {bucket_name key} {
+    buckets::import $bucket_name
+    ensure_key_exists $bucket_name $key
+    unset bucket($key)
+  }
+
+  proc ensure_key_exists {bucket_name key} {
+    if ![exists $bucket_name $key] {
+      error "bucket \"$bucket_name\" doesn't have key \"$key\""
+    }
+  }
+}
+
+namespace eval commands {
+  meta_proc cache delete exists fetch get keys put
+}

src/smeggdrop/smeggdrop/commands/dict.tcl

@@ -0,0 +1,39 @@
+namespace eval dict {
+  variable cache 
+  array set cache {}
+        
+  variable cache_times
+  array set cache_times {}
+    
+  proc file_is_cached? filename {
+    info exists ::dict::cache($filename)
+  }
+    
+  proc file_has_changed? filename {
+    if ![info exists ::dict::cache_times($filename)] {
+      puts ""
+      return 1
+    }
+    expr {[file mtime $filename] != $::dict::cache_times($filename)}
+  }
+
+  proc cache_dictionary filename {
+    set file [open $filename r]
+    set ::dict::cache($filename) [split [read $file] \n]
+    set ::dict::cache_times($filename) [clock seconds]
+    close $file 
+  }
+
+  proc get_dictionary filename {
+    if [file_has_changed? $filename] {
+      cache_dictionary $filename
+    }
+    return $::dict::cache($filename)
+  }
+}
+
+namespace eval commands {
+  proc words {} {
+    dict::get_dictionary "$::SMEGGDROP_ROOT/data/words"
+  }
+}

src/smeggdrop/smeggdrop/commands/encoding.tcl

@@ -0,0 +1,8 @@
+namespace eval commands {
+  proc encoding args {
+    if {[string match s* [lindex $args 0]] && [llength $args] > 1} {
+      error "can't modify system encoding"
+    }
+    apply ::encoding $args
+  }
+}

src/smeggdrop/smeggdrop/commands/history.tcl

@@ -0,0 +1,11 @@
+namespace eval commands {
+  proc history {{start HEAD}} {
+    if {[set revision [$::versioned_interpreter git rev-parse --revs-only $start]] eq ""} return
+    set revisions [$::versioned_interpreter git rev-list "--pretty=format:%at%n%an <%ae>%n%s" -n 10 $revision]
+    set result {}
+    foreach {commit date author summary} [split $revisions \n] {
+      lappend result [list [lindex $commit 1] $date $author $summary]
+    }
+    return $result
+  }
+}

src/smeggdrop/smeggdrop/commands/http.tcl

@@ -0,0 +1,222 @@
+# 5 requests, per interpreter eval, per channel (at most 25 requests per minute)
+if ![info exists smeggdrop_http_requests_per_eval] {set smeggdrop_http_requests_per_eval 5}
+if ![info exists smeggdrop_http_request_interval]  {set smeggdrop_http_request_interval  60}
+if ![info exists smeggdrop_http_request_limit]     {set smeggdrop_http_request_limit     25}
+if ![info exists smeggdrop_http_post_limit]        {set smeggdrop_http_post_limit        150000}
+if ![info exists smeggdrop_http_transfer_limit]    {set smeggdrop_http_transfer_limit    150000}
+if ![info exists smeggdrop_http_time_limit]        {set smeggdrop_http_time_limit        5000}
+
+package require http
+package require TclCurl
+
+namespace eval httpx {
+  http::config -useragent {Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_5_6; en-us) AppleWebKit/525.27.1 (KHTML, like Gecko) Version/3.2.1 Safari/525.27.1}
+
+  variable options
+  proc option {name args} {
+    variable options
+    eval [concat [list set options($name)] $args]
+  }  
+
+  option requests_per_eval $::smeggdrop_http_requests_per_eval
+  option request_interval  $::smeggdrop_http_request_interval
+  option request_limit     $::smeggdrop_http_request_limit
+  option post_limit        $::smeggdrop_http_post_limit
+  option transfer_limit    $::smeggdrop_http_transfer_limit
+  option time_limit        $::smeggdrop_http_time_limit
+  
+  variable requests
+  array set requests {}
+
+  proc enforce_limits {} {
+    variable requests
+    array set current [limit_info]
+    
+    set eval_request_count 0
+    set threshold [expr {$current(seconds) - [option request_interval]}]
+    set threshold_request_count 0
+    
+    foreach limit_info [requests] {
+      array set request $limit_info
+      if {$request(eval_count) == $current(eval_count)} {
+        if {[incr eval_request_count] >= [option requests_per_eval]} {
+          error "too many HTTP requests in this eval (max [option requests_per_eval] requests)"
+        }
+      } elseif {$request(seconds) >= $threshold} {
+        if {[incr threshold_request_count] >= [option request_limit]} {
+          error "too many HTTP requests (max [option request_limit] requests in [option request_interval] seconds)"
+        }
+      }
+    }
+  }
+
+  proc update_limits {} {
+    variable requests
+    array set current [limit_info]
+    set old_requests [requests]
+    set new_requests [list [array get current]]
+    set threshold [expr {$current(seconds) - [option request_interval]}]
+    
+    foreach limit_info $old_requests {
+      array set request $limit_info
+      if {$request(seconds) >= $threshold} {
+        lappend new_requests $limit_info
+      }
+    }
+
+    set requests([limit_key]) $new_requests
+    return
+  }
+
+  proc requests {} {
+    variable requests
+    if [info exists requests([limit_key])] {
+      set requests([limit_key])
+    } else {
+      list
+    }
+  }
+
+  proc limit_key {} {
+    ::commands::get channel
+  }
+  
+  proc limit_info {} {
+    list seconds [clock seconds] eval_count [::commands::get eval_count]
+  }
+    
+  proc http_proc {name args body} {
+    set new_body [list]
+    lappend new_body [list enforce_limits]
+    lappend new_body "if {\[catch [list $body] {}] == 1} {error \[set {}]}"
+    lappend new_body [list update_limits]
+    lappend new_body [list set {}]
+    set new_body [join $new_body \;]
+    proc $name $args $new_body
+  }
+    
+  proc http_read_progress_callback {token total current} {
+    puts "Callback: $token $total $current"
+    upvar #0 $token state
+    if {$current > [option transfer_limit]} {
+      http::reset $token "transfer exceeded [option transfer_limit] bytes"
+    }
+  }
+    
+  proc http_handle_token token {
+    upvar #0 $token state
+    
+    set status $state(status)
+    
+    if {$status ne "ok"} {
+      http::cleanup $token
+      error $status
+    }
+        
+    set ret [list]
+    lappend ret [http::ncode $token]
+    lappend ret $state(meta)
+    lappend ret $state(body)
+    http::cleanup $token
+    return $ret
+  }
+
+    
+
+  proc http_get url {
+      set curlHandle [curl::init]
+      set html {}
+      array set http_resp_header [list]
+      $curlHandle configure -url $url -nosignal 1 -bodyvar html -headervar http_resp_header
+      catch { $curlHandle perform } curlErrorNumber
+      if { $curlErrorNumber != 0 } {
+          error [curl::easystrerror $curlErrorNumber]
+      }
+      set ret [list]
+      lappend ret [$curlHandle getinfo responsecode]
+      lappend ret [array get http_resp_header]
+      lappend ret $html
+      array unset http_resp_header
+      $curlHandle cleanup
+
+      return $ret
+  }
+
+  http_proc head url {
+      set resp [http_get $url]
+      #puts [lindex $resp 1]
+    #puts "We have the token! $url"
+      return [lindex $resp 1]
+    #set token [http::geturl $url -validate 1 -timeout [option time_limit]]
+    #http_handle_token $token
+  }
+    
+
+
+    proc http_post {url body} {
+      set curlHandle [curl::init]
+      set html {}
+      $curlHandle configure -url $url -nosignal 1 -bodyvar html -post 1 -postfields $body
+      catch { $curlHandle perform } curlErrorNumber
+      if { $curlErrorNumber != 0 } {
+          error [curl::easystrerror $curlErrorNumber]
+      }
+      set ret [list]
+      lappend ret [$curlHandle getinfo responsecode]
+      lappend ret {} 
+      # bad
+      lappend ret $html
+
+      $curlHandle cleanup
+
+      return $ret
+  }
+
+
+
+  http_proc get url {
+    #http::register http 80 socket
+    #puts "GET $url"
+    set html [http_get $url]
+    #puts $html
+    #puts "We have the token! $url"
+    return $html
+    
+    #set token [http::geturl $url \
+    #   -blocksize 1024 \
+    #   -timeout   [option time_limit] \
+    #   -progress  ::httpx::http_read_progress_callback]
+    #http_handle_token $token
+  }
+    
+  http_proc post {url body args} {
+    #http::register http 80 socket
+    #puts "GET $url"
+
+    if [llength $args] {
+      set body [eval http::formatQuery [concat [list $body] $args]]
+    }
+
+    if {[string length "$body"] > [option post_limit]} {
+      error "post body exceeds [option post_limit] bytes"
+    }
+
+    set html [http_post $url $body]
+    #puts $html
+    #puts "We have the token! $url"
+    return $html
+
+        
+    #set token [http::geturl $url \
+    #  -blocksize 1024 \
+    #  -timeout   [option time_limit] \
+    #  -progress  ::httpx::http_read_progress_callback \
+    #  -query     $body]
+        
+    #http_handle_token $token
+  }
+}
+
+namespace eval commands {
+  meta_proc http -namespace httpx head get post
+}

src/smeggdrop/smeggdrop/commands/irc.tcl

@@ -0,0 +1,25 @@
+namespace eval commands {
+  proc names {} {
+    variable channel
+    return [chanlist $channel]
+  }
+  
+  proc nick {} {
+    variable nick
+    return $nick
+  }
+  
+  proc channel {} {
+    variable channel
+    return $channel
+  }
+  
+  proc hostmask {{who ""}} {
+    variable channel
+    variable mask
+    
+    set hostmask [getchanhost $who $channel]
+    if {$hostmask eq ""} {set hostmask $mask}
+    return $hostmask
+  }
+}

src/smeggdrop/smeggdrop/commands/log.tcl

@@ -0,0 +1,19 @@
+if [info exists smeggdrop_log_max_lines] {
+  #bind pubm - * pubm:smeggdrop_log_line
+  array set smeggdrop_log_lines {}
+
+  proc pubm:smeggdrop_log_line {nick mask hand channel line} {
+    lappend ::smeggdrop_log_lines($channel) [list [clock seconds] $nick $mask $line]
+    if {[set length [llength $::smeggdrop_log_lines($channel)]] >= $::smeggdrop_log_max_lines} {
+      set ::smeggdrop_log_lines($channel) \
+        [lrange $::smeggdrop_log_lines($channel) [expr $length - $::smeggdrop_log_max_lines] end]
+    }
+  }
+
+  namespace eval commands {
+    proc log {} {
+      variable channel
+      set ::smeggdrop_log_lines($channel)
+    }
+  }
+}

src/smeggdrop/smeggdrop/commands/meta.tcl

@@ -0,0 +1,17 @@
+namespace eval meta {
+  proc eval_count {} {
+    commands::get eval_count
+  }
+  
+  proc line {} {
+    commands::get line
+  }
+  
+  proc uptime {} {
+    $::versioned_interpreter uptime
+  }
+}
+
+namespace eval commands {
+  meta_proc meta
+}

src/smeggdrop/smeggdrop/commands/publish.tcl

@@ -0,0 +1,32 @@
+if [info exists smeggdrop_publish_url] {
+  namespace eval commands {
+    variable last_publish 0
+
+    proc publish message {
+      variable last_publish
+      set time_since_last_publish [expr [clock seconds] - $last_publish]
+      if {$time_since_last_publish < 5} {
+        error "can't publish for another [expr 5 - $time_since_last_publish] secs"
+      }
+
+      set file [open /tmp/publish-data w]
+      fconfigure $file -encoding utf-8
+      puts $file $message
+      close $file
+
+      set cmd [list exec env \
+        PUBLISH_HOSTNAME=$::smeggdrop_publish_hostname \
+        PUBLISH_USERNAME=$::smeggdrop_publish_username \
+        PUBLISH_PASSWORD=$::smeggdrop_publish_password \
+        PUBLISH_FILENAME=$::smeggdrop_publish_filename \
+        $::SMEGGDROP_ROOT/bin/publish.pl < /tmp/publish-data]
+
+      if [catch $cmd result] {
+        error "publish failed"
+      } else {
+        set last_publish [clock seconds]
+        return $::smeggdrop_publish_url
+      }
+    }
+  }
+}

src/smeggdrop/smeggdrop/commands/sha1.tcl

@@ -0,0 +1,7 @@
+package require sha1
+
+namespace eval commands {
+  proc sha1 string {
+    ::sha1::sha1 $string
+  }
+}

src/smeggdrop/smeggdrop/interpx.tcl

@@ -0,0 +1,401 @@
+package require snit
+package require Tclx
+
+snit::type interpx {
+  variable interp
+  variable private_key
+  variable procs_touched_during_eval -array {}
+  variable vars_touched_during_eval -array {}
+  variable timed_out
+  
+    option -onproccreated
+    option -onprocupdated
+    option -onprocdestroyed
+    option -onvarcreated
+    option -onvarupdated
+    option -onvardestroyed
+    option -timeout 6000
+  
+  constructor args {
+    set private_key [expr rand()]
+    $self configurelist $args
+    $self initialize_interpreter
+  }
+  
+  destructor {
+    catch {interp delete $interp}
+  }
+  
+  # introspection
+  method procs {} {
+    $self . info procs
+  }
+  
+  method vars {} {
+    $self . info vars
+  }
+  
+  method scalars {} {
+    set result {}
+    foreach var [$self vars] {
+      if [$self has scalar $var] {
+        lappend result $var
+      }
+    }
+    return $result
+  }
+  
+  method arrays {} {
+    set result {}
+    foreach var [$self vars] {
+      if [$self has array $var] {
+        lappend result $var
+      }
+    }
+    return $result
+  }
+  
+  method serialize {} {
+    set result {}
+    
+    foreach var [$self vars] {
+      lappend result [$self inspect var $var]
+    }
+    
+    foreach proc [$self procs] {
+      lappend result [$self inspect proc $proc]
+    }
+    
+    join $result \n
+  }
+  
+method {inspect var} var {
+    if [$self has array $var] {
+      $self inspect array $var
+    } else {
+      $self inspect scalar $var
+    }
+  }
+  
+method {inspect scalar} scalar {
+    if [$self has scalar $scalar] {
+      list set $scalar [$self . set $scalar]
+    } else {
+      error "can't read \"$scalar\": no such scalar"
+    }
+  }
+  
+method {inspect array} array {
+    if [$self has array $array] {
+      list array set $array [$self . array get $array]
+    } else {
+      error "can't read \"$array\": no such array"
+    }
+  }
+  
+method {inspect proc} proc {
+    set args {}
+    foreach arg [$self . info args $proc] {
+      if [$self . info default $proc $arg ::interpx::default] {
+        set arg [list $arg [$self . set ::interpx::default]]
+        $self . unset ::interpx::default
+      }
+      lappend args $arg
+    }
+
+    list proc $proc $args [$self . info body $proc]
+  }
+  
+  # aliasing
+  method alias {name command args} {
+    apply [list $interp alias $name $command] $args
+  }
+  
+  # evaluation
+  method eval args {
+    if {[lindex $args 0] eq "-notimeout"} {
+      set timeout 0
+      set script [lindex $args 1]
+    } else {
+      set timeout 1
+      set timed_out 0
+      set script [lindex $args 0]
+    }
+
+    array set procs_existing_before_eval [list_to_array [$self procs]]
+    array set vars_existing_before_eval [list_to_array [$self vars]]
+
+    unset procs_touched_during_eval
+    array set procs_touched_during_eval {}
+
+    unset vars_touched_during_eval
+    array set vars_touched_during_eval {}
+    
+    if $timeout {
+      signal trap SIGALRM [list ::interpx::timeout $self $private_key]
+      alarm [expr {[$self cget -timeout] / 1000.0}]
+    }
+    
+    set code [catch {$interp eval $script} result]
+    
+    if $timeout {
+      alarm 0
+      if $timed_out {
+        set code 1
+        set result "timeout ([$self cget -timeout]ms)"
+      }
+    }
+    
+    foreach proc [$self procs] {
+      if ![info exists procs_existing_before_eval($proc)] {
+        $self did create proc $proc
+      } else {
+        if [info exists procs_touched_during_eval($proc)] {
+          $self did update proc $proc
+        }
+        unset procs_existing_before_eval($proc)
+      }
+    }
+    
+    foreach proc [array names procs_existing_before_eval] {
+      $self did destroy proc $proc
+    }
+
+    foreach var [$self vars] {
+      if ![var_is_traceable $var] continue
+      
+      if ![info exists vars_existing_before_eval($var)] {
+        $self did create var $var
+      } else {
+        if [info exists vars_touched_during_eval($var)] {
+          $self did update var $var
+        }
+        unset vars_existing_before_eval($var)
+      }
+    }
+    
+    foreach var [array names vars_existing_before_eval] {
+      if ![var_is_traceable $var] continue
+      $self did destroy var $var
+    }
+    
+    return -code $code $result
+  }
+  
+  method {did timeout} key {
+    if {$key eq $private_key} {
+      set timed_out 1
+      error timeout
+    }
+  }
+  
+  # traces
+  method {trace var} var {
+    if [var_is_traceable $var] {
+      $self . trace add variable $var write [$self trace_command_for_var $var]
+    }
+  }
+
+  method {untrace var} var {
+    if [var_is_traceable $var] {
+      $self . trace remove variable $var write [$self trace_command_for_var $var]
+    }
+  }
+  
+  method {did touch var} {key var args} {
+    if {$key eq $private_key} {
+      set vars_touched_during_eval($var) {}
+    }
+  }
+
+  method trace_command_for_var var {
+    list ::interpx::touched_var $private_key $var
+  }
+
+  # callbacks
+  method {did create proc} proc {
+    $self fire proccreated $proc
+  }
+  
+  method {did update proc} proc {
+    $self fire procupdated $proc
+  }
+  
+  method {did destroy proc} proc {
+    $self fire procdestroyed $proc
+  }
+  
+  method {did create var} var {
+    $self trace var $var
+    $self fire varcreated $var
+  }
+  
+  method {did update var} var {
+    $self fire varupdated $var
+  }
+  
+  method {did destroy var} var {
+    $self untrace var $var
+    $self fire vardestroyed $var
+  }
+  
+  method fire {event args} {
+      if {[set handler [$self cget -on$event]] ne ""} {
+      uplevel #0 [concat $handler $args]
+    }
+  }
+  
+  # internal implementations of builtins
+  method proc args {
+    set name [lindex $args 0]
+    if [$self has builtin $name] {
+      error "can't override builtin \"$name\""
+    }
+
+    set result [apply [list $self . proc] $args]
+    set procs_touched_during_eval($name) {}
+    return $result
+  }
+  
+  method rename args {
+    set name [lindex $args 0]
+    if [$self has builtin $name] {
+      error "can't rename builtin \"$name\""
+    }
+
+    set result [apply [list $self . rename] $args]
+    set procs_touched_during_eval($name) {}
+    return $result
+  }
+  
+  method for args {
+    set body [concat "::interpx::noop;" [lindex $args 3]]
+    apply [list $self . for] [lreplace $args 3 3 $body]
+  }
+  
+  method foreach args {
+    set body [concat "::interpx::noop;" [lindex $args end]]
+    apply [list $self . foreach] [lreplace $args end end $body]
+  }
+  
+  method while args {
+    set body [concat "::interpx::noop;" [lindex $args 1]]
+    apply [list $self . while] [lreplace $args 1 1 $body]
+  }
+  
+  # predicates
+  method {has var} var {
+    $self . info exists $var
+  }
+  
+  method {has command} command {
+    expr {[llength [$self . info commands $command]] == 1}
+  }
+
+  method {has scalar} scalar {
+    expr {[$self has var $scalar] && ![$self has array $scalar]}
+  }
+  
+  method {has array} array {
+    $self . array exists $array
+  }
+
+  method {has proc} proc {
+    expr {[llength [$self . info proc $proc]] == 1}
+  }
+  
+  method {has builtin} builtin {
+    expr {[$self has command $builtin] && ![$self has proc $builtin]}
+  }
+  
+  # private
+  method initialize_interpreter {} {
+    set interp [interp create -safe]
+    $self preserve array
+    $self preserve error
+    $self preserve eval
+    $self preserve info
+    $self preserve set
+    $self preserve unset
+    $self hide interp
+    $self hide namespace
+    $self hide trace
+    $self hide vwait
+    $self reimplement for
+    $self reimplement foreach
+    $self reimplement proc
+    $self reimplement rename
+    $self reimplement while
+    $self unset_internal_vars
+    $self initialize_private_namespace
+    
+    puts "initialize_interpreter inside interpx finished"
+  }
+  
+  method unset_internal_vars {} {
+    foreach var [$self vars] {
+      $self . unset $var
+    }
+  }
+  
+  method initialize_private_namespace {} {
+    $self . namespace eval ::interpx {}
+    $interp alias ::interpx::noop expr 0
+    $interp alias ::interpx::timeout ::interpx::timeout
+    $self expose {did touch var} ::interpx::touched_var
+    
+    puts "finished initialize_private_namespace inside interpx"
+  }
+  
+  method hide command {
+    $interp hide $command
+  }
+  
+  method restore command {
+    $interp alias $command $interp invokehidden $command
+  }
+  
+  method preserve command {
+    $self hide $command
+    $self restore $command
+  }
+  
+  method expose {command {as {}}} {
+    if {$as eq ""} {
+      set as $command
+    }
+    $interp alias $as $self $command
+  }
+  
+  method reimplement command {
+    $self hide $command
+    $self expose $command
+  }
+  
+  method . {command args} {
+    apply [list $interp invokehidden $command] $args
+  }
+  
+  # helpers
+  proc list_to_array {list {value {}}} {
+    set result {}
+    foreach key $list {
+      lappend result $key $value
+    }
+    return $result
+  }
+  
+  proc apply {command arguments} {
+    uplevel [concat $command $arguments]
+  }
+  
+  proc var_is_traceable var {
+    expr {$var ne "errorCode" && $var ne "errorInfo"}
+  }
+}
+
+namespace eval interpx {
+  proc timeout {interpx private_key} {
+    $interpx did timeout $private_key
+  }
+}

src/smeggdrop/smeggdrop/meta_proc.tcl

@@ -0,0 +1,38 @@
+namespace eval meta_proc {
+  proc call {namespace name arguments commands} {
+    set command [lindex $arguments 0]
+    set arguments [lrange $arguments 1 end]    
+    if ![llength $commands] {
+      set commands [lsort [namespace eval ::$namespace {info procs}]]
+    }
+    
+    set usage [join [concat [lrange $commands 0 end-1] [list "or [lindex $commands end]"]] ", "]
+    set matches [lsearch -all -inline -glob $commands $command*]
+    
+    if {$command eq ""} {
+      error "wrong # args: should be \"$name command ?arg arg ...?\""
+    } elseif {[llength $matches] == 0} {
+      error "bad command \"$command\": must be $usage"
+    } elseif {[llength $matches] > 1} {
+      error "ambiguous command \"$command\": must be $usage"
+    } else {
+      set code [catch [concat [list ::${namespace}::[lindex $matches 0]] $arguments] result]
+      if {$code && [regexp {^wrong # args} $result]} {
+        error [string map [list ::${namespace}:: "$name "] $result]
+      } else {
+        return -code $code $result
+      }
+    }
+  }
+}
+
+proc meta_proc {name args} {
+  if {[lindex $args 0] eq "-namespace"} {
+    set namespace [lindex $args 1]
+    set args [lrange $args 2 end]
+  } else {
+    set namespace $name
+  }
+  
+  uplevel [list proc $name args "meta_proc::call [list $namespace] [list $name] \$args [list $args]"]
+}

src/smeggdrop/smeggdrop/smeggdrop.tcl

@@ -0,0 +1,190 @@
+source $SMEGGDROP_ROOT/smeggdrop/versioned_interpreter.tcl
+source $SMEGGDROP_ROOT/smeggdrop/commands.tcl
+
+namespace eval smeggdrop {
+  proc split_lines {string length} {
+    set lines [list]
+
+    foreach source_line [split $string \n] {
+      set line ""
+      set formatting [empty_formatting]
+      
+      foreach {format text} [split_on_formatting $source_line] {
+        set formatting [parse_formatting $format $formatting]
+        set chars [split $text {}]
+        if ![llength $chars] {set chars [list {}]}
+        
+        foreach char $chars {
+          if ![buffer line $length $format$char] {
+            lappend lines $line
+            set line [unparse_formatting $formatting]$char
+          }
+          set format ""
+        }
+      }
+
+      lappend lines $line
+    }
+    
+    return $lines
+  }
+  
+  proc buffer {var length char} {
+    upvar $var line
+
+    if {![string bytelength $line] && [string index $char 0] eq "\017"} {
+      set char [string range $char 1 end]
+    }
+
+    if {[string bytelength $line$char] <= $length} {
+      append line $char
+      return 1
+    } else {
+      return 0
+    }
+  }
+  
+  proc line_length_for channel {
+    expr 512 - [string length ":$::botname PRIVMSG $channel :\r\n"]
+  }
+  
+  proc split_on_formatting string {
+    set result [list]
+    while {[string length $string]} {
+      regexp {^(\003((\d{0,2})(,(\d{0,2}))?)?|\002|\037|\026|\017)?([^\003\002\037\026\017]*)(.*)} \
+        $string {} format {} {} {} {} text remainder
+      if {$format eq ""} {set format \017}
+      lappend result $format $text
+      set string $remainder
+    }
+    return $result
+  }
+
+  proc empty_formatting {} {
+    list b 0 u 0 r 0 o 0 c 0 fg -1 bg -1
+  }
+  
+  proc parse_formatting {str {state {}}} {
+    if {$state eq ""} {
+      array set f [empty_formatting]
+    } else {
+      array set f $state
+    }
+    set f(c) [set f(o) 0]
+    switch -- [string index $str 0] [list \
+      \003 {
+        regexp {^\003((\d*)(,(\d*))?)?} $str {} a b {} c
+        if {$a eq ""} {
+          set f(fg) [set f(bg) -1]
+          set f(c) 1
+        }
+        if {!($b eq "")} {
+          set f(fg) $b
+        }
+        if {!($c eq "")} {
+          set f(bg) $c
+        }
+      } \002 {
+        set f(b) [expr !$f(b)]
+      } \037 {
+        set f(u) [expr !$f(u)]
+      } \026 {
+        set f(r) [expr !$f(r)]
+      } \017 {
+        set f(o) 1
+      }]
+    array get f
+  }
+
+  proc unparse_formatting {formatting {state {}}} {
+    if {$state eq ""} {
+      array set old [empty_formatting]
+    } else {
+      array set old $state
+    }
+    array set new $formatting
+    if $old(o) {
+      array set old [empty_formatting]
+    }
+    if $new(o) {
+      return \017
+    }
+    set ret ""
+    foreach k {b u r} {
+      if {$old($k) != $new($k)} {
+        append ret [string map {b \002 u \037 r \026} $k]
+      }
+    }
+    return $ret[unparse_formatting_color [array get new] [array get old]]
+  }
+  
+  proc unparse_formatting_color {new old} {
+    array set n $new
+    array set o $old
+    if {($n(fg) == -1 && $n(bg) == -1) || ($n(fg) == $o(fg) && $n(bg) == $o(bg))} return
+    set ret \003
+    if !$n(c) {
+      if {$n(fg) != -1 && $n(fg) != $o(fg)} {
+        append ret [format %02s $n(fg)]
+      }
+      if {$n(bg) != -1 && $n(bg) != $o(bg)} {
+        append ret ,[format %02s $n(bg)]
+      }
+    }
+    return $ret
+  }
+
+  proc to_str string {
+    set result ""
+    foreach char [split $string {}] {
+      if [regexp {[$\\"\[]} $char] {
+        append result \\$char
+      } elseif [is_unprintable $char] {
+        append result \\[format %03o [scan $char %c]]
+      } else {
+        append result $char
+      }
+    }
+    return "\"$result\""
+  }
+  
+  proc is_unprintable char {
+    set c [scan $char %c]
+    expr {$c < 32 || $c > 126}
+  }
+}
+
+proc interp_eval script {
+  $::versioned_interpreter interpx . eval $script
+}
+
+proc pub:tcl:perform {nick mask hand channel line} {
+  global versioned_interpreter
+
+  commands::configure nick mask hand channel line
+  commands::increment_eval_count
+  
+  set author "$nick on $channel <$mask>"
+
+  if [catch {$versioned_interpreter eval $line $author} output] {
+    set output "error: $output"
+  }
+
+  putlog $output
+  return $output
+}
+
+if [info exists versioned_interpreter]  {$versioned_interpreter destroy}
+if ![info exists smeggdrop_state_path]  {set smeggdrop_state_path  state}
+if ![info exists smeggdrop_max_lines]   {set smeggdrop_max_lines   10}
+if ![info exists smeggdrop_timeout]     {set smeggdrop_timeout     5000}
+if ![info exists smeggdrop_trigger]     {set smeggdrop_trigger     tcl}
+
+set versioned_interpreter [versioned_interpreter create %AUTO% \
+  $smeggdrop_state_path -verbose true -logcommand ::putlog -timeout $smeggdrop_timeout]
+
+foreach alias [namespace eval commands {info procs}] {
+  if {[lsearch -exact [commands::get hidden_procs] $alias] == -1} {
+    $versioned_interpreter alias $alias ::commands::$alias
+  }
+}

src/smeggdrop/smeggdrop/versioned_interpreter.tcl

@@ -0,0 +1,385 @@
+package require snit
+package require sha1
+source $SMEGGDROP_ROOT/smeggdrop/interpx.tcl
+
+snit::type versioned_interpreter {
+  variable state_path
+  variable interpx
+  variable procs
+  variable vars
+  variable aliases {}
+  variable is_inside_eval 0
+  variable state_changed 0
+  variable created_at
+  
+  option -verbose    -readonly true -default false
+  option -timeout    -readonly true -default 5000
+  option -logcommand -readonly true -default {puts stderr}
+    
+  constructor {path_to_state args} {
+    set state_path $path_to_state
+    set created_at [clock seconds]
+    
+    $self configurelist $args
+    if [$self cget -verbose] {
+      proc log message [list apply [$self cget -logcommand] {$message}]
+    }
+
+    $self initialize_interpreter
+  }
+  
+  destructor {
+    catch {$interpx destroy}
+  }
+  
+  method uptime {} {
+    expr [clock seconds] - $created_at
+  }
+  
+  method interpx args {
+    apply $interpx $args
+  }
+
+  method initialize_interpreter {} {
+    if [info exists interpx] {
+      $interpx destroy
+    }
+    
+    set interpx [interpx create %AUTO% \
+                     -onproccreated    [list $self did create proc]  \
+                     -onprocupdated    [list $self did update proc]  \
+                     -onprocdestroyed  [list $self did destroy proc] \
+                     -onvarcreated     [list $self did create var]   \
+                     -onvarupdated     [list $self did update var]   \
+                     -onvardestroyed   [list $self did destroy var]  \
+                     -timeout          [$self cget -timeout]
+                ]
+    
+    $self initialize_repository
+    $self load_state_from_repository
+    $self restore_interpreter_aliases
+  }
+  
+  method initialize_repository {} {
+    mkdir_p [$self path]
+    mkdir_p [$self path procs]
+    mkdir_p [$self path vars]
+    touch [$self path procs _index]
+    touch [$self path vars _index]
+    
+    if ![$self repository_exists] {
+      $self git init
+      $self git add procs vars
+      $self commit "Created repository"
+    }
+  }
+  
+  method load_state_from_repository {{revision HEAD}} {
+    $self git checkout -f $revision
+
+    set time [clock clicks]
+    log "Loading interpreter state..."
+
+    set script {}
+    lappend script [$self read_procs_from_repository]
+    set fn [$self path "stolen-treasure.tcl"]
+    set ff [open $fn r]
+    fconfigure $ff -encoding utf-8
+    set fuku [read $ff]
+    set hng [split $fuku "\n"]
+    lappend script {*}$hng
+    lappend script [$self read_vars_from_repository]
+#    puts [join $script \n]
+# good luck curating this turd, I give up
+    $interpx eval -notimeout [join $script \n]
+    
+    log "State loaded ([format %.2f [expr {([clock clicks] - $time) / 1000000.0}]] sec)"
+  }
+  
+  method read_procs_from_repository {} {
+    set procs [index create %AUTO% [$self path procs _index]]
+    set script {}
+    foreach proc [$procs keys] {
+      lappend script [$self read proc $proc]
+    }
+    join $script \n
+  }
+  
+  method read_vars_from_repository {} {
+    set vars [index create %AUTO% [$self path vars _index]]
+    set script {}
+    foreach var [$vars keys] {
+      lappend script [$self read var $var]
+    }
+    join $script \n
+  }
+  
+  method {read var} var {
+    set kind [lindex [set kind_and_value [$self read object var $var]] 0]
+    if {$kind eq "scalar"} {
+      list set $var [lindex $kind_and_value 1]
+    } elseif {$kind eq "array"} {
+      list array set $var [lindex $kind_and_value 1]
+    }
+  }
+  
+  method {read proc} proc {
+    concat [list proc $proc] [$self read object proc $proc]
+  }
+  
+  method {read object} {kind key} {
+    set index ${kind}s
+    set filename [$self path $index [[set $index] get $key]]
+    set file [open $filename r]
+    fconfigure $file -encoding utf-8
+    set value [read $file]
+    close $file
+    return $value
+  }
+  
+  method {write var} var {
+    set content [lindex [$interpx inspect var $var] end]
+    if [$interpx has scalar $var] {
+      set value [list scalar $content]
+    } elseif [$interpx has array $var] {
+      set value [list array $content]
+    }
+    $self write object var $var $value
+  }
+  
+  method {write proc} proc {
+    set value [lrange [$interpx inspect proc $proc] 2 end]
+    $self write object proc $proc $value
+  }
+  
+  method {write object} {kind key value} {
+    set index ${kind}s
+    set name [[set $index] get $key]
+    set filename [$self path $index $name]
+    set file [open $filename w]
+    fconfigure $file -encoding utf-8
+    puts $file $value
+    close $file
+    $self git add [file join $index $name]
+    set state_changed 1
+  }
+  
+  method delete {kind key} {
+    set index ${kind}s
+    set name [[set $index] delete $key]
+    rm_f [$self path $index $name]
+    set state_changed 1
+  }
+  
+  method alias {name command args} {
+    lappend aliases [list $name $command $args]
+    apply [list $interpx alias $name $command] $args
+  }
+  
+  method restore_interpreter_aliases {} {
+    foreach alias $aliases {
+      apply [list $interpx alias] [concat [lrange $alias 0 end-1] [lindex $alias end]]
+    }
+  }
+  
+  method eval {script {author "Administrator <admin@localhost>"} {message ""}}  {
+    set is_inside_eval 1
+    set code [catch {$interpx eval $script} result]
+    set is_inside_eval 0
+    
+    if $state_changed {
+      $procs save_to_file
+      $vars save_to_file
+    
+      if {$message eq ""} {
+        set message $script
+      }
+    
+      if {[string length $message] > 1024} {
+        set message [string range $message 0 1020]...
+      }
+    
+      $self commit "Evaluated $message" $author
+      
+      set state_changed 0
+    }
+    
+    return -code $code $result
+  }
+  
+  method rollback {{revision HEAD^}} {
+    set revision  [$self git rev-parse --revs-only $revision]
+    set revisions [$self revisions $revision]
+
+    foreach revision $revisions {
+      $self git revert -n $revision
+    }
+
+    $self commit "Rolled back to revision $revision\nReverts [join $revisions]"
+    $self initialize_interpreter
+  }
+  
+  method {did create proc} proc {
+    if !$is_inside_eval return
+    $procs put $proc [sha1 $proc]
+    $self write proc $proc
+  }
+  
+  method {did update proc} proc {
+    if !$is_inside_eval return
+    $self write proc $proc
+  }
+  
+  method {did destroy proc} proc {
+    if !$is_inside_eval return
+    $self delete proc $proc
+  }
+  
+  method {did create var} var {
+    if !$is_inside_eval return
+    $vars put $var [sha1 $var]
+    $self write var $var
+  }
+  
+  method {did update var} var {
+    if !$is_inside_eval return
+    $self write var $var
+  }
+  
+  method {did destroy var} var {
+    if !$is_inside_eval return
+    $self delete var $var
+  }
+  
+  # private
+  method path args {
+    apply [list file join $state_path] $args
+  }
+  
+  method git args {
+    set pwd [pwd]
+    cd [$self path]
+    set code [catch {apply [list exec git] $args} result]
+    cd $pwd
+    return -code $code $result
+  }
+  
+  method commit {message {author "Administrator <admin@localhost>"}} {
+    set code [catch {$self git commit --author $author -am $message} result]
+    if {$code && [regexp -line {^nothing (added )?to commit} $result]} {
+      set code 0 
+    }
+
+    if [regexp -line {^origin$} [$self git remote]] {
+      $self git push origin master 
+    }
+
+    return -code $code $result
+  }
+  
+  method revisions {{until ""}} {
+    set args HEAD
+    if {$until ne ""} {
+      lappend args ^$until
+    }
+    apply [list $self git rev-list] $args
+  }
+  
+  method repository_exists {} {
+    catch {$self git status} result
+    set has_git_dir [file isdirectory [$self path .git]]
+    expr {$has_git_dir && ![regexp {Not a git repository} $result]}
+  }
+
+  proc touch filename {
+    exec touch $filename
+  }
+  
+  proc mkdir_p directory {
+    exec mkdir -p $directory
+  }
+  
+  proc rm_f filename {
+    exec rm -f $filename
+  }
+  
+  proc exec args {
+    log "--> $args"
+    set command [concat $args |& cat]
+    set result [apply ::exec $command]
+    if {$result ne ""} {log $result}
+    return $result
+  }
+  
+  proc cd directory {
+    ::cd $directory
+    log "(in [pwd])"
+  }
+  
+  proc apply {command arguments} {
+    uplevel [concat $command $arguments]
+  }
+  
+  proc sha1 string {
+    ::sha1::sha1 $string
+  }
+  
+  proc log message {
+  }
+}
+
+snit::type versioned_interpreter::index {
+  variable filename
+  variable values -array {}
+  
+  constructor path {
+    set filename $path
+    $self load_from_file
+  }
+  
+  method load_from_file {} {
+    $self reset
+    set file [open $filename r]
+    fconfigure $file -encoding utf-8
+    foreach {key value} [read $file] {
+      $self put $key $value
+    }
+    close $file
+  }
+  
+  method save_to_file {} {
+    set file [open $filename w]
+    fconfigure $file -encoding utf-8
+    foreach key [$self keys] {
+      puts $file [list $key [$self get $key]]
+    }
+    close $file
+  }
+  
+  method reset {} {
+    unset values
+    array set values {}
+  }
+
+  method put {key value} {
+    set values($key) $value
+  }
+  
+  method get key {
+    set values($key)
+  }
+  
+  method delete key {
+    set value [$self get $key]
+    unset values($key)
+    return $value
+  }
+  
+  method has key {
+    info exists values($key)
+  }
+  
+  method keys {} {
+    lsort [array names values]
+  }
+}

src/tclstubswrapper/tclstubs.c

@@ -0,0 +1,6 @@
+#include <tcl.h>
+#include "tclstubs.h"
+
+const char * Tcl_InitStubs_wrap(Tcl_Interp * interp, char * wanted_version, int wantexact) {
+  return Tcl_InitStubs(interp,wanted_version,wantexact);
+  }

src/tclstubswrapper/tclstubs.h

@@ -0,0 +1 @@
+const char * Tcl_InitStubs_wrap(Tcl_Interp * interp, char * wanted_version, int wantexact);

state

@@ -0,0 +1 @@
+Subproject commit 9faea92d5bd3541b173ba0327b2b5b3d6f2000a3

tclcurl-fa

@@ -0,0 +1 @@
+Subproject commit bfba40e566eea65a9171f6f943c78958ffe0509d

tcllib

@@ -0,0 +1 @@
+Subproject commit 5e9393b769a69c2d93be2df8065166a71d6c9051

tclx

@@ -0,0 +1 @@
+Subproject commit 5c19ee9d60c2e6cf18b13589a665817b836373ef