diff --git a/HsPerl5.cabal b/HsPerl5.cabal new file mode 100644 --- /dev/null +++ b/HsPerl5.cabal @@ -0,0 +1,18 @@ +name: HsPerl5 +version: 0.0.1 +copyright: 2008 Audrey Tang +license: BSD3 +license-file: LICENSE +author: Audrey Tang +maintainer: Audrey Tang +synopsis: Haskell interface to embedded Perl 5 interpreter +description: Haskell interface to embedded Perl 5 interpreter +stability: experimental +build-type: Simple +extensions: ForeignFunctionInterface +exposed-modules: Language.Perl5 +build-depends: base +extra-source-files: README test.hs configure +hs-source-dirs: src +category: Language +c-sources: p5embed.c diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ +Copyright 2008 by Audrey Tang + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to +deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,7 @@ +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runghc +> import Distribution.Simple +> main = defaultMainWithHooks autoconfUserHooks diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,20 @@ +#!/bin/sh -e + +/usr/bin/perl << CONFIGURE + +use ExtUtils::Embed; + +my @ccoptions = (split(/\s+/, ccflags()), split(/\s+/, ccdlflags())); +my @includedirs = split(/\s+/, perl_inc()); +my @ldoptions = split(/\s+/, ldopts()); +s/^-I// for @includedirs; + +open INFO, ">HsPerl5.buildinfo" or die "Cannot write build info"; +print INFO "cc-options: @ccoptions\n"; +print INFO "ld-options: @ldoptions\n"; +print INFO "include-dirs: @includedirs\n"; +close INFO; + +xsinit(); + +CONFIGURE diff --git a/p5embed.c b/p5embed.c new file mode 100644 --- /dev/null +++ b/p5embed.c @@ -0,0 +1,150 @@ +#include "p5embed.h" +#include +#include "perlxsi.c" + +/* define to enable pugsembed debug messages */ +#define PERL5_EMBED_DEBUG 0 + +#if PERL5_EMBED_DEBUG +#define oRZ "" +#define hate Perl_croak(aTHX_ "hate software") +#else +#define oRZ "#" +#define hate +#endif + +/* Workaround for mapstart: the only op which needs a different ppaddr */ +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart +#undef OP_MAPSTART +#define OP_MAPSTART OP_GREPSTART + +static PerlInterpreter *my_perl; +int _P5EMBED_INIT = 0; + +SV * +perl5_sv_undef () +{ + return(&PL_sv_undef); +} + +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 cxt) +{ + dSP; + SV* sv; + + ENTER; + SAVETMPS; + + sv = newSVpv(code, 0); +#ifdef SvUTF8_on + SvUTF8_on(sv); +#endif + eval_sv(sv, cxt); + SvREFCNT_dec(sv); + + 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)); + } + + FREETMPS; + LEAVE; + + return sv; +} + +char * +perl5_SvPV ( SV *sv ) +{ + char *rv; + rv = SvPV_nolen(sv); + return rv; +} + +SV * +perl5_newSVpvn ( char * pv, int len ) +{ + SV *sv = newSVpvn(pv, len); +#ifdef SvUTF8_on + SvUTF8_on(sv); +#endif + return(sv); +} diff --git a/src/Language/Perl5.hs b/src/Language/Perl5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Perl5.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, ScopedTypeVariables #-} +{-# INCLUDE "p5embed.h" #-} + +module Language.Perl5 + ( Context(..) + , ToSV(..) + , FromSV(..) + , withPerl5 + , eval + ) where +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Control.Exception (bracket) + +data Context = Void | Item | List + +enumContext :: (Num a) => Context -> a +enumContext Void = 128 +enumContext Item = 0 +enumContext List = 1 + +type Interpreter = Ptr () +type SV = Ptr () + +-- | Run a computation within the context of a Perl 5 interpreter. +withPerl5 :: IO a -> IO a +withPerl5 f = do + withCString "-e" $ \prog -> withCString "" $ \cstr -> do + withArray [prog, prog, cstr] $ \argv -> do + bracket (perl5_init 3 argv) (\interp -> do + perl_destruct interp + 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 + +-- | Data types that can be casted into a Perl 5 value (SV). +class ToSV a where + toSV :: a -> IO SV + +-- | 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 () where + toSV _ = perl5_sv_undef +instance FromSV () where + fromSV x = seq x (return ()) + contextOf _ = Void + +instance ToSV String where + toSV str = withCStringLen str $ \(cstr, len) -> do + perl5_newSVpvn cstr (toEnum len) +instance FromSV String where + fromSV sv = do + cstr <- perl5_SvPV sv + peekCString cstr + +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_eval" + perl5_eval :: CString -> CInt -> IO 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 "perl_destruct" + perl_destruct :: Interpreter -> IO CInt +foreign import ccall "perl_free" + perl_free :: Interpreter -> IO () diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,6 @@ +import Language.Perl5 + +main :: IO () +main = withPerl5 $ do + putStrLn =<< eval "qq[1..1]" + eval "print qq[ok 1\n]"