root/src/Pugs/Embed/Perl5.hs

Revision 21677, 11.4 kB (checked in by audreyt, 4 months ago)

* Reflect data-dir changes.
  • Property svn:mime-type set to text/plain; charset=UTF-8
  • Property svn:eol-style set to native
Line 
1{-# OPTIONS_GHC -fglasgow-exts -cpp -optc-w #-}
2
3#ifndef PUGS_HAVE_PERL5
4module Pugs.Embed.Perl5
5    ( InvokePerl5Result(..)
6    , svToVBool, svToVInt, svToVNum, svToVStr, vstrToSV, vintToSV, svToVal, bufToSV, svUndef
7    , vnumToSV, mkValRef, mkValPtr, mkEnv, PerlSV, nullSV, nullEnv, evalPerl5, invokePerl5
8    , initPerl5, freePerl5, canPerl5
9    , evalPCR, pugs_SvToVal
10    )
11where
12import Foreign.C.Types
13import System.Directory
14import Pugs.Internals
15import qualified Data.ByteString.UTF8 as Str
16
17evalPCR :: [FilePath] -> String -> String -> [(String, String)] -> IO String
18evalPCR [path] match rule subrules = do
19    (inp, out, err, pid) <- initPCR $ head path
20    (`mapM` subrules) $ \(name, rule) -> do
21        let nameStr = escape name
22            ruleStr = escape rule
23        hPutStrLn inp $ unwords
24            ["add_rule", show (length nameStr), show (length ruleStr)]
25        hPutStrLn inp nameStr
26        hPutStrLn inp ruleStr
27    let matchStr = escape match
28        ruleStr  = escape rule
29    hPutStrLn inp $ unwords
30        ["match", show (length matchStr), show (length ruleStr)]
31    hPutStrLn inp $ matchStr
32    hPutStrLn inp $ ruleStr
33    hFlush inp
34    rv <- hGetLine out
35    case rv of
36        ('O':'K':' ':_) -> do
37            -- size <- readIO sizeStr
38            -- rv   <- sequence (replicate size (hGetChar out))
39            ln   <- hGetLine out
40            ln2  <- hGetLine out
41            return $ ln ++ ln2
42        _ -> do
43            errMsg  <- fmap (rv ++) (hGetContents err)
44            rc      <- waitForProcess pid
45            writeIORef _Perl5Interp Nothing
46            let msg | null errMsg = show rc
47                    | otherwise   = errMsg
48            fail $ "*** Running external 'perl' failed:\n" ++ msg
49    where
50    escape "" = ""
51    escape ('\\':xs) = "\\\\" ++ escape xs
52    escape ('\n':xs) = "\\n" ++ escape xs
53    escape (x:xs) = (x:escape xs)
54
55initPCR :: FilePath -> IO Perl5Interp
56initPCR path = do
57    rv <- readIORef _Perl5Interp
58    case rv of
59        Just interp@(_, _, _, pid) -> do
60            gone <- getProcessExitCode pid
61            if isNothing gone then return interp else do
62            writeIORef _Perl5Interp Nothing
63            initPCR path
64        Nothing -> do
65            cmd <- findPerl5
66            interp <- runInteractiveProcess cmd
67                [ "-Iperl5/Pugs-Compiler-Rule/lib"
68                , "-MPugs::Runtime::Match::HsBridge"
69                , "-ePugs::Runtime::Match::HsBridge::__CMD__"
70                ] (Just path) Nothing
71            writeIORef _Perl5Interp (Just interp)
72            return interp
73    where
74    findPerl5 :: IO FilePath
75    findPerl5 = do
76        rv <- findExecutable "perl"
77        case rv of
78            Nothing     -> do
79                rv' <- findExecutable "perl.exe"
80                case rv' of
81                    Just cmd    -> return cmd
82                    Nothing     -> fail "Cannot find the parrot executable in PATH"
83            Just cmd    -> return cmd
84
85type Perl5Interp = (Handle, Handle, Handle, ProcessHandle)
86
87{-# NOINLINE _Perl5Interp #-}
88_Perl5Interp :: IORef (Maybe Perl5Interp)
89_Perl5Interp = unsafePerformIO $ newIORef Nothing
90
91type PerlInterpreter = ()
92data PerlSV = MkPerlSV -- phantom type
93    deriving (Show, Eq, Ord, Typeable)
94type PugsVal = PerlSV
95type PugsEnv = PerlSV
96
97data InvokePerl5Result
98    = Perl5ReturnValues [PerlSV]
99    | Perl5ErrorString String
100    | Perl5ErrorObject PerlSV
101    deriving (Show, Typeable)
102
103constFail :: a -> IO b
104constFail = const $ fail "perl5 not embedded"
105
106initPerl5 :: String -> Maybe a -> IO PerlInterpreter
107initPerl5 _ _ = return ()
108
109freePerl5 :: PerlInterpreter -> IO ()
110freePerl5 _ = return ()
111
112evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV
113evalPerl5 _ _ = constFail
114
115svToVStr :: PerlSV -> IO String
116svToVStr = constFail
117
118svToVInt :: (Num a) => PerlSV -> IO a
119svToVInt = constFail
120
121svToVNum :: (Fractional a) => PerlSV -> IO a
122svToVNum = constFail
123
124svToVBool :: PerlSV -> IO Bool
125svToVBool = constFail
126
127svToVal :: PerlSV -> IO a
128svToVal = constFail
129
130mkValPtr :: (Show a) => a -> IO PugsVal
131mkValPtr = constFail
132
133mkEnv :: a -> IO PugsVal
134mkEnv = constFail
135
136mkValRef :: a -> String -> IO PerlSV
137mkValRef _ = constFail
138
139vstrToSV :: String -> IO PerlSV
140vstrToSV = constFail
141
142svUndef :: IO PerlSV
143svUndef = error "perl5 not embedded"
144
145bufToSV :: ByteString -> IO PerlSV
146bufToSV = constFail
147
148vintToSV :: (Integral a) => a -> IO PerlSV
149vintToSV = constFail
150
151vnumToSV :: (Real a) => a -> IO PerlSV
152vnumToSV = constFail
153
154invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result
155invokePerl5 _ _ _ _ = constFail
156
157canPerl5 :: PerlSV -> ByteString -> IO Bool
158canPerl5 MkPerlSV = constFail
159
160pugs_SvToVal :: PerlSV -> IO PugsVal
161pugs_SvToVal = constFail
162
163nullSV :: PerlSV
164nullSV = error "perl5 not embedded"
165
166nullEnv :: PugsVal
167nullEnv = error "perl5 not embedded"
168
169-- Below are unused
170
171-- mkSV :: IO PerlSV -> IO PerlSV
172-- mkSV = id
173
174-- perl5_SvROK :: IO PerlSV -> IO Bool
175-- perl5_SvROK _ = return False
176
177#else
178#undef RETURN
179
180{-# INCLUDE "../../perl5/p5embed.h" #-}
181{-# INCLUDE "../../perl5/pugsembed.h" #-}
182
183module Pugs.Embed.Perl5 where
184import Pugs.Internals
185import Foreign
186import Foreign.C.Types
187import Foreign.C.String
188import {-# SOURCE #-} Pugs.AST.Internals
189import qualified Data.ByteString.UTF8 as Str
190import qualified Data.ByteString.Char8 as Buf
191import qualified Pugs.Val as Val
192
193type PerlInterpreter = Ptr ()
194type PerlSV = Ptr ()
195type PugsVal = StablePtr Val
196type PugsEnv = StablePtr Env
197
198foreign import ccall "perl_alloc"
199    perl_alloc :: IO PerlInterpreter
200foreign import ccall "perl_construct"
201    perl_construct :: PerlInterpreter -> IO ()
202foreign import ccall "perl_run"
203    perl_run :: PerlInterpreter -> IO CInt
204foreign import ccall "perl_destruct"
205    perl_destruct :: PerlInterpreter -> IO CInt
206foreign import ccall "perl_free"
207    perl_free :: PerlInterpreter -> IO ()
208{-
209foreign import ccall "boot_DynaLoader"
210    boot_DynaLoader :: Ptr () -> IO ()
211-}
212foreign import ccall "perl5_finalize"
213    perl5_finalize :: PerlSV -> IO ()
214foreign import ccall "perl5_SvPV"
215    perl5_SvPV :: PerlSV -> IO CString
216foreign import ccall "perl5_SvIV"
217    perl5_SvIV :: PerlSV -> IO CInt
218foreign import ccall "perl5_SvNV"
219    perl5_SvNV :: PerlSV -> IO CDouble
220foreign import ccall "perl5_SvTRUE"
221    perl5_SvTRUE :: PerlSV -> IO Bool
222foreign import ccall "perl5_SvROK"
223    perl5_SvROK :: PerlSV -> IO Bool
224foreign import ccall "perl5_newSVpvn"
225    perl5_newSVpvn :: CString -> CInt -> IO PerlSV
226foreign import ccall "perl5_newSViv"
227    perl5_newSViv :: CInt -> IO PerlSV
228foreign import ccall "perl5_newSVnv"
229    perl5_newSVnv :: CDouble -> IO PerlSV
230foreign import ccall "perl5_sv_undef"
231    perl5_sv_undef :: IO PerlSV
232foreign import ccall "perl5_get_sv"
233    perl5_get_sv :: CString -> IO PerlSV
234foreign import ccall "perl5_apply"
235    perl5_apply :: PerlSV -> PerlSV -> Ptr PerlSV -> PugsEnv -> CInt -> IO (Ptr PerlSV)
236foreign import ccall "perl5_can"
237    perl5_can :: PerlSV -> CString -> IO Bool
238foreign import ccall "perl5_eval"
239    perl5_eval :: CString -> PugsEnv -> CInt -> IO PerlSV
240foreign import ccall "perl5_init"
241    perl5_init :: CInt -> Ptr CString -> IO PerlInterpreter
242
243foreign import ccall "pugs_getenv"
244    pugs_getenv :: IO PugsEnv
245foreign import ccall "pugs_setenv"
246    pugs_setenv :: PugsEnv -> IO ()
247
248foreign import ccall "pugs_SvToVal"
249    pugs_SvToVal :: PerlSV -> IO PugsVal
250foreign import ccall "pugs_MkValRef"
251    pugs_MkValRef :: PugsVal -> CString -> IO PerlSV
252
253initPerl5 :: String -> Maybe Env -> IO PerlInterpreter
254initPerl5 str env = do
255    withCString "-e" $ \prog -> withCString str $ \cstr -> do
256        withArray [prog, prog, cstr] $ \argv -> do
257            interp <- perl5_init 3 argv
258            case env of
259                Just val    -> pugs_setenv =<< mkEnv val
260                Nothing     -> return ()
261            modifyIORef _GlobalFinalizer (>> perl_free interp)
262            return interp
263
264mkValPtr :: Val -> IO PugsVal
265mkValPtr x = do
266    -- warn "Creating nonblessed stable pointer for " (showVal x)
267    newStablePtr x
268
269mkEnv :: Env -> IO PugsEnv
270mkEnv = newStablePtr
271
272svToVStr :: PerlSV -> IO String
273svToVStr sv = peekCString =<< perl5_SvPV sv
274
275svToVInt :: (Num a) => PerlSV -> IO a
276svToVInt sv = fmap fromIntegral $ perl5_SvIV sv
277
278svToVNum :: (Fractional a) => PerlSV -> IO a
279svToVNum sv = fmap realToFrac $ perl5_SvNV sv
280
281svToVBool :: PerlSV -> IO Bool
282svToVBool = perl5_SvTRUE
283
284svToVal :: PerlSV -> IO Val
285svToVal sv = do
286    ptr <- pugs_SvToVal sv
287    deRefStablePtr ptr
288
289mkValRef :: Val -> String -> IO PerlSV
290mkValRef x typ = do
291    -- warn "Creating stable pointer for " (showVal x)
292    val <- mkValPtr x
293    withCString typ (pugs_MkValRef val)
294
295svUndef :: IO PerlSV
296svUndef = perl5_sv_undef
297
298vstrToSV :: String -> IO PerlSV
299vstrToSV str = Buf.useAsCStringLen (cast str) $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len)
300
301bufToSV :: ByteString -> IO PerlSV
302bufToSV str = Buf.useAsCStringLen str $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len)
303
304vintToSV :: (Integral a) => a -> IO PerlSV
305vintToSV int = perl5_newSViv (fromIntegral int)
306
307vnumToSV :: (Real a) => a -> IO PerlSV
308vnumToSV int = perl5_newSVnv (realToFrac int)
309
310
311data InvokePerl5Result
312    = Perl5ReturnValues [PerlSV]
313    | Perl5ErrorString String
314    | Perl5ErrorObject PerlSV
315    deriving (Show, Typeable)
316
317invokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> PugsEnv -> CInt -> IO InvokePerl5Result
318invokePerl5 sub inv args env cxt = do
319    withArray0 nullPtr args $ \argv -> do
320        rv  <- perl5_apply sub inv argv env cxt
321        svs <- peekArray0 nullPtr rv
322
323        -- If it's empty, no error occured (see p5embed.c on out[0]).
324        -- Otherwise, the second slot may be a stringified version we should use.
325        case svs of
326            []      -> fmap Perl5ReturnValues $ peekArray0 nullPtr (rv `advancePtr` 1)
327            [err]   -> return $ Perl5ErrorObject err
328            (_:x:_) -> do
329                str <- svToVStr x
330                return $ Perl5ErrorString str
331           
332canPerl5 :: PerlSV -> ByteString -> IO Bool
333canPerl5 sv meth = Buf.useAsCString meth $ \cstr -> perl5_can sv cstr
334
335mkSV :: IO PerlSV -> IO PerlSV
336mkSV action = action
337{-
338 - do
339    sv <- action
340    addFinalizer sv (perl5_finalize sv)
341    return sv
342-}
343
344evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV
345evalPerl5 str env cxt = mkSV $ Buf.useAsCString (cast str) $ \cstr -> perl5_eval cstr env cxt
346
347freePerl5 :: PerlInterpreter -> IO ()
348freePerl5 my_perl = do
349    perl_destruct my_perl
350    return ()
351
352nullSV :: PerlSV
353nullSV = nullPtr
354
355{-# NOINLINE nullEnv #-}
356nullEnv :: PugsEnv
357nullEnv = unsafePerformIO (newStablePtr (error "undefined environment"))
358
359evalPCR :: [FilePath] -> String -> String -> [(String, String)] -> IO String
360evalPCR paths match rule subrules = do
361    let bridgeMod   = "Pugs::Runtime::Match::HsBridge"
362        bridgeFile  = "Pugs/Runtime/Match/HsBridge.pm";
363        incs        = map (\p -> "    unshift @INC, '"++p++"';") paths
364    inv     <- evalPerl5 (unlines $
365        [ "if (!$INC{'"++bridgeFile++"'}) {"
366        ] ++ incs ++
367        [ "    eval q[require '"++bridgeFile++"'] or die $@;"
368        , "}"
369        , "'"++bridgeMod++"'"
370        ]) nullEnv 1
371    meth    <- vstrToSV "__RUN__"
372    args    <- mapM vstrToSV $ concatMap (\(x, y) -> [x, y]) ((match, rule):subrules)
373    rv      <- invokePerl5 meth inv args nullEnv 1
374    case rv of
375        Perl5ReturnValues []    -> return ""
376        Perl5ReturnValues (x:_) -> svToVStr x
377        Perl5ErrorString err    -> return $ "Error: " ++ err
378        Perl5ErrorObject obj    -> do
379            err <- svToVStr obj
380            return $ "Error: " ++ err
381
382#endif
Note: See TracBrowser for help on using the browser.