add stuff
This commit is contained in:
parent
912a88004b
commit
90996dfcb6
@ -6,7 +6,7 @@ module Carrion.Plugin.TCL
|
||||
tellCommands
|
||||
) where
|
||||
import Control.Monad
|
||||
import Control.Concurrent(forkIO)
|
||||
import Control.Concurrent(forkIO, threadDelay, killThread)
|
||||
import Control.Concurrent.STM
|
||||
import System.Posix.DynamicLinker
|
||||
import System.Environment
|
||||
@ -30,21 +30,27 @@ data TCLCommand = TCLCommand {getTCLCNick :: String,
|
||||
getTCLCActualCommand :: String
|
||||
}
|
||||
|
||||
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)
|
||||
type Tcl_CancelEval_Sig = (Tcl_Interp_Ptr -> Ptr Tcl_Obj_Dummy -> Ptr Tcl_ClientData_Dummy -> Int -> IO Int)
|
||||
type Tcl_AsyncInvoke_Sig = (Tcl_Interp_Ptr -> Int -> IO Int)
|
||||
foreign import ccall "dynamic" mkTcl_CreateInterp :: FunPtr (IO Tcl_Interp_Ptr) -> IO (Tcl_Interp_Ptr)
|
||||
|
||||
|
||||
data Tcl_Obj_Dummy = Tcl_Obj_Dummy
|
||||
data Tcl_ClientData_Dummy = Tcl_ClientData_Dummy
|
||||
|
||||
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_CancelEval :: FunPtr Tcl_CancelEval_Sig -> Tcl_CancelEval_Sig
|
||||
foreign import ccall "dynamic" mkTcl_AsyncInvoke :: FunPtr Tcl_AsyncInvoke_Sig -> Tcl_AsyncInvoke_Sig
|
||||
foreign import ccall "dynamic" mkTcl_EvalFile :: FunPtr Tcl_EvalFile_Sig -> Tcl_EvalFile_Sig
|
||||
foreign import ccall "dynamic" mkTcl_GetStringResult :: FunPtr Tcl_GetStringResult_Sig -> Tcl_GetStringResult_Sig
|
||||
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 :: [T.Text]
|
||||
@ -66,65 +72,18 @@ fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson b = case b of
|
||||
mkTCLCommandFromAIAndMsg :: SewageAutorInfo -> String -> TCLCommand
|
||||
mkTCLCommandFromAIAndMsg = fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
|
||||
|
||||
data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: Tcl_Interp_Ptr,
|
||||
data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Interp_Ptr),
|
||||
getEvalFile :: Tcl_EvalFile_Sig,
|
||||
getEvalEx :: Tcl_EvalEx_Sig,
|
||||
getGetStringResult :: Tcl_GetStringResult_Sig
|
||||
|
||||
getGetStringResult :: Tcl_GetStringResult_Sig,
|
||||
getCancelEval :: Tcl_CancelEval_Sig,
|
||||
getAsyncInvoke :: Tcl_AsyncInvoke_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 _ = return ()
|
||||
|
||||
@ -156,8 +115,12 @@ initPlugin manhole = do
|
||||
tcl_EvalEx <- bless "Tcl_EvalEx" mkTcl_EvalEx
|
||||
tcl_GetStringResult <- bless "Tcl_GetStringResult" mkTcl_GetStringResult
|
||||
tcl_EvalFile <- bless "Tcl_EvalFile" mkTcl_EvalFile
|
||||
tcl_CancelEval <- bless "Tcl_CancelEval" mkTcl_CancelEval
|
||||
tcl_AsyncInvoke <- bless "Tcl_AsyncInvoke" mkTcl_AsyncInvoke
|
||||
smeginitstatus <- newCString "./src/smeggdrop/smeggdrop.tcl" >>= \fn -> tcl_EvalFile interp fn
|
||||
let wrappedinterp = TCLInterpreterWrapper interp tcl_EvalFile tcl_EvalEx tcl_GetStringResult
|
||||
threadsafe_interp_duh <- atomically $ newTMVar interp
|
||||
|
||||
let wrappedinterp = TCLInterpreterWrapper threadsafe_interp_duh tcl_EvalFile tcl_EvalEx tcl_GetStringResult tcl_CancelEval tcl_AsyncInvoke
|
||||
forkIO $ rEPL wrappedinterp manhole
|
||||
return GoodInitStatus
|
||||
|
||||
@ -168,22 +131,36 @@ processCommand :: TCLInterpreterWrapper -> Sewage -> IO T.Text
|
||||
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"
|
||||
tcl_CancelEval = getCancelEval wi
|
||||
tcl_AsyncInvoke = getAsyncInvoke wi
|
||||
i = getInterp wi
|
||||
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
|
||||
interp <- atomically $ takeTMVar i
|
||||
let runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
|
||||
runTclCommand s = newCString s >>= runscript
|
||||
errorInfo = runTclCommand "return $errorInfo"
|
||||
|
||||
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 >>= return . T.pack
|
||||
performFromIRC = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
|
||||
-- harvester <- forkIO $ do
|
||||
-- threadDelay 15000000
|
||||
-- putStrLn "cancelling thread!!!"
|
||||
-- fff <- tcl_CancelEval interp nullPtr nullPtr 0x100000
|
||||
-- putStrLn $ "cancel status " ++ (show fff)
|
||||
-- hngggg <- tcl_AsyncInvoke interp 0
|
||||
-- putStrLn $ "asyncinvoke returned " ++ (show hngggg)
|
||||
res <- performFromIRC
|
||||
-- putStrLn "putting back the interp"
|
||||
atomically $ putTMVar i interp
|
||||
return $ T.pack res
|
||||
|
||||
rEPL wrappedtclinterp manhole =
|
||||
let inspectManhole = atomically . readTChan . getInputChan
|
||||
@ -194,6 +171,35 @@ rEPL wrappedtclinterp manhole =
|
||||
case strippedCmd of
|
||||
Just cmdBodyStripped -> do
|
||||
let giftStripped = Sewage (getSewageAutor newGift) cmdBodyStripped
|
||||
let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped
|
||||
case hmm of
|
||||
Nothing -> do
|
||||
processedGift <- processCommand wrappedtclinterp giftStripped
|
||||
regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) processedGift) manhole
|
||||
regift (Sewage mySignature processedGift) manhole
|
||||
Just berror -> regift (Sewage mySignature (T.pack berror)) manhole
|
||||
Nothing -> return ()
|
||||
|
||||
-- stolen from the internet and adapted for tcl
|
||||
-- Return whether a string contains balanced brackets. Nothing indicates a
|
||||
-- balanced string, while (Just i) means an imbalance was found at, or just
|
||||
-- after, the i'th bracket. We assume the string contains only brackets.
|
||||
isBalanced :: Char -> Char -> String -> Maybe String
|
||||
isBalanced openc closec = bal (-1) 0
|
||||
where
|
||||
bal :: Int -> Int -> String -> Maybe String
|
||||
bal _ 0 [] = Nothing
|
||||
bal i _ [] = Just $ "Opening bracket unmatched until end of command." -- unmatched opening
|
||||
bal i (-1) _ = Just $ "Unmatched closing bracket at position " ++ show i -- unmatched close
|
||||
bal i n (singlec:bs)
|
||||
| singlec == openc = bal (i + 1) (n + 1) bs
|
||||
| singlec == closec = bal (i + 1) (n - 1) bs
|
||||
| singlec == '\\' = case bs of
|
||||
(sc:rs) -> if sc == openc || sc == closec then bal (i+2) n rs else bal (i+1) n rs
|
||||
| otherwise = bal (i+1) n bs
|
||||
|
||||
gnarlyBalanced = isBalanced '{' '}'
|
||||
-- it's better not to check for double quotes and square brackets I think since they can be escaped and not used internally for pub:tcl:perform...
|
||||
|
||||
squareBalanced = isBalanced '[' ']'
|
||||
|
||||
dquoteBalanced = isBalanced '"' '"'
|
||||
|
@ -47,7 +47,7 @@ assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
|
||||
lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
|
||||
lookupManholeInSewer s p = do
|
||||
s_l <- readTMVar s
|
||||
return $ traceShow (hash p) $ M.lookup (hash p) (getSewerMap s_l)
|
||||
return $ M.lookup (hash p) (getSewerMap s_l)
|
||||
|
||||
dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
|
||||
-- broadcast ouputs from routines to all (interested) parties
|
||||
@ -73,14 +73,19 @@ runForever s =
|
||||
someGarbage <- atomically block
|
||||
let theAutor = show $ getSewageAutor someGarbage
|
||||
let theSewage = getSewage someGarbage
|
||||
putStrLn $ (T.pack theAutor) ++ " sez:"
|
||||
putStrLn $ theSewage
|
||||
threadDelay 1000000
|
||||
if (theAutor == "local:STDIO haskeline@local" && ("tcl " `T.isPrefixOf` theSewage)) then sendToTCL s someGarbage else return ()
|
||||
if (theAutor == "local:STDIO haskeline@local") then
|
||||
if ("tcl " `T.isPrefixOf` theSewage) then
|
||||
sendToTCL s someGarbage
|
||||
else
|
||||
return ()
|
||||
else do
|
||||
putStrLn $ T.pack theAutor ++ " sez:"
|
||||
putStrLn theSewage
|
||||
sendToTCL sewer sewage = do
|
||||
m <- atomically $ lookupManholeInSewer sewer "TCL-Simple"
|
||||
case m of
|
||||
Just m -> traceShow (getSewageAutor sewage,getSewage sewage) regift' sewage m
|
||||
Just m -> regift' sewage m
|
||||
Nothing -> putStrLn "couldn't find TCL submodule"
|
||||
|
||||
registerComms = undefined
|
||||
|
29
src/Test.hs
Normal file
29
src/Test.hs
Normal file
@ -0,0 +1,29 @@
|
||||
import System.Environment
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
-- stolen from the internet and adapted for tcl
|
||||
-- Return whether a string contains balanced brackets. Nothing indicates a
|
||||
-- balanced string, while (Just i) means an imbalance was found at, or just
|
||||
-- after, the i'th bracket. We assume the string contains only brackets.
|
||||
isBalanced :: Char -> Char -> String -> Maybe String
|
||||
isBalanced openc closec = bal (-1) 0
|
||||
where
|
||||
bal :: Int -> Int -> String -> Maybe String
|
||||
bal _ 0 [] = Nothing
|
||||
bal i _ [] = Just $ "Opening bracket unmatched until end of command." -- unmatched opening
|
||||
bal i (-1) _ = Just $ "Unmatched closing bracket at position " ++ show i -- unmatched close
|
||||
bal i n (singlec:bs)
|
||||
| singlec == openc = bal (i + 1) (n + 1) bs
|
||||
| singlec == closec = bal (i + 1) (n - 1) bs
|
||||
| singlec == '\\' = case bs of
|
||||
(sc:rs) -> if sc == openc || sc == closec then bal (i+2) n rs else bal (i+1) n rs
|
||||
| otherwise = bal (i+1) n bs
|
||||
|
||||
gnarlyBalanced = isBalanced '{' '}'
|
||||
-- it's better not to check for double quotes and square brackets I think since they can be escaped and not used internally for pub:tcl:perform...
|
||||
|
||||
squareBalanced = isBalanced '[' ']'
|
||||
|
||||
dquoteBalanced = isBalanced '"' '"'
|
||||
|
||||
main = getArgs >>= (mapM (putStrLn . show . (isBalanced '(' ')') ))
|
@ -135,9 +135,9 @@ method {inspect proc} proc {
|
||||
signal trap SIGALRM [list ::interpx::timeout $self $private_key]
|
||||
alarm [expr {[$self cget -timeout] / 1000.0}]
|
||||
}
|
||||
|
||||
interp limit $interp time -seconds [clock add [clock seconds] 5 seconds]
|
||||
set code [catch {$interp eval $script} result]
|
||||
|
||||
interp limit $interp time -seconds {}
|
||||
if $timeout {
|
||||
alarm 0
|
||||
if $timed_out {
|
||||
@ -329,7 +329,6 @@ method {inspect proc} proc {
|
||||
$self unset_internal_vars
|
||||
$self initialize_private_namespace
|
||||
|
||||
puts "initialize_interpreter inside interpx finished"
|
||||
}
|
||||
|
||||
method unset_internal_vars {} {
|
||||
@ -344,7 +343,6 @@ method {inspect proc} proc {
|
||||
$interp alias ::interpx::timeout ::interpx::timeout
|
||||
$self expose {did touch var} ::interpx::touched_var
|
||||
|
||||
puts "finished initialize_private_namespace inside interpx"
|
||||
}
|
||||
|
||||
method hide command {
|
||||
|
@ -169,7 +169,6 @@ proc pub:tcl:perform {nick mask hand channel line} {
|
||||
if [catch {$versioned_interpreter eval $line $author} output] {
|
||||
set output "error: $output"
|
||||
}
|
||||
|
||||
putlog $output
|
||||
return $output
|
||||
}
|
||||
|
Loading…
x
Reference in New Issue
Block a user