{-# OPTIONS_GHC -fglasgow-exts -cpp -fvia-C -optc-w #-}
#ifndef PUGS_HAVE_PERL5
module Pugs.Embed.Perl5
( InvokePerl5Result(..)
, svToVBool, svToVInt, svToVNum, svToVStr, vstrToSV, vintToSV, svToVal, bufToSV, svUndef
, vnumToSV, mkValRef , mkVal, mkEnv, PerlSV, nullSV, nullEnv, evalPerl5, invokePerl5
, initPerl5, freePerl5, canPerl5
, evalPCR, pugs_SvToVal
)
where
import Foreign.C.Types
import System.Directory
import Pugs.Internals
import qualified UTF8 as Str
evalPCR :: FilePath -> String -> String -> [(String, String)] -> IO String
evalPCR path match rule subrules = do
(inp, out, err, pid) <- initPCR path
(`mapM` subrules) $ \(name, rule) -> do
let nameStr = escape name
ruleStr = escape rule
hPutStrLn inp $ unwords
["add_rule", show (length nameStr), show (length ruleStr)]
hPutStrLn inp nameStr
hPutStrLn inp ruleStr
let matchStr = escape match
ruleStr = escape rule
hPutStrLn inp $ unwords
["match", show (length matchStr), show (length ruleStr)]
hPutStrLn inp $ matchStr
hPutStrLn inp $ ruleStr
hFlush inp
rv <- hGetLine out
case rv of
('O':'K':' ':_) -> do
-- size <- readIO sizeStr
-- rv <- sequence (replicate size (hGetChar out))
ln <- hGetLine out
ln2 <- hGetLine out
return $ ln ++ ln2
_ -> do
errMsg <- fmap (rv ++) (hGetContents err)
rc <- waitForProcess pid
writeIORef _Perl5Interp Nothing
let msg | null errMsg = show rc
| otherwise = errMsg
fail $ "*** Running external 'perl' failed:\n" ++ msg
where
escape "" = ""
escape ('\\':xs) = "\\\\" ++ escape xs
escape ('\n':xs) = "\\n" ++ escape xs
escape (x:xs) = (x:escape xs)
initPCR :: FilePath -> IO Perl5Interp
initPCR path = do
rv <- readIORef _Perl5Interp
case rv of
Just interp@(_, _, _, pid) -> do
gone <- getProcessExitCode pid
if isNothing gone then return interp else do
writeIORef _Perl5Interp Nothing
initPCR path
Nothing -> do
cmd <- findPerl5
interp <- runInteractiveProcess cmd
[ "-Iperl5/Pugs-Compiler-Rule/lib"
, "-MPugs::Runtime::Match::HsBridge"
, "-ePugs::Runtime::Match::HsBridge::__CMD__"
] (Just path) Nothing
writeIORef _Perl5Interp (Just interp)
return interp
where
findPerl5 :: IO FilePath
findPerl5 = do
rv <- findExecutable "perl"
case rv of
Nothing -> do
rv' <- findExecutable "perl.exe"
case rv' of
Just cmd -> return cmd
Nothing -> fail "Cannot find the parrot executable in PATH"
Just cmd -> return cmd
type Perl5Interp = (Handle, Handle, Handle, ProcessHandle)
{-# NOINLINE _Perl5Interp #-}
_Perl5Interp :: IORef (Maybe Perl5Interp)
_Perl5Interp = unsafePerformIO $ newIORef Nothing
type PerlInterpreter = ()
data PerlSV = MkPerlSV -- phantom type
deriving (Show, Eq, Ord, Typeable)
type PugsVal = PerlSV
type PugsEnv = PerlSV
data InvokePerl5Result
= Perl5ReturnValues [PerlSV]
| Perl5ErrorString String
| Perl5ErrorObject PerlSV
constFail :: a -> IO b
constFail = const $ fail "perl5 not embedded"
initPerl5 :: String -> Maybe a -> IO PerlInterpreter
initPerl5 _ _ = return ()
freePerl5 :: PerlInterpreter -> IO ()
freePerl5 _ = return ()
evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV
evalPerl5 _ _ = constFail
svToVStr :: PerlSV -> IO String
svToVStr = constFail
svToVInt :: (Num a) => PerlSV -> IO a
svToVInt = constFail
svToVNum :: (Fractional a) => PerlSV -> IO a
svToVNum = constFail
svToVBool :: PerlSV -> IO Bool
svToVBool = constFail
svToVal :: PerlSV -> IO a
svToVal = constFail
mkVal :: (Show a) => a -> IO PugsVal
mkVal = constFail
mkEnv :: (Show a) => a -> IO PugsVal
mkEnv = constFail
mkValRef :: a -> String -> IO PerlSV
mkValRef _ = constFail
vstrToSV :: String -> IO PerlSV
vstrToSV = constFail
svUndef :: IO PerlSV
svUndef = error "perl5 not embedded"
bufToSV :: ByteString -> IO PerlSV
bufToSV = constFail
vintToSV :: (Integral a) => a -> IO PerlSV
vintToSV = constFail
vnumToSV :: (Real a) => a -> IO PerlSV
vnumToSV = constFail
invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result
invokePerl5 _ _ _ _ = constFail
canPerl5 :: PerlSV -> ByteString -> IO Bool
canPerl5 MkPerlSV = constFail
pugs_SvToVal :: PerlSV -> IO PugsVal
pugs_SvToVal = constFail
nullSV :: PerlSV
nullSV = error "perl5 not embedded"
nullEnv :: PugsVal
nullEnv = error "perl5 not embedded"
-- Below are unused
-- mkSV :: IO PerlSV -> IO PerlSV
-- mkSV = id
-- perl5_SvROK :: IO PerlSV -> IO Bool
-- perl5_SvROK _ = return False
#else
#undef RETURN
{-# INCLUDE "../../perl5/p5embed.h" #-}
{-# INCLUDE "../../perl5/pugsembed.h" #-}
module Pugs.Embed.Perl5 where
import Pugs.Internals
import System.Directory
import Foreign
import Foreign.C.Types
import Foreign.C.String
import {-# SOURCE #-} Pugs.AST.Internals
import qualified UTF8 as Str
type PerlInterpreter = Ptr ()
type PerlSV = Ptr ()
type PugsVal = StablePtr Val
type PugsEnv = StablePtr Env
foreign import ccall "perl_alloc"
perl_alloc :: IO PerlInterpreter
foreign import ccall "perl_construct"
perl_construct :: PerlInterpreter -> IO ()
foreign import ccall "perl_run"
perl_run :: PerlInterpreter -> IO CInt
foreign import ccall "perl_destruct"
perl_destruct :: PerlInterpreter -> IO CInt
foreign import ccall "perl_free"
perl_free :: PerlInterpreter -> IO ()
{-
foreign import ccall "boot_DynaLoader"
boot_DynaLoader :: Ptr () -> IO ()
-}
foreign import ccall "perl5_finalize"
perl5_finalize :: PerlSV -> IO ()
foreign import ccall "perl5_SvPV"
perl5_SvPV :: PerlSV -> IO CString
foreign import ccall "perl5_SvIV"
perl5_SvIV :: PerlSV -> IO CInt
foreign import ccall "perl5_SvNV"
perl5_SvNV :: PerlSV -> IO CDouble
foreign import ccall "perl5_SvTRUE"
perl5_SvTRUE :: PerlSV -> IO Bool
foreign import ccall "perl5_SvROK"
perl5_SvROK :: PerlSV -> IO Bool
foreign import ccall "perl5_newSVpvn"
perl5_newSVpvn :: CString -> CInt -> IO PerlSV
foreign import ccall "perl5_newSViv"
perl5_newSViv :: CInt -> IO PerlSV
foreign import ccall "perl5_newSVnv"
perl5_newSVnv :: CDouble -> IO PerlSV
foreign import ccall "perl5_sv_undef"
perl5_sv_undef :: IO PerlSV
foreign import ccall "perl5_get_sv"
perl5_get_sv :: CString -> IO PerlSV
foreign import ccall "perl5_apply"
perl5_apply :: PerlSV -> PerlSV -> Ptr PerlSV -> PugsEnv -> CInt -> IO (Ptr PerlSV)
foreign import ccall "perl5_can"
perl5_can :: PerlSV -> CString -> IO Bool
foreign import ccall "perl5_eval"
perl5_eval :: CString -> PugsEnv -> CInt -> IO PerlSV
foreign import ccall "perl5_init"
perl5_init :: CInt -> Ptr CString -> IO PerlInterpreter
foreign import ccall "pugs_getenv"
pugs_getenv :: IO PugsEnv
foreign import ccall "pugs_setenv"
pugs_setenv :: PugsEnv -> IO ()
foreign import ccall "pugs_SvToVal"
pugs_SvToVal :: PerlSV -> IO PugsVal
foreign import ccall "pugs_MkValRef"
pugs_MkValRef :: PugsVal -> CString -> IO PerlSV
initPerl5 :: String -> Maybe Env -> IO PerlInterpreter
initPerl5 str env = do
withCString "-e" $ \prog -> withCString str $ \cstr -> do
withArray [prog, prog, cstr] $ \argv -> do
interp <- perl5_init 3 argv
case env of
Just val -> pugs_setenv =<< mkEnv val
Nothing -> return ()
modifyIORef _GlobalFinalizer (>> perl_free interp)
return interp
mkVal :: Val -> IO PugsVal
mkVal x = do
-- warn "Creating nonblessed stable pointer for " (showVal x)
newStablePtr x
mkEnv :: Env -> IO PugsEnv
mkEnv = newStablePtr
svToVStr :: PerlSV -> IO String
svToVStr sv = peekCString =<< perl5_SvPV sv
svToVInt :: (Num a) => PerlSV -> IO a
svToVInt sv = fmap fromIntegral $ perl5_SvIV sv
svToVNum :: (Fractional a) => PerlSV -> IO a
svToVNum sv = fmap realToFrac $ perl5_SvNV sv
svToVBool :: PerlSV -> IO Bool
svToVBool = perl5_SvTRUE
svToVal :: PerlSV -> IO Val
svToVal sv = do
ptr <- pugs_SvToVal sv
deRefStablePtr ptr
mkValRef :: Val -> String -> IO PerlSV
mkValRef x typ = do
-- warn "Creating stable pointer for " (showVal x)
val <- mkVal x
withCString typ (pugs_MkValRef val)
svUndef :: IO PerlSV
svUndef = perl5_sv_undef
vstrToSV :: String -> IO PerlSV
vstrToSV str = Str.useAsCStringLen (cast str) $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len)
bufToSV :: ByteString -> IO PerlSV
bufToSV str = Str.useAsCStringLen str $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len)
vintToSV :: (Integral a) => a -> IO PerlSV
vintToSV int = perl5_newSViv (fromIntegral int)
vnumToSV :: (Real a) => a -> IO PerlSV
vnumToSV int = perl5_newSVnv (realToFrac int)
data InvokePerl5Result
= Perl5ReturnValues [PerlSV]
| Perl5ErrorString String
| Perl5ErrorObject PerlSV
invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result
invokePerl5 sub inv args env cxt = do
withArray0 nullPtr args $ \argv -> do
rv <- perl5_apply sub inv argv env cxt
svs <- peekArray0 nullPtr rv
-- If it's empty, no error occured (see p5embed.c on out[0]).
-- Otherwise, the second slot may be a stringified version we should use.
case svs of
[] -> fmap Perl5ReturnValues $ peekArray0 nullPtr (rv `advancePtr` 1)
[err] -> return $ Perl5ErrorObject err
(_:x:_) -> do
str <- svToVStr x
return $ Perl5ErrorString str
canPerl5 :: PerlSV -> ByteString -> IO Bool
canPerl5 sv meth = Str.useAsCString meth $ \cstr -> perl5_can sv cstr
mkSV :: IO PerlSV -> IO PerlSV
mkSV action = action
{-
- do
sv <- action
addFinalizer sv (perl5_finalize sv)
return sv
-}
evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV
evalPerl5 str env cxt = mkSV $ Str.useAsCString (cast str) $ \cstr -> perl5_eval cstr env cxt
freePerl5 :: PerlInterpreter -> IO ()
freePerl5 my_perl = do
perl_destruct my_perl
return ()
nullSV :: PerlSV
nullSV = nullPtr
{-# NOINLINE nullEnv #-}
nullEnv :: PugsEnv
nullEnv = unsafePerformIO (newStablePtr (error "undefined environment"))
evalPCR :: FilePath -> String -> String -> [(String, String)] -> IO String
evalPCR path match rule subrules = do
let bridgeMod = "Pugs::Runtime::Match::HsBridge"
bridgeFile = "Pugs/Runtime/Match/HsBridge.pm";
inv <- evalPerl5 (unlines
[ "if (!$INC{'"++bridgeFile++"'}) {"
, " unshift @INC, '"++path++"';"
, " eval q[require '"++bridgeFile++"'] or die $@;"
, "}"
, "'"++bridgeMod++"'"
]) nullEnv 1
meth <- vstrToSV "__RUN__"
args <- mapM vstrToSV $ concatMap (\(x, y) -> [x, y]) ((match, rule):subrules)
rv <- invokePerl5 meth inv args nullEnv 1
case rv of
Perl5ReturnValues [] -> return ""
Perl5ReturnValues (x:_) -> svToVStr x
Perl5ErrorString err -> return $ "Error: " ++ err
Perl5ErrorObject obj -> do
err <- svToVStr obj
return $ "Error: " ++ err
#endif