Changeset 15441 for src/Pugs/Meta

Timestamp:

03/04/07 14:42:37 (21 months ago)

Author:

audreyt

Message:

* Pugs.Meta.Perl5: The Grand Perl 5 Bridge Box

Files:

• src/Pugs/Meta/Perl5.hs (modified) (2 diffs)

src/Pugs/Meta/Perl5.hs

@@ -5 +5 @@
 import Pugs.Class
 import Pugs.Embed.Perl5
-import Data.Typeable
+import Pugs.Internals
+import Data.Typeable (Typeable)
+import qualified Data.Map as Map
+import {-# SOURCE #-} Pugs.AST.Internals (envContext, anyToVal)
+import Pugs.Types
 
 data Perl5Responder = Perl5Responder deriving Typeable
@@ -16 +20 @@
 instance Boxable Eval PerlSV where
     mkObj sv = MkInvocant sv (MkResponder (return Perl5Responder))
+    fromObj (MkInvocant x _)
+        | Just x' <- fromTypeable x = return x'
+        | Just x' <- fromTypeable x = liftIO $ vstrToSV x'
+        | Just x' <- fromTypeable x = liftIO . bufToSV  $ (cast :: PureStr -> ByteString) x'
+        | Just x' <- fromTypeable x = liftIO . vintToSV $ (cast :: PureInt -> Integer)    x'
+        | Just x' <- fromTypeable x = liftIO . vnumToSV $ (cast :: PureNum -> Double)     x'
+        | otherwise                 = fail $ "Cannot coerce to SV: " ++ show (typeOf x)
+
 
 dispatchPerl5 :: Val -> Call -> Eval Val
 dispatchPerl5 inv call = do
-    fail $ "Dispatch failed - " ++ show (miName call)
+    let feed = concatFeeds (c_feeds (miArguments call))
+    invSV   <- fromObj inv
+    subSV   <- liftIO . bufToSV . cast $ miName call
+    posSVs  <- mapM fromObj (fromP $ f_positionals feed)
+    namSVs  <- fmap concat . forM (Map.toList (f_nameds feed)) $ \(key, vals) -> do
+        keySV   <- liftIO (bufToSV $ cast key)
+        fmap concat . forM (fromP vals) $ \v -> do
+            valSV   <- fromObj v
+            return [keySV, valSV]
+    env     <- ask
+    rv      <- liftIO $ do
+        envSV   <- mkEnv env
+        invokePerl5 subSV invSV (posSVs ++ namSVs) envSV (enumCxt $ envContext env)
+    case rv of
+        Perl5ReturnValues [x]   -> return $ mkVal x 
+        Perl5ReturnValues xs    -> return $ mkVal xs
+        Perl5ErrorString str    -> fail str
+        Perl5ErrorObject err    -> throwError (anyToVal err)