add stuff

src/Carrion/Plugin/TCL.hs

@@ -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_CancelEval :: FunPtr Tcl_CancelEval_Sig -> Tcl_CancelEval_Sig
-foreign import ccall "dynamic" mkTcl_GetStringResult :: FunPtr (Tcl_Interp_Ptr -> IO CString) -> (Tcl_Interp_Ptr -> IO CString)
+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
+      tcl_CancelEval = getCancelEval wi
-      runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
+      tcl_AsyncInvoke = getAsyncInvoke wi
-      runTclCommand s = newCString s >>= runscript
+      i = getInterp wi
-      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
+  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 = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
-  performFromIRC >>= return . T.pack
+--  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
-        processedGift <- processCommand wrappedtclinterp giftStripped
+        let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped
-        regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) processedGift) manhole
+        case hmm of
+          Nothing -> do
+            processedGift <- processCommand wrappedtclinterp giftStripped
+            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 '"' '"'

src/GypsFulvus.hs

@@ -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

src/Test.hs

@@ -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 '(' ')') ))

src/smeggdrop/smeggdrop/interpx.tcl

@@ -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 {

src/smeggdrop/smeggdrop/smeggdrop.tcl

@@ -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
 }