Index: /lang/perl/arguments/trunk/t/arguments.t =================================================================== --- /lang/perl/arguments/trunk/t/arguments.t (revision 10886) +++ /lang/perl/arguments/trunk/t/arguments.t (revision 10886) @@ -0,0 +1,15 @@ +use Test::More tests => 5; +BEGIN { use_ok('arguments') }; + +do { + my $f; $f = sub { + ok($f eq arguments::callee); + }; +}->(); + +sub { + my $c = shift; + ok($c); + arguments::callee->($c) if (--$c); +}->(3); + Index: /lang/perl/arguments/trunk/MANIFEST =================================================================== --- /lang/perl/arguments/trunk/MANIFEST (revision 10886) +++ /lang/perl/arguments/trunk/MANIFEST (revision 10886) @@ -0,0 +1,7 @@ +arguments.xs +Changes +Makefile.PL +MANIFEST +README +t/arguments.t +lib/arguments.pm Index: /lang/perl/arguments/trunk/lib/arguments.pm =================================================================== --- /lang/perl/arguments/trunk/lib/arguments.pm (revision 10886) +++ /lang/perl/arguments/trunk/lib/arguments.pm (revision 10886) @@ -0,0 +1,52 @@ +package arguments; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +require XSLoader; +XSLoader::load('arguments', $VERSION); + +sub callee { + my $level = shift; + $level = 0 if (!defined $level); + my $cx = _upcontext($level + 1); + return unless $cx; + return _context_cv($cx); +} + +1; +__END__ + +=head1 NAME + +arguments.xs - Perl extension for arguments::callee + +=head1 SYNOPSIS + + use arguments; + + sub { + my $c = shift; + print "$c\n"; + arguments::callee->($c) if ($c--); + }->(10); + +=head1 DESCRIPTION + +inspired by arguments.callee from ECMAScript. + +see also. +http://d.hatena.ne.jp/amachang/20080501/1209623634 + +=head1 SEE ALSO + +Devel::Caller, PadWalker + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut Index: /lang/perl/arguments/trunk/Makefile.PL =================================================================== --- /lang/perl/arguments/trunk/Makefile.PL (revision 10886) +++ /lang/perl/arguments/trunk/Makefile.PL (revision 10886) @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +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' + 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 +); Index: /lang/perl/arguments/trunk/Changes =================================================================== --- /lang/perl/arguments/trunk/Changes (revision 10886) +++ /lang/perl/arguments/trunk/Changes (revision 10886) @@ -0,0 +1,5 @@ +Revision history for Perl extension arguments. + +0.01 Thu May 1 16:34:55 2008 + - original version; created + Index: /lang/perl/arguments/trunk/README =================================================================== --- /lang/perl/arguments/trunk/README (revision 10886) +++ /lang/perl/arguments/trunk/README (revision 10886) @@ -0,0 +1,14 @@ +arguments version 0.01 +====================== + +arguments.xs - Perl extension for arguments::callee + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + Index: /lang/perl/arguments/trunk/arguments.xs =================================================================== --- /lang/perl/arguments/trunk/arguments.xs (revision 10886) +++ /lang/perl/arguments/trunk/arguments.xs (revision 10886) @@ -0,0 +1,104 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* copy code from PadWalker.xs */ +I32 +dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) +{ + dTHR; + I32 i; + PERL_CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_SUB: + /* In Perl 5.005, formats just used CXt_SUB */ +#ifdef CXt_FORMAT + case CXt_FORMAT: +#endif + return i; + } + } + return i; +} + +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) +{ + PERL_SI *top_si = PL_curstackinfo; + I32 cxix = dopoptosub(aTHX_ 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; + } + 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)) + 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; + } + if (ccstack_p) *ccstack_p = ccstack; + return &ccstack[cxix]; +} + +/* copy code from Devel-Caller/Caller.xs */ + +MODULE = arguments PACKAGE = arguments +PROTOTYPES: DISABLE + +void +_upcontext(uplevel) +I32 uplevel + PPCODE: + XPUSHs(sv_2mortal(newSViv((IV)upcontext(aTHX_ uplevel, 0, 0, 0, 0)))); + +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 + +