packages feed

HsPerl5 0.0.2 → 0.0.3

raw patch · 5 files changed

+315/−79 lines, 5 files

Files

HsPerl5.cabal view
@@ -1,5 +1,5 @@ name:               HsPerl5-version:            0.0.2+version:            0.0.3 copyright:          2008 Audrey Tang license:            BSD3 license-file:       LICENSE@@ -12,14 +12,20 @@                     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+                    Currently supported features are:+                        * Function calls+                        * Method calls+                        * Module imports+                        * Callbacks++                    Eventually, the entirety of Pugs.Embed.Perl5 and Pugs.Run.Perl5 will be                     carried into this module.  stability:          experimental build-type:         Simple extensions:         ForeignFunctionInterface, TypeSynonymInstances,                     ScopedTypeVariables, FlexibleInstances,-                    UndecidableInstances, OverlappingInstances+                    UndecidableInstances, OverlappingInstances, IncoherentInstances exposed-modules:    Language.Perl5 build-depends:      base extra-source-files: README test.hs configure
README view
@@ -3,5 +3,11 @@ Documentation and functionality is scarce at the moment; see test.hs for some basic usage examples. +Currently supported features are:+    * Function calls+    * Method calls+    * Module imports+    * Callbacks+ Eventually the entirety of Pugs.Embed.Perl5 and Pugs.Run.Perl5 will be carried into this module.
p5embed.c view
@@ -1,3 +1,6 @@+#ifndef HsPerl5DefinedC+#define HsPerl5DefinedC 1+ #include "p5embed.h" #include <XSUB.h> #include "perlxsi.c"@@ -13,6 +16,14 @@ #define hate #endif +const char HsPerl5Preamble[] =+"package __HsPerl5__;\n\n"+"sub MkCode {\n"+"    my $val = shift;\n"+"    sub { unshift @_, $val; goto &__HsPerl5__::Invoke }\n"+"}\n"+"1;\n";+ /* Workaround for mapstart: the only op which needs a different ppaddr */ #undef Perl_pp_mapstart #define Perl_pp_mapstart Perl_pp_grepstart@@ -40,77 +51,6 @@     return(&PL_sv_no); } -PerlInterpreter *-perl5_init ( int argc, char **argv )-{-    int exitstatus;-    int i;--#ifdef PERL_GPROF_MONCONTROL-    PERL_GPROF_MONCONTROL(0);-#endif--#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && defined(HAS_PTHREAD_ATFORK)-    /* XXX Ideally, this should really be happening in perl_alloc() or-     * perl_construct() to keep libperl.a transparently fork()-safe.-     * It is currently done here only because Apache/mod_perl have-     * problems due to lack of a call to cancel pthread_atfork()-     * handlers when shared objects that contain the handlers may-     * be dlclose()d.  This forces applications that embed perl to-     * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't-     * been called at least once before in the current process.-     * --GSAR 2001-07-20 */-    PTHREAD_ATFORK(Perl_atfork_lock,-                   Perl_atfork_unlock,-                   Perl_atfork_unlock);-#endif--    if (!PL_do_undump) {-        my_perl = perl_alloc();-        if (!my_perl)-            exit(1);-        perl_construct( my_perl );-        PL_perl_destruct_level = 0;-    }-#ifdef PERL_EXIT_DESTRUCT_END-    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;-#endif /* PERL_EXIT_DESTRUCT_END */-#ifdef PERL_EXIT_EXPECTED-    PL_exit_flags |= PERL_EXIT_EXPECTED;-#endif /* PERL_EXIT_EXPECTED */--#if (defined(CSH) && defined(PL_cshname))-    if (!PL_cshlen)-      PL_cshlen = strlen(PL_cshname);-#endif--    exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);--    if (exitstatus == 0)-        exitstatus = perl_run( my_perl );--    _P5EMBED_INIT = 1;--    /*-    newXS((char*) "pugs::guts::invoke", _pugs_guts_invoke, (char*)__FILE__);-    newXS((char*) "pugs::guts::eval_apply", _pugs_guts_eval_apply, (char*)__FILE__);-    */--#if PERL5_EMBED_DEBUG-    fprintf(stderr, "(%s)", pugs_guts_code);-#endif-    /*-    eval_pv(pugs_guts_code, TRUE);-    */--    if (SvTRUE(ERRSV)) {-        STRLEN n_a;-        printf("Error init perl: %s\n", SvPV(ERRSV,n_a));-        exit(1);-    }-    return my_perl;-}- SV ** perl5_eval(char *code, int len, int cxt) {@@ -250,3 +190,164 @@     return(rv ? 1 : 0); } +SV *+perl5_make_cv ( HsStablePtr *sub )+{+    SV *sv = newSV(0);+    SV *ret = NULL;+    int count;+    sv_setref_pv(sv, "__HsPerl5__::Code", sub);+    dSP;++    ENTER;+    SAVETMPS;+    PUSHMARK(SP);+    XPUSHs(sv_2mortal(sv));+    PUTBACK;++    count = call_pv("__HsPerl5__::MkCode", G_SCALAR);++    if (count != 1) {+        croak("Big trouble\n");+    }++    SPAGAIN;+    ret = newSVsv(POPs);++    PUTBACK;+    FREETMPS;+    LEAVE;++    return (ret);+}++XS(__HsPerl5__Invoke) {+    HsStablePtr *sub;+    SV **stack;+    SV **ret;+    SV **cur;+    SV *sv;+    int i;++    IV tmp = 0;+            +    dXSARGS;++    if (items < 1) {+      hate;+    }++    sv = ST(0);++    tmp = SvIV((SV*)SvRV(sv));+    sub = (HsStablePtr *)tmp;++    New(6, stack, items, SV*);++    for (i = 1; i < items; ++i) {+        stack[i-1] = ST(i);+    }+    stack[i-1] = NULL;+    Safefree(stack);+    +    SPAGAIN;++    ret = hsPerl5Apply(sub, stack, GIMME_V);+    if (ret == NULL) {+        XSRETURN(0);+    }++    for (cur = ret; *cur != NULL; ++cur) {+        EXTEND(SP, 1);+        ST(cur - ret) = *cur;+    }+    Safefree(ret);++    XSRETURN(cur - ret);+}++PerlInterpreter *+perl5_init ( int argc, char **argv )+{+    int exitstatus;+    int i;++#ifdef PERL_GPROF_MONCONTROL+    PERL_GPROF_MONCONTROL(0);+#endif++#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && defined(HAS_PTHREAD_ATFORK)+    /* XXX Ideally, this should really be happening in perl_alloc() or+     * perl_construct() to keep libperl.a transparently fork()-safe.+     * It is currently done here only because Apache/mod_perl have+     * problems due to lack of a call to cancel pthread_atfork()+     * handlers when shared objects that contain the handlers may+     * be dlclose()d.  This forces applications that embed perl to+     * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't+     * been called at least once before in the current process.+     * --GSAR 2001-07-20 */+    PTHREAD_ATFORK(Perl_atfork_lock,+                   Perl_atfork_unlock,+                   Perl_atfork_unlock);+#endif++    if (!PL_do_undump) {+        my_perl = perl_alloc();+        if (!my_perl)+            exit(1);+        perl_construct( my_perl );+        PL_perl_destruct_level = 0;+    }+#ifdef PERL_EXIT_DESTRUCT_END+    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;+#endif /* PERL_EXIT_DESTRUCT_END */+#ifdef PERL_EXIT_EXPECTED+    PL_exit_flags |= PERL_EXIT_EXPECTED;+#endif /* PERL_EXIT_EXPECTED */++#if (defined(CSH) && defined(PL_cshname))+    if (!PL_cshlen)+      PL_cshlen = strlen(PL_cshname);+#endif++    exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);++    if (exitstatus == 0)+        exitstatus = perl_run( my_perl );++    _P5EMBED_INIT = 1;++    newXS((char*) "__HsPerl5__::Invoke", __HsPerl5__Invoke, (char*)__FILE__);+    /*+    newXS((char*) "pugs::guts::eval_apply", _pugs_guts_eval_apply, (char*)__FILE__);+    */++#if PERL5_EMBED_DEBUG+    fprintf(stderr, "(%s)", pugs_guts_code);+#endif+    eval_pv(HsPerl5Preamble, TRUE);++    if (SvTRUE(ERRSV)) {+        STRLEN n_a;+        printf("Error init perl: %s\n", SvPV(ERRSV,n_a));+        exit(1);+    }+    return my_perl;+}++SV *+perl5_get_sv(const char *name)+{+    SV *sv = get_sv(name, 1);+    return sv;+}++SV *+perl5_get_cv(const char *name)+{+    SV *cv = (SV*)(get_cv(name, 0));+    return cv;+}+++#endif
src/Language/Perl5.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+{-# LANGUAGE ForeignFunctionInterface+           , TypeSynonymInstances+           , ScopedTypeVariables+           , FlexibleInstances+           , UndecidableInstances+           , OverlappingInstances+           , IncoherentInstances #-} {-# INCLUDE "p5embed.h" #-}  module Language.Perl5@@ -39,8 +45,10 @@  instance ToCV String where     toCV sub count = do-        let prms = map (\i -> "$_[" ++ show i ++ "]") [0 .. count-1]-        eval ("sub { " ++ sub ++ "(" ++ (concat $ intersperse ", " prms) ++ ") }")+        cv <- withCString sub perl5_get_cv+        if cv /= nullPtr then return cv else 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@@ -182,6 +190,90 @@     fromArgs (x:_) = fromSV x     contextOf _ = Item +instance (FromSV a, FromSV b) => FromArgs (a, b) where+    fromArgs [] = fail "Can't convert an empty return list!"+    fromArgs [_] = fail "Can't convert a single  return list!"+    fromArgs (x:y:_) = do+        x' <- fromSV x+        y' <- fromSV y+        return (x', y')+    contextOf _ = List++instance FromArgs r => FromSV (IO r) where+    -- Callback code.+    fromSV x = do+        return $ callSub x ()++instance (ToArgs a, FromArgs r) => FromSV (a -> IO r) where+    -- Callback code.+    fromSV x = do+        return $ callSub x++instance (ToArgs a, ToArgs b, FromArgs r) => FromSV (a -> b -> IO r) where+    -- Callback code.+    fromSV x = do+        -- First we obtain x as a CV+        return $ \arg1 arg2 -> do+            as1  <- toArgs arg1+            as2  <- toArgs arg2+            callSub x (as1 ++ as2)++instance ToArgs [SV] where+    toArgs = return+instance FromArgs [SV] where+    fromArgs = return++instance ToArgs a => ToSV (IO a) where+    toSV f = do+        sp <- newStablePtr $ \_ _ -> do+            svs <- toArgs =<< f +            newArray0 nullPtr svs+        perl5_make_cv sp++instance (ToArgs a, FromArgs r) => ToSV (r -> IO a) where+    toSV f = do+        sp <- newStablePtr $ \args _ -> do+            args'   <- fromArgs =<< peekArray0 nullPtr args+            svs     <- toArgs =<< f args'+            newArray0 nullPtr svs+        perl5_make_cv sp++instance (ToArgs a, FromArgs (r1, r2)) => ToSV (r1 -> r2 -> IO a) where+    toSV f = do+        sp <- newStablePtr $ \args _ -> do+            (a1, a2)    <- fromArgs =<< peekArray0 nullPtr args+            svs         <- toArgs =<< f a1 a2+            newArray0 nullPtr svs+        perl5_make_cv sp++instance (ToArgs a, FromArgs r) => ToSV (r -> a) where+    toSV f = do+        sp <- newStablePtr $ \args _ -> do+            args'   <- fromArgs =<< peekArray0 nullPtr args+            svs     <- toArgs $ f args'+            newArray0 nullPtr svs+        perl5_make_cv sp++instance (ToArgs a, FromArgs (r1, r2)) => ToSV (r1 -> r2 -> a) where+    toSV f = do+        sp <- newStablePtr $ \args _ -> do+            (a1, a2)    <- fromArgs =<< peekArray0 nullPtr args+            svs         <- toArgs $ f a1 a2+            newArray0 nullPtr svs+        perl5_make_cv sp++type Callback = Ptr SV -> CInt -> IO (Ptr SV)++hsPerl5Apply :: StablePtr Callback -> Ptr SV -> CInt -> IO (Ptr SV)+hsPerl5Apply ptr args cxt = do+    f <- deRefStablePtr ptr+    f args cxt++foreign export ccall "hsPerl5Apply"+    hsPerl5Apply :: StablePtr Callback -> Ptr SV -> CInt -> IO (Ptr SV)++foreign import ccall "perl5_make_cv"+    perl5_make_cv :: StablePtr Callback -> IO SV foreign import ccall "perl5_init"     perl5_init :: CInt -> Ptr CString -> IO Interpreter foreign import ccall "perl5_sv_undef"@@ -212,3 +304,7 @@     perl5_apply :: SV -> SV -> Ptr SV -> CInt -> IO (Ptr SV) foreign import ccall "perl5_SvTRUE"     perl5_SvTRUE :: SV -> IO Bool+foreign import ccall "perl5_get_sv"+    perl5_get_sv :: CString -> IO SV+foreign import ccall "perl5_get_cv"+    perl5_get_cv :: CString -> IO SV
test.hs view
@@ -5,7 +5,7 @@ main = withPerl5 $ do     _Test_  <- use "Test" -    "plan".!("tests", 2)+    "plan".!("tests", 11)      x1 <- "crypt".:("salt", "plaintext")     x2 <- "crypt".:("salt", "plaintext") :: IO String@@ -15,9 +15,36 @@     ver <- _Test_.$"VERSION"$(1.00)     "ok".!(ver :: String) +    code <- eval "sub { ok 1 }" :: IO (IO ())+    code++    code' <- eval "sub { ok $_[0] }" :: IO (Int -> IO ())+    code' 123++    foo <- eval "sub { $_[0]->() }" :: IO (IO () -> IO ())+    foo (putStrLn "ok 5")++    foo <- eval "sub { print $_[0]->(q[ok]) }" :: IO ((String -> IO String) -> IO ())+    foo (\x -> return (x ++ " 6\n"))++    foo <- eval "sub { print $_[0]->(q[ok]) }" :: IO ((String -> String) -> IO ())+    foo (++ " 7\n")++    foo <- eval "sub { print $_[0]->(q[ok], qq[ 8\n]) }" :: IO ((String -> String -> String) -> IO ())+    foo (++)++    say <- eval "sub { print qq[$_[0] $_[1]\n] }" :: IO (String -> Int -> IO ())+    say "ok" 9++    rec <- eval "sub { $_[0]->(sub { $_[0]->() }) }"+    rec (($ (putStrLn "ok 10")) :: (IO () -> IO ()) -> IO ()) :: IO ()++    eval_ "sub my_ok { print qq[ok @_\n] }"+    "my_ok".!11+ dbiDemo :: IO () dbiDemo = do-    _DBI_   <- use "DBI"+    _DBI_ <- use "DBI"      dbh <- _DBI_.$"connect"$"dbi:SQLite:foo"     dbh.$!"do"$"CREATE TABLE foo (id, moose)"