diff --git a/Foreign/Ruby.hs b/Foreign/Ruby.hs --- a/Foreign/Ruby.hs +++ b/Foreign/Ruby.hs @@ -14,6 +14,7 @@ , loadFile , Foreign.Ruby.Safe.embedHaskellValue , Foreign.Ruby.Safe.safeMethodCall + , Foreign.Ruby.Safe.safeFunCall , makeSafe , RubyError(..) -- * Converting to and from Ruby values diff --git a/Foreign/Ruby/Bindings.hsc b/Foreign/Ruby/Bindings.hsc --- a/Foreign/Ruby/Bindings.hsc +++ b/Foreign/Ruby/Bindings.hsc @@ -14,18 +14,16 @@ -- | The Ruby ID type, mostly used for symbols. type RID = CULong -data ShimDispatch = ShimDispatch String String [RValue] +data ShimDispatch = ShimDispatch RValue RID [RValue] instance Storable ShimDispatch where sizeOf _ = (#size struct s_dispatch) alignment = sizeOf - peek ptr = do a <- peekCString ((#ptr struct s_dispatch, classname) ptr) - b <- peekCString ((#ptr struct s_dispatch, methodname) ptr) + peek ptr = do a <- peek ((#ptr struct s_dispatch, receiver) ptr) + b <- peek ((#ptr struct s_dispatch, methodid) ptr) return (ShimDispatch a b []) poke ptr (ShimDispatch c m vals) = do - cs <- newCString c - cm <- newCString m - (#poke struct s_dispatch, classname) ptr cs - (#poke struct s_dispatch, methodname) ptr cm + (#poke struct s_dispatch, receiver) ptr c + (#poke struct s_dispatch, methodid) ptr m (#poke struct s_dispatch, nbargs) ptr (length vals) let arrayblock = (#ptr struct s_dispatch, args) ptr pokeArray arrayblock vals @@ -113,6 +111,7 @@ foreign import ccall safe "rb_define_global_function" c_rb_define_global_function :: CString -> FunPtr a -> Int -> IO () foreign import ccall unsafe "rb_const_get" rb_const_get :: RValue -> RID -> IO RValue foreign import ccall safe "&safeCall" safeCallback :: FunPtr (RValue -> IO RValue) +foreign import ccall safe "&getRubyCObject" getRubyCObjectCallback :: FunPtr (RValue -> IO RValue) foreign import ccall safe "rb_protect" c_rb_protect :: FunPtr (RValue -> IO RValue) -> RValue -> Ptr Int -> IO RValue foreign import ccall unsafe "rb_string_value_cstr" c_rb_string_value_cstr :: Ptr RValue -> IO CString foreign import ccall unsafe "rb_ary_new" rb_ary_new :: IO RValue diff --git a/Foreign/Ruby/Helpers.hs b/Foreign/Ruby/Helpers.hs --- a/Foreign/Ruby/Helpers.hs +++ b/Foreign/Ruby/Helpers.hs @@ -4,6 +4,7 @@ import Foreign.Ruby.Bindings import Foreign +import Foreign.C (withCString) import Data.Aeson import Control.Monad import qualified Data.Text as T @@ -190,26 +191,49 @@ defineGlobalClass :: String -> IO RValue defineGlobalClass s = peek rb_cObject >>= rb_define_class s --- | Runs a Ruby method, capturing errors. -safeMethodCall :: String -- ^ Class name. +-- | Gets a Ruby class, capturing errors. +safeGetClass :: String -> IO (Either (String, RValue) RValue) +safeGetClass s = + withCString s $ \cs -> + with 0 $ \pstatus -> do + o <- c_rb_protect getRubyCObjectCallback (castPtr cs) pstatus + status <- peek pstatus + if status == 0 + then pure $ Right o + else do + err <- showErrorStack + pure $ Left (err, o) + +-- | Runs a Ruby singleton method, capturing errors. +safeMethodCall :: String -- ^ Name of a class or a module. -> String -- ^ Method name. -> [RValue] -- ^ Arguments. Please note that the maximum number of arguments is 16. -> IO (Either (String, RValue) RValue) -- ^ Returns either an error message / value couple, or the value returned by the function. -safeMethodCall classname methodname args = - if length args > 16 - then return (Left ("too many arguments", rbNil)) - else do - dispatch <- new (ShimDispatch classname methodname args) - pstatus <- new 0 - o <- c_rb_protect safeCallback (castPtr dispatch) pstatus - status <- peek pstatus - free dispatch - free pstatus - if status == 0 - then return (Right o) - else do - err <- showErrorStack - return (Left (err,o)) +safeMethodCall classname methodname args = do + erecv <- safeGetClass classname + case erecv of + Right recv -> safeFunCall recv methodname args + Left err -> pure $ Left err + +-- | Runs a Ruby method, capturing errors. +safeFunCall + :: RValue -- ^ Receiver. + -> String -- ^ Method name. + -> [RValue] -- ^ Arguments. Please note that the maximum number of arguments is 16. + -> IO (Either (String, RValue) RValue) -- ^ Returns either an error message / value couple, or the value returned by the function. +safeFunCall recv methodname args + | length args > 16 = pure $ Left ("too many arguments", rbNil) + | otherwise = + rb_intern methodname >>= \methodid -> + with (ShimDispatch recv methodid args) $ \dispatch -> + with 0 $ \pstatus -> do + o <- c_rb_protect safeCallback (castPtr dispatch) pstatus + status <- peek pstatus + if status == 0 + then pure $ Right o + else do + err <- showErrorStack + pure $ Left (err, o) -- | Gives a (multiline) error friendly string representation of the last -- error. diff --git a/Foreign/Ruby/Safe.hs b/Foreign/Ruby/Safe.hs --- a/Foreign/Ruby/Safe.hs +++ b/Foreign/Ruby/Safe.hs @@ -15,6 +15,7 @@ , loadFile , embedHaskellValue , safeMethodCall + , safeFunCall , makeSafe , fromRuby , toRuby @@ -115,7 +116,7 @@ embedHaskellValue :: RubyInterpreter -> a -> IO (Either RubyError RValue) embedHaskellValue int v = makeSafe int $ FR.embedHaskellValue v --- | A safe version of the corresponding "Foreign.Ruby" function. +-- | A safe version of the corresponding "Foreign.Ruby.Helper" function. safeMethodCall :: RubyInterpreter -> String -> String @@ -123,6 +124,19 @@ -> IO (Either RubyError RValue) safeMethodCall int className methodName args = do o <- makeSafe int $ FR.safeMethodCall className methodName args + case o of + Left x -> return (Left x) + Right (Right v) -> return (Right v) + Right (Left (s,v)) -> return (Left (WithOutput s v)) + +-- | A safe version of the corresponding "Foreign.Ruby.Helper" function. +safeFunCall :: RubyInterpreter + -> RValue + -> String + -> [RValue] + -> IO (Either RubyError RValue) +safeFunCall int receiver methodName args = do + o <- makeSafe int $ FR.safeFunCall receiver methodName args case o of Left x -> return (Left x) Right (Right v) -> return (Right v) diff --git a/cbits/shim.c b/cbits/shim.c --- a/cbits/shim.c +++ b/cbits/shim.c @@ -29,13 +29,14 @@ VALUE safeCall(VALUE args) { struct s_dispatch * d = (struct s_dispatch *) args; - VALUE myclass = rb_const_get(rb_cObject, rb_intern(d->classname)); - VALUE o = rb_funcall2(myclass, rb_intern(d->methodname), d->nbargs, d->args); - free(d->methodname); - free(d->classname); - return o; + return rb_funcall2(d->receiver, d->methodid, d->nbargs, d->args); } +VALUE getRubyCObject(VALUE name) +{ + return rb_const_get(rb_cObject, rb_intern((const char*) name)); +} + long arrayLength(VALUE r) { return RARRAY_LEN(r); @@ -64,4 +65,3 @@ double num2dbl(VALUE v) { NUM2DBL(v); } - diff --git a/cbits/shim.h b/cbits/shim.h --- a/cbits/shim.h +++ b/cbits/shim.h @@ -6,8 +6,8 @@ void ruby_initialization(void); struct s_dispatch { - char * classname; - char * methodname; + VALUE receiver; + ID methodid; int nbargs; VALUE args[16]; }; diff --git a/hruby.cabal b/hruby.cabal --- a/hruby.cabal +++ b/hruby.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: hruby -version: 0.3.7 +version: 0.3.8 synopsis: Embed a Ruby intepreter in your Haskell program ! description: This doesn't work with Ruby 1.9. Everything you need should be in Foreign.Ruby.Safe. license: BSD3 diff --git a/test/roundtrip.hs b/test/roundtrip.hs --- a/test/roundtrip.hs +++ b/test/roundtrip.hs @@ -3,6 +3,7 @@ import Foreign.Ruby import Data.Aeson import Control.Monad +import System.Exit (exitFailure) import Test.QuickCheck import Test.QuickCheck.Monadic import qualified Data.Text as T @@ -54,4 +55,5 @@ main :: IO () main = withRubyInterpreter $ \i -> do loadFile i "./test/test.rb" >>= either (error . show) return - quickCheckWith (stdArgs { maxSuccess = 1000 } ) (roundTrip i) + result <- quickCheckWithResult (stdArgs { maxSuccess = 1000 } ) (roundTrip i) + unless (isSuccess result) exitFailure