[svn:parrot] r41552 - in trunk: src/pmc t/pmc

[bacek at svn.parrot.org]

Author: bacek
Date: Tue Sep 29 11:42:40 2009
New Revision: 41552
URL: https://trac.parrot.org/parrot/changeset/41552

Log:
[core] Expose some Context fields into PIR.

Modified:
   trunk/src/pmc/context.pmc
   trunk/t/pmc/context.t

Modified: trunk/src/pmc/context.pmc
==============================================================================
--- trunk/src/pmc/context.pmc	Tue Sep 29 10:34:15 2009	(r41551)
+++ trunk/src/pmc/context.pmc	Tue Sep 29 11:42:40 2009	(r41552)
@@ -139,6 +139,52 @@
     VTABLE void set_pointer(void *context) {
         PMC_data(SELF) = context;
     }
+
+/*
+
+=item C<PMC *get_pmc_keyed_str(STRING *key)>
+
+Introspection interface. C<key> can be:
+
+    caller_ctx          ... return Caller Context
+    lex_pad             ... return LexPad
+    outer_ctx           ... return Outer Context
+    current_sub         ... return current Sub
+    handlers            ... return list of ExceptioHandlers
+    current_cont        ... return current Continuation
+    current_object      ... return current Object (if in method call)
+    current_namespace   ... return current Namespace
+=cut
+
+*/
+    VTABLE PMC *get_pmc_keyed_str(STRING *key) {
+        Parrot_Context *ctx = PMC_data_typed(SELF, Parrot_Context*);
+
+        if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "caller_ctx")))
+            return ctx->caller_ctx;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "lex_pad")))
+            return ctx->lex_pad;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "outer_ctx")))
+            return ctx->outer_ctx;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "current_sub")))
+            return ctx->current_sub;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "current_cont")))
+            return ctx->current_cont;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "current_object")))
+            return ctx->current_object;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "current_namespace")))
+            return ctx->current_namespace;
+        else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "handlers")))
+            return ctx->handlers;
+
+        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
+                "No such item %Ss", key);
+    }
+
+    VTABLE PMC *get_pmc_keyed(PMC *key) {
+        return STATICSELF.get_pmc_keyed_str(VTABLE_get_string(INTERP, key));
+    }
+
 }
 
 /*

Modified: trunk/t/pmc/context.t
==============================================================================
--- trunk/t/pmc/context.t	Tue Sep 29 10:34:15 2009	(r41551)
+++ trunk/t/pmc/context.t	Tue Sep 29 11:42:40 2009	(r41552)
@@ -21,13 +21,105 @@
 .sub main :main
     .include 'test_more.pir'
 
-    plan(1)
+    plan(15)
 
+    test_new()
+
+    $P0 = get_hll_global ['Foo'], 'load'
+    $P0()
+    $P0 = new ['Foo']
+    $P0.'test_inspect'()
+
+.end
+
+.sub 'test_new'
     $P0 = new ['Context']
     sweep 1
     ok(1, 'Instantiated .Context')
 .end
 
+# Put test_inspect into Namespace, as method, with outer, etc.
+.namespace ['Foo']
+
+.sub 'load'
+    $P0 = newclass 'Foo'
+.end
+
+.sub 'test_inspect' :method :outer('load')
+    .include 'test_more.pir'
+
+    .local pmc ctx
+
+    # We need LexPad
+    .lex 'foo_ctx', ctx
+
+    $P0 = getinterp
+    ctx = $P0['context']
+    $I0 = defined ctx 
+    ok($I0, "Got Context")
+
+    # Check current_sub first. Other tests relying on it
+    $P0 = ctx['current_sub']
+    is($P0, 'test_inspect', 'Got Context.current_sub')
+
+    $P0 = ctx['caller_ctx']
+    $I0 = isa $P0, 'Context'
+    ok($I0, 'Got Context.caller_ctx')
+    $P0 = $P0['current_sub']
+    is($P0, 'main', '... from proper Sub')
+
+    $P0 = ctx['outer_ctx']
+    $I0 = isa $P0, 'Context'
+    ok($I0, 'Got Context.outer_ctx')
+    $P0 = $P0['current_sub']
+    is($P0, 'load', '... from proper Sub')
+
+    $P0 = ctx['lex_pad']
+    $I0 = isa $P0, 'LexPad'
+    ok($I0, 'Got Context.lex_pad')
+    $P1 = $P0['foo_ctx']
+    $I0 = defined $P1
+    ok($I0, '... with proper content')
+
+    $P0 = ctx['current_cont']
+    $I0 = isa $P0, 'Continuation'
+    ok($I0, 'Got Context.current_cont')
+
+    $P0 = ctx['current_object']
+    $I0 = isa $P0, 'Foo'
+    ok($I0, 'Got Context.current_object')
+
+    $P0 = ctx['current_namespace']
+    ok($P0, 'Got Context.current_namespace')
+    $P1 = $P0['test_inspect']
+    is($P1, 'test_inspect', '... with proper content')
+
+    # Checking handlers
+    push_eh done
+    $P0 = ctx['handlers']
+    $I0 = elements $P0
+
+    push_eh cought
+    # Now we should have one more handler
+    $P0 = ctx['handlers']
+    $I1 = elements $P0
+    dec $I1
+    is($I0, $I1, 'Got Context.handlers')
+
+    # Check absurd fields
+    $I0 = 1
+    $P0 = ctx['world_domination']
+    $I0 = 0
+  cought:
+    pop_eh
+    ok($I0, "No world domination in this Context")
+
+
+  done:
+    pop_eh
+
+.end
+
 # Local Variables:
 #   mode: pir
 #   fill-column: 100