Changeset 14595 for lang/perl/arguments

Timestamp:

06/25/08 16:51:22 (5 years ago)

Author:

takesako

Message:

fixed up for shibuya.pm#9 XS Nite

Location:

lang/perl/arguments/trunk

Files:

• Changes (modified) (1 diff)
• Makefile.PL (modified) (1 diff)
• arguments.xs (modified) (3 diffs)
• lib/arguments.pm (modified) (2 diffs)
• t/arguments.t (modified) (1 diff)

lang/perl/arguments/trunk/Changes

@@ -1 +1 @@
 Revision history for Perl extension arguments.
+
+0.03  Wed Jun 25 16:50:19 JST 2008
+        - fixed up
 
 0.02  Thu May  1 22:04:15 JST 2008

lang/perl/arguments/trunk/Makefile.PL

@@ -2 +2 @@
 WriteMakefile(
     NAME              => 'arguments',
-    VERSION_FROM      => 'lib/arguments.pm', # finds $VERSION
-    PREREQ_PM         => {}, # e.g., Module::Name => 1.1
-    LIBS              => [''], # e.g., '-lm'
-    DEFINE            => '', # e.g., '-DHAVE_SOMETHING'
+    VERSION_FROM      => 'lib/arguments.pm',
+    PREREQ_PM         => {},    # e.g., Module::Name => 1.1
+    LIBS              => [''],  # e.g., '-lm'
+    DEFINE            => '',    # e.g., '-DHAVE_SOMETHING'
     INC               => '-I.', # e.g., '-I. -I/usr/include/other'
-        # Un-comment this if you add C files to link with later:
-    # OBJECT            => '$(O_FILES)', # link all the C files too
 );

lang/perl/arguments/trunk/arguments.xs

@@ -3 +3 @@
 #include "XSUB.h"
 
-/* copy code from PadWalker.xs */
+/* base xs code from PadWalker.xs */
 I32
-dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
+_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 starting_block)
 {
     dTHR;
     I32 i;
     PERL_CONTEXT *cx;
-    for (i = startingblock; i >= 0; i--) {
+    for (i = starting_block; i >= 0; i--) {
         cx = &cxstk[i];
         switch (CxTYPE(cx)) {
@@ -16 +16 @@
             continue;
         case CXt_SUB:
-        /* In Perl 5.005, formats just used CXt_SUB */
-#ifdef CXt_FORMAT
-       case CXt_FORMAT:
+#ifdef CXt_FORMAT /* In Perl 5.005, formats just used CXt_SUB */
+        case CXt_FORMAT:
 #endif
             return i;
@@ -26 +25 @@
 }
 
-I32
-dopoptosub(pTHX_ I32 startingblock)
-{
-    dTHR;
-    return dopoptosub_at(aTHX_ cxstack, startingblock);
-}
-
 PERL_CONTEXT*
-upcontext(I32 count, COP **cop_p, PERL_CONTEXT **ccstack_p, 
-          I32 *cxix_from_p, I32 *cxix_to_p) 
+_upcontext(pTHX_ I32 count) 
 {
     PERL_SI *top_si = PL_curstackinfo;
-    I32 cxix = dopoptosub(aTHX_ cxstack_ix);
+    I32 cxix = _dopoptosub_at(aTHX_ cxstack, cxstack_ix);
     PERL_CONTEXT *ccstack = cxstack;
 
-    if (cxix_from_p) *cxix_from_p = cxstack_ix+1;
-    if (cxix_to_p)   *cxix_to_p   = cxix;
     for (;;) {
-        /* we may be in a higher stacklevel, so dig down deeper */
         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
             top_si  = top_si->si_prev;
             ccstack = top_si->si_cxstack;
-            cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
-                        if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
-                        if (cxix_to_p) *cxix_to_p = cxix;
+            cxix = _dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
         }
-        if (cxix < 0 && count == 0) {
-                    if (ccstack_p) *ccstack_p = ccstack;
-            return (PERL_CONTEXT *)0;
-                }
-        else if (cxix < 0)
-            return (PERL_CONTEXT *)-1;
-        if (PL_DBsub && cxix >= 0 &&
-                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+        if (cxix < 0) {
+            return (PERL_CONTEXT *) NULL;
+        }
+        if (PL_DBsub && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
             count++;
         if (!count--)
             break;
 
-        if (cop_p) *cop_p = ccstack[cxix].blk_oldcop;
-        cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
-                        if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
-                        if (cxix_to_p) *cxix_to_p = cxix;
+        cxix = _dopoptosub_at(aTHX_ ccstack, cxix - 1);
     }
-    if (ccstack_p) *ccstack_p = ccstack;
     return &ccstack[cxix];
 }
 
-/* copy code from Devel-Caller/Caller.xs */
+/* base xs code from Devel-Caller/Caller.xs */
 
 MODULE = arguments              PACKAGE = arguments
-PROTOTYPES: DISABLE  
+PROTOTYPES: DISABLE
 
 void
-_upcontext(uplevel)
+upcontext(uplevel)
 I32 uplevel
   PPCODE:
-    XPUSHs(sv_2mortal(newSViv((IV)upcontext(aTHX_ uplevel, 0, 0, 0, 0))));
+    PERL_CONTEXT *cx = _upcontext(aTHX_ uplevel);
+    if (!cx) {
+        ST(0) = sv_2mortal(newRV( (SV *) NULL) );
+    } else {
+        if (cx->cx_type != CXt_SUB)
+            croak("cx_type is %d not CXt_SUB\n", cx->cx_type);
+        if (!cx->blk_sub.cv)
+            croak("Context has no CV!\n");
+        ST(0) = (SV*) newRV_inc( (SV*) cx->blk_sub.cv );
+    }
+    XSRETURN(1);
 
-SV*
-_context_cv(context)
-SV* context;
-  CODE:
-    PERL_CONTEXT *cx = INT2PTR(PERL_CONTEXT *, SvIV(context));
-    CV *cur_cv;
-
-    if (cx->cx_type != CXt_SUB)
-        croak("cx_type is %d not CXt_SUB\n", cx->cx_type);
-
-    cur_cv = cx->blk_sub.cv;
-    if (!cur_cv)
-        croak("Context has no CV!\n");
-
-    RETVAL = (SV*) newRV_inc( (SV*) cur_cv );
-  OUTPUT:
-    RETVAL
-
-

lang/perl/arguments/trunk/lib/arguments.pm

@@ -4 +4 @@
 use warnings;
 
-our $VERSION = '0.02';
+our $VERSION = '0.03';
 
 use Exporter;
 our @ISA = qw(Exporter);
-our @EXPORT = qw(arguments);
+our @EXPORT = qw(arguments callee);
 
 sub arguments {
@@ -26 +26 @@
 
 sub callee {
-    my $cx = _upcontext(1);
-    return unless $cx;
-    return _context_cv($cx);
+    my $cx = upcontext(1);
+    return sub {} unless $cx;
+    return $cx;
 }
 

lang/perl/arguments/trunk/t/arguments.t

@@ -17 +17 @@
   my $x = shift;
   return 1 if ($x <= 1);
-  return $x * arguments::callee->($x - 1);
+  return $x * (arguments::callee->($x - 1));
 }->(5);
 ok($n == 120);
-
 
 sub func {