HsPerl5 0.0.1 → 0.0.2
raw patch · 4 files changed
+291/−25 lines, 4 files
Files
- HsPerl5.cabal +14/−3
- p5embed.c +112/−10
- src/Language/Perl5.hs +146/−10
- test.hs +19/−2
HsPerl5.cabal view
@@ -1,18 +1,29 @@ name: HsPerl5-version: 0.0.1+version: 0.0.2 copyright: 2008 Audrey Tang license: BSD3 license-file: LICENSE author: Audrey Tang <audreyt@audreyt.org> maintainer: Audrey Tang <audreyt@audreyt.org> synopsis: Haskell interface to embedded Perl 5 interpreter-description: Haskell interface to embedded Perl 5 interpreter++description: This module provides a Haskell interface to embedded Perl 5 interpreter.++ Documentation and functionality is scarce at the moment; see test.hs for+ some basic usage examples.++ Eventually the entirety of Pugs.Embed.Perl5 and Pugs.Run.Perl5 will be+ carried into this module.+ stability: experimental build-type: Simple-extensions: ForeignFunctionInterface+extensions: ForeignFunctionInterface, TypeSynonymInstances,+ ScopedTypeVariables, FlexibleInstances,+ UndecidableInstances, OverlappingInstances exposed-modules: Language.Perl5 build-depends: base extra-source-files: README test.hs configure hs-source-dirs: src category: Language c-sources: p5embed.c+includes: p5embed.h
p5embed.c view
@@ -28,6 +28,18 @@ return(&PL_sv_undef); } +SV *+perl5_sv_yes ()+{+ return(&PL_sv_yes);+}++SV *+perl5_sv_no ()+{+ return(&PL_sv_no);+}+ PerlInterpreter * perl5_init ( int argc, char **argv ) {@@ -99,36 +111,64 @@ return my_perl; } -SV *-perl5_eval(char *code, int cxt)+SV **+perl5_eval(char *code, int len, int cxt) { dSP; SV* sv;+ int count; ENTER; SAVETMPS; - sv = newSVpv(code, 0);+ sv = newSVpvn(code, len); #ifdef SvUTF8_on SvUTF8_on(sv); #endif- eval_sv(sv, cxt);+ count = eval_sv(sv, cxt); SvREFCNT_dec(sv); + return perl5_return_conv(count);+}+++SV **+perl5_return_conv (int count) {+ SV **out;+ int i;++ dSP; SPAGAIN;- sv = POPs;- SvREFCNT_inc(sv);- PUTBACK; if (SvTRUE(ERRSV)) {- STRLEN n_a;- fprintf(stderr, "Error eval perl5: \"%s\"\n*** %s\n", code, SvPV(ERRSV,n_a));+ Newz(42, out, 3, SV*);+ if (SvROK(ERRSV)) {+ out[0] = newSVsv(ERRSV);+ out[1] = NULL;+ }+ else {+ out[0] = ERRSV;+ out[1] = ERRSV; /* for Haskell-side to read PV */+ }+ out[2] = NULL; }+ else {+ Newz(42, out, count+2, SV*); + out[0] = NULL;++ for (i=count; i>0; --i) {+ out[i] = newSVsv(POPs);+ }+ out[count+1] = NULL;+ }++ PUTBACK; FREETMPS; LEAVE; - return sv;+ /* pugs_setenv(old_env); */+ return out; } char *@@ -148,3 +188,65 @@ #endif return(sv); }++SV **+perl5_apply(SV *sub, SV *inv, SV** args, int cxt)+{+ SV **arg;+ SV *rv;+ SV *sv;++ dSP;++ ENTER;+ SAVETMPS;++ PUSHMARK(SP);+ if (inv != NULL) {+ XPUSHs(inv);+ }+ for (arg = args; *arg != NULL; arg++) {+ XPUSHs(*arg);+ }+ PUTBACK;++ if (inv != NULL) {+ perl5_return_conv(call_method(SvPV_nolen(sub), cxt|G_EVAL));+ }+ else {+ perl5_return_conv(call_sv(sub, cxt|G_EVAL));+ }+}++SV *+perl5_newSViv ( int iv )+{+ return(newSViv(iv));+}++SV *+perl5_newSVnv ( double iv )+{+ return(newSVnv(iv));+}++int+perl5_SvIV ( SV *sv )+{+ return((int)SvIV(sv));+}++double+perl5_SvNV ( SV *sv )+{+ return((double)SvNV(sv));+}++bool+perl5_SvTRUE ( SV * sv )+{+ bool rv;+ rv = SvTRUE(sv);+ return(rv ? 1 : 0);+}+
src/Language/Perl5.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, ScopedTypeVariables #-}+{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, UndecidableInstances, OverlappingInstances #-} {-# INCLUDE "p5embed.h" #-} module Language.Perl5@@ -6,13 +6,21 @@ , ToSV(..) , FromSV(..) , withPerl5+ , callSub, (.:), (.!)+ , callMethod, (.$), (.$!) , eval+ , eval_+ , SV+ , use ) where import Foreign import Foreign.C.Types import Foreign.C.String-import Control.Exception (bracket)+import Control.Exception (bracket, throwIO, Exception(..))+import Data.Dynamic (toDyn)+import Data.List (intersperse) +-- | Perl 5's calling context. data Context = Void | Item | List enumContext :: (Num a) => Context -> a@@ -23,6 +31,52 @@ type Interpreter = Ptr () type SV = Ptr () +class ToCV a where+ toCV :: a -> Int -> IO SV++instance ToSV a => ToCV a where+ toCV x _ = toSV x++instance ToCV String where+ toCV sub count = do+ let prms = map (\i -> "$_[" ++ show i ++ "]") [0 .. count-1]+ eval ("sub { " ++ sub ++ "(" ++ (concat $ intersperse ", " prms) ++ ") }")++(.:) :: (ToCV sub, ToArgs args, FromArgs ret) => sub -> args -> IO ret+(.:) = callSub++(.!) :: (ToCV sub, ToArgs args) => sub -> args -> IO ()+(.!) = callSub++-- | Call a Perl 5 subroutine.+callSub :: forall s a r. (ToCV s, ToArgs a, FromArgs r) => s -> a -> IO r+callSub sub args = do+ args' <- toArgs args+ sub' <- toCV sub (length args')+ rv <- withArray0 nullPtr args' $ \argsPtr -> do+ perl5_apply sub' nullPtr argsPtr (enumContext $ contextOf (undefined :: r))+ returnPerl5 rv++(.$) :: (ToSV meth, ToArgs args, FromArgs ret) => SV -> meth -> args -> IO ret+(.$) = callMethod++(.$!) :: (ToSV meth, ToArgs args) => SV -> meth -> args -> IO ()+(.$!) = callMethod++-- | Call a Perl 5 method.+callMethod :: forall i m a r. (ToSV i, ToSV m, ToArgs a, FromArgs r) => i -> m -> a -> IO r+callMethod inv meth args = do+ inv' <- toSV inv+ args' <- toArgs args+ sub' <- toSV meth+ rv <- withArray0 nullPtr args' $ \argsPtr -> do+ perl5_apply sub' inv' argsPtr (enumContext $ contextOf (undefined :: r))+ returnPerl5 rv++-- | Use a module. Returns a prototype object representing the module.+use :: String -> IO SV+use m = eval $ "use " ++ m ++ "; q[" ++ m ++ "]"+ -- | Run a computation within the context of a Perl 5 interpreter. withPerl5 :: IO a -> IO a withPerl5 f = do@@ -33,11 +87,23 @@ perl_free interp) (const f) -- | Evaluate a snippet of Perl 5 code.-eval :: forall a. FromSV a => String -> IO a-eval str = withCString str $ \cstr -> do- sv <- perl5_eval cstr (enumContext $ contextOf (undefined :: a))- fromSV sv+eval :: forall a. FromArgs a => String -> IO a+eval str = withCStringLen str $ \(cstr, len) -> do+ rv <- perl5_eval cstr (toEnum len) (enumContext $ contextOf (undefined :: a))+ returnPerl5 rv +-- | Same as 'eval' but always in void context.+eval_ :: String -> IO ()+eval_ str = eval str++returnPerl5 :: forall a. FromArgs a => Ptr SV -> IO a+returnPerl5 rv = do+ svs <- peekArray0 nullPtr rv+ case svs of+ [] -> fromArgs =<< peekArray0 nullPtr (rv `advancePtr` 1)+ [err] -> throwIO (DynException $ toDyn err)+ (_:x:_) -> fail =<< fromSV x+ -- | Data types that can be casted into a Perl 5 value (SV). class ToSV a where toSV :: a -> IO SV@@ -45,15 +111,21 @@ -- | Data types that can be casted from a Perl 5 value (SV). class FromSV a where fromSV :: SV -> IO a- contextOf :: a -> Context- contextOf _ = Item +instance ToSV SV where toSV = return+instance FromSV SV where fromSV = return+ instance ToSV () where toSV _ = perl5_sv_undef instance FromSV () where fromSV x = seq x (return ())- contextOf _ = Void +instance ToArgs [String] where+ toArgs = mapM toSV++instance FromArgs [String] where+ fromArgs = mapM fromSV+ instance ToSV String where toSV str = withCStringLen str $ \(cstr, len) -> do perl5_newSVpvn cstr (toEnum len)@@ -62,17 +134,81 @@ cstr <- perl5_SvPV sv peekCString cstr +instance ToSV Int where+ toSV = perl5_newSViv . toEnum++instance ToSV Double where+ toSV = perl5_newSVnv . realToFrac++instance FromSV Int where+ fromSV = fmap fromEnum . perl5_SvIV++instance FromSV Double where+ fromSV = fmap realToFrac . perl5_SvNV++instance FromSV Bool where+ fromSV = perl5_SvTRUE++instance ToSV Bool where+ toSV True = perl5_sv_yes+ toSV False = perl5_sv_no++class ToArgs a where+ toArgs :: a -> IO [SV]++class FromArgs a where+ fromArgs :: [SV] -> IO a+ contextOf :: a -> Context+ contextOf _ = Item++instance FromArgs () where+ fromArgs _ = return ()+ contextOf _ = Void++instance ToArgs () where+ toArgs _ = return []++instance ToSV a => ToArgs a where+ toArgs = fmap (:[]) . toSV++instance (ToSV a, ToSV b) => ToArgs (a, b) where+ toArgs (x, y) = do+ x' <- toSV x+ y' <- toSV y+ return [x', y']++instance FromSV a => FromArgs a where+ fromArgs [] = fail "Can't convert an empty return list!"+ fromArgs (x:_) = fromSV x+ contextOf _ = Item+ foreign import ccall "perl5_init" perl5_init :: CInt -> Ptr CString -> IO Interpreter foreign import ccall "perl5_sv_undef" perl5_sv_undef :: IO SV+foreign import ccall "perl5_sv_yes"+ perl5_sv_yes :: IO SV+foreign import ccall "perl5_sv_no"+ perl5_sv_no :: IO SV foreign import ccall "perl5_eval"- perl5_eval :: CString -> CInt -> IO SV+ perl5_eval :: CString -> CInt -> CInt -> IO (Ptr SV) foreign import ccall "perl5_newSVpvn" perl5_newSVpvn :: CString -> CInt -> IO SV foreign import ccall "perl5_SvPV" perl5_SvPV :: SV -> IO CString+foreign import ccall "perl5_SvIV"+ perl5_SvIV :: SV -> IO CInt+foreign import ccall "perl5_SvNV"+ perl5_SvNV :: SV -> IO CDouble+foreign import ccall "perl5_newSViv"+ perl5_newSViv :: CInt -> IO SV+foreign import ccall "perl5_newSVnv"+ perl5_newSVnv :: CDouble -> IO SV foreign import ccall "perl_destruct" perl_destruct :: Interpreter -> IO CInt foreign import ccall "perl_free" perl_free :: Interpreter -> IO ()+foreign import ccall "perl5_apply"+ perl5_apply :: SV -> SV -> Ptr SV -> CInt -> IO (Ptr SV)+foreign import ccall "perl5_SvTRUE"+ perl5_SvTRUE :: SV -> IO Bool
test.hs view
@@ -1,6 +1,23 @@+{-# LANGUAGE ExtendedDefaultRules #-} import Language.Perl5 main :: IO () main = withPerl5 $ do- putStrLn =<< eval "qq[1..1]"- eval "print qq[ok 1\n]"+ _Test_ <- use "Test"++ "plan".!("tests", 2)++ x1 <- "crypt".:("salt", "plaintext")+ x2 <- "crypt".:("salt", "plaintext") :: IO String++ "ok".![x1, x2]++ ver <- _Test_.$"VERSION"$(1.00)+ "ok".!(ver :: String)++dbiDemo :: IO ()+dbiDemo = do+ _DBI_ <- use "DBI"++ dbh <- _DBI_.$"connect"$"dbi:SQLite:foo"+ dbh.$!"do"$"CREATE TABLE foo (id, moose)"