view release on metacpan or  search on metacpan

src/Pugs/Embed/Perl5.hs  view on Meta::CPAN

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