diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..0a880f7 --- /dev/null +++ b/.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 diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index e0ea906..9b87bed 100644 --- a/GypsFulvus.cabal +++ b/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 diff --git a/src/Carrion/Plugin/TCL.hs b/src/Carrion/Plugin/TCL.hs new file mode 100644 index 0000000..b62f619 --- /dev/null +++ b/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 () diff --git a/src/Test-Carrion-TCL.hs b/src/Test-Carrion-TCL.hs new file mode 100644 index 0000000..eed8152 --- /dev/null +++ b/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) diff --git a/src/smeggdrop/smeggdrop.conf.default b/src/smeggdrop/smeggdrop.conf.default new file mode 100644 index 0000000..9fdc3ca --- /dev/null +++ b/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 diff --git a/src/smeggdrop/smeggdrop.tcl b/src/smeggdrop/smeggdrop.tcl new file mode 100644 index 0000000..d1be177 --- /dev/null +++ b/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 diff --git a/src/smeggdrop/smeggdrop/commands.tcl b/src/smeggdrop/smeggdrop/commands.tcl new file mode 100644 index 0000000..79b98ae --- /dev/null +++ b/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] + } +} diff --git a/src/smeggdrop/smeggdrop/commands/cache.tcl b/src/smeggdrop/smeggdrop/commands/cache.tcl new file mode 100644 index 0000000..bb8c074 --- /dev/null +++ b/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 +} diff --git a/src/smeggdrop/smeggdrop/commands/dict.tcl b/src/smeggdrop/smeggdrop/commands/dict.tcl new file mode 100644 index 0000000..c1e752d --- /dev/null +++ b/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" + } +} diff --git a/src/smeggdrop/smeggdrop/commands/encoding.tcl b/src/smeggdrop/smeggdrop/commands/encoding.tcl new file mode 100644 index 0000000..c739634 --- /dev/null +++ b/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 + } +} diff --git a/src/smeggdrop/smeggdrop/commands/history.tcl b/src/smeggdrop/smeggdrop/commands/history.tcl new file mode 100644 index 0000000..8649f1c --- /dev/null +++ b/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 + } +} diff --git a/src/smeggdrop/smeggdrop/commands/http.tcl b/src/smeggdrop/smeggdrop/commands/http.tcl new file mode 100644 index 0000000..6b39ff4 --- /dev/null +++ b/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 +} diff --git a/src/smeggdrop/smeggdrop/commands/irc.tcl b/src/smeggdrop/smeggdrop/commands/irc.tcl new file mode 100644 index 0000000..c733e9a --- /dev/null +++ b/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 + } +} diff --git a/src/smeggdrop/smeggdrop/commands/log.tcl b/src/smeggdrop/smeggdrop/commands/log.tcl new file mode 100644 index 0000000..4866357 --- /dev/null +++ b/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) + } + } +} diff --git a/src/smeggdrop/smeggdrop/commands/meta.tcl b/src/smeggdrop/smeggdrop/commands/meta.tcl new file mode 100644 index 0000000..b2e0ee7 --- /dev/null +++ b/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 +} diff --git a/src/smeggdrop/smeggdrop/commands/publish.tcl b/src/smeggdrop/smeggdrop/commands/publish.tcl new file mode 100644 index 0000000..2953191 --- /dev/null +++ b/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 + } + } + } +} diff --git a/src/smeggdrop/smeggdrop/commands/sha1.tcl b/src/smeggdrop/smeggdrop/commands/sha1.tcl new file mode 100644 index 0000000..c85a54b --- /dev/null +++ b/src/smeggdrop/smeggdrop/commands/sha1.tcl @@ -0,0 +1,7 @@ +package require sha1 + +namespace eval commands { + proc sha1 string { + ::sha1::sha1 $string + } +} diff --git a/src/smeggdrop/smeggdrop/interpx.tcl b/src/smeggdrop/smeggdrop/interpx.tcl new file mode 100644 index 0000000..23f450c --- /dev/null +++ b/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 + } +} diff --git a/src/smeggdrop/smeggdrop/meta_proc.tcl b/src/smeggdrop/smeggdrop/meta_proc.tcl new file mode 100644 index 0000000..e642551 --- /dev/null +++ b/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]"] +} diff --git a/src/smeggdrop/smeggdrop/smeggdrop.tcl b/src/smeggdrop/smeggdrop/smeggdrop.tcl new file mode 100644 index 0000000..72d248e --- /dev/null +++ b/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 + } +} diff --git a/src/smeggdrop/smeggdrop/versioned_interpreter.tcl b/src/smeggdrop/smeggdrop/versioned_interpreter.tcl new file mode 100644 index 0000000..4d5269e --- /dev/null +++ b/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 "} {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 "}} { + 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] + } +} diff --git a/src/tclstubswrapper/tclstubs.c b/src/tclstubswrapper/tclstubs.c new file mode 100644 index 0000000..a7a60f1 --- /dev/null +++ b/src/tclstubswrapper/tclstubs.c @@ -0,0 +1,6 @@ +#include +#include "tclstubs.h" + +const char * Tcl_InitStubs_wrap(Tcl_Interp * interp, char * wanted_version, int wantexact) { + return Tcl_InitStubs(interp,wanted_version,wantexact); + } diff --git a/src/tclstubswrapper/tclstubs.h b/src/tclstubswrapper/tclstubs.h new file mode 100644 index 0000000..31e2f93 --- /dev/null +++ b/src/tclstubswrapper/tclstubs.h @@ -0,0 +1 @@ +const char * Tcl_InitStubs_wrap(Tcl_Interp * interp, char * wanted_version, int wantexact); diff --git a/src/tclstubswrapper/tclstubs.o b/src/tclstubswrapper/tclstubs.o new file mode 100644 index 0000000..fdd316b Binary files /dev/null and b/src/tclstubswrapper/tclstubs.o differ diff --git a/state b/state new file mode 160000 index 0000000..9faea92 --- /dev/null +++ b/state @@ -0,0 +1 @@ +Subproject commit 9faea92d5bd3541b173ba0327b2b5b3d6f2000a3 diff --git a/tclcurl-fa b/tclcurl-fa new file mode 160000 index 0000000..bfba40e --- /dev/null +++ b/tclcurl-fa @@ -0,0 +1 @@ +Subproject commit bfba40e566eea65a9171f6f943c78958ffe0509d diff --git a/tcllib b/tcllib new file mode 160000 index 0000000..5e9393b --- /dev/null +++ b/tcllib @@ -0,0 +1 @@ +Subproject commit 5e9393b769a69c2d93be2df8065166a71d6c9051 diff --git a/tclx b/tclx new file mode 160000 index 0000000..5c19ee9 --- /dev/null +++ b/tclx @@ -0,0 +1 @@ +Subproject commit 5c19ee9d60c2e6cf18b13589a665817b836373ef