[Jifty-commit] r5733 - in B-Generate/trunk: . lib/B
Jifty commits
jifty-commit at lists.jifty.org
Sat Aug 16 11:31:11 EDT 2008
Author: clkao
Date: Sat Aug 16 11:31:11 2008
New Revision: 5733
Modified:
B-Generate/trunk/ (props changed)
B-Generate/trunk/BTest.pm
B-Generate/trunk/Changes
B-Generate/trunk/META.yml
B-Generate/trunk/lib/B/Generate.pm
B-Generate/trunk/lib/B/Generate.xs
B-Generate/trunk/t/inspect-btest.t
B-Generate/trunk/t/inspect-this.t
B-Generate/trunk/t/op_list.t
Log:
merge from 1.13.
Modified: B-Generate/trunk/BTest.pm
==============================================================================
--- B-Generate/trunk/BTest.pm (original)
+++ B-Generate/trunk/BTest.pm Sat Aug 16 11:31:11 2008
@@ -18,10 +18,10 @@
'2' => 'BINOP',
'|' => 'LOGOP',
'@' => 'LISTOP',
- '/' => 'PMOP',
- '$' => 'SVOP',
+ '/' => 'PMOP',
+ '$' => 'SVOP',
'"' => 'PVOP',
- '{' => 'LOOP',
+ '{' => 'LOOP',
';' => 'COP',,
'#' => 'PADOP',
);
@@ -43,16 +43,16 @@
} else {
warn "things depend on having B::Concise,-exec line";
}
-
+
# later, we'll emit the low-level code
if ($args{emit}) {
diag( "auto-gen'd, needs massaging\n",
"testop(\$op,\n",
- map("\t $_ \t=> '$args{$_}',\n",
+ map("\t $_ \t=> '$args{$_}',\n",
sort keys %args),
"\t);\n");
}
-
+
my $label = $args{label} || $args{name};
if ($args{ref}) {
@@ -155,7 +155,7 @@
sub parse_bcons {
# digest B::Concise,-exec line, populate \%args with tests
my $tests = shift;
-
+
my $line = $tests->{bcons};
my ($cls, $nm, $arg, $flg, $to);
@@ -170,11 +170,11 @@
$tests->{ref} = 'B::'.$clsmap{$1}
};
$long =~ s/^(\w+)// && do {
- $tests->{name} //= $1;
- $tests->{label} //= $1;
- $tests->{arg} //= $long;
+ $tests->{name} = $1 unless defined $tests->{name};
+ $tests->{label} = $1 unless defined $tests->{label};
+ $tests->{arg} = $long unless defined $tests->{arg};
};
-
+
# parse pub-flags
if ($flg) {
my ($pub,$priv) = split m|/|, $flg;
@@ -218,35 +218,36 @@
# anomalous IV,NV behavior
# ie mismatch between bcons arg and tested obj
-
- /IV$/ && do {
- $tests->{sv} //= sub { "->NV \"".(shift)->NV() .'"' };
+ # 5.8 dont have NV methods for PVIVs
+
+ /IV$/ && $] > 5.010 && do {
+ $tests->{sv} = sub { "->NV \"".(shift)->NV() .'"' } unless defined $tests->{sv};
};
/NV$/ && do {
- $tests->{sv} //= sub { "->NV \"".(shift)->NV() .'"' };
+ $tests->{sv} = sub { "->NV \"".(shift)->NV() .'"' } unless defined $tests->{sv} ;
};
/PV$/ && do {
- $tests->{sv} //=
+ $tests->{sv} =
sub {
my $sv = shift;
my $res;
ok($res = $sv->PV, "->PV $res");
ok($res = $sv->PVX, "->PVX $res");
ok($res = $sv->CUR, "->CUR $res");
- ok($res = $sv->LEN, "->LEN $res");
+ ok($res = $sv->LEN, "->LEN $res") if $] < 5.010;
Dump($sv) unless $res;
1;
- };
+ } unless defined $tests->{sv};
};
/\*(w+)$/ && do {
diag ("found gv[$1]\n");
# $tests->{sv} //= sub { "->NV \"".(shift)->NV() .'"' };
};
/t(\d+)/ && do {
- $tests->{targ} //= $1;
+ $tests->{targ} = $1 unless defined $tests->{targ};
};
}
- $tests->{type} //= B::opnumber($tests->{name});
+ $tests->{type} = B::opnumber($tests->{name}) unless defined $tests->{type};
}
@@ -342,7 +343,7 @@
each run and result is validated against values, typically something
like this:
- # f <$> const[PV "1st thing in main"] sM
+ # f <$> const[PV "1st thing in main"] sM
ok 99 - isa B::SVOP=SCALAR(0x8a32eec)
ok 100 - const->flags is 34
ok 101 - const->name is const
@@ -374,7 +375,7 @@
explanatory text (see above).
You have a lot of flexibility here; you can call any and all methods
-of the object returned by the $op->method ('sv' here). and you can
+of the object returned by the $op->method ('sv' here). and you can
- and enough rope to hang yourself.
@@ -459,12 +460,12 @@
It should be possible to do something like:
- testop($op[3],
+ testop($op[3],
bcons => '<0> pushmark s ->4',
sibling => $op[4]);
Since pushmark never has kids, its sibling is also its next, and
-should be testable. CAVEAT - tests like this dont work yet TBD.
+should be testable. CAVEAT - tests like this dont work yet. TBD
=head2 test_all_ops(\@ops, $rendering);
@@ -483,11 +484,11 @@
=head2 anomalous IV,NV behavior
-If you search the code for (heading), youll find code which attempts
-to address a discrepancy between how bconcise renders OP_CONST args
+If you search the code for (heading), you will find code which attempts
+to address a discrepancy between how B::Concise renders OP_CONST args
(typically \[(IV|NV|PVIV) (\w)+\]) and what testing shows to be fatal.
-TODO Either turn them into exception tests, or examine B::Concise to
+TODO: Either turn them into exception tests, or examine B::Concise to
see how its displaying/determining the type.
=head1 Future Development
@@ -503,7 +504,7 @@
due to brain-dead op-vector build, we only get ops which are not on a
branch, excluding if blocks, for blocks, etc..
-Consider a B::Concise callback, or
+Consider a B::Concise callback, or
=head2 sentinel
Modified: B-Generate/trunk/Changes
==============================================================================
--- B-Generate/trunk/Changes (original)
+++ B-Generate/trunk/Changes Sat Aug 16 11:31:11 2008
@@ -1,5 +1,8 @@
Revision history for Perl extension B::Generate.
+1.13 - (released by Reini Urban)
+ - same as 1.12_10
+
1.12
_01 - (against 5.10)
- fixed a GV assertion error by adding isGV_with_GP
@@ -17,6 +20,25 @@
- undo creeping 'feature'isms in tests (5.8 friendly)
- static renderings dont port, drop test_all_ops in inspect-btest
- drop filegv from nextstate tests (caused uninit-strings in prints)
+ _07 Anton Berezin
+ - fixed a leak in find_cv_by_root()
+ _08 Reini Urban
+ - cop_label now in hints_hash (5.11 Change #33656)
+ - silence use64bitint warnings
+ - fix t/inspect-btest.t test count
+ - fix t/inspect-this.t not ok 568 - ->LEN 0.
+ skip all PV->LEN tests >= 5.10
+ - removed //= from BTest to support 5.8 and older
+ _09 Reini Urban
+ - fix 5.8.8 test PVIV->NV
+ - < 5.8 and blead DEBUGGING builds fail, the rest passes
+ _10 Dmitry Karasik
+ - B::COP->new won't coredump on 5.10.0
+ - proper allocation of COP label
+ - add B::cv_pad for switching padlist during op generation
+ - add B::GVOP->new because B::PADOP is needed on threaded perls
+ where B::SVOP is normally used
+ - added missing t/op_list.t OP_LIST indices for 5.8 (Reini Urban)
1.11 - (releaed by Josh Ben Jore)
- rt#29257 - patches from Reini Urban & Jim Cromie
Modified: B-Generate/trunk/META.yml
==============================================================================
--- B-Generate/trunk/META.yml (original)
+++ B-Generate/trunk/META.yml Sat Aug 16 11:31:11 2008
@@ -1,6 +1,6 @@
---
name: B-Generate
-version: 1.12_06
+version: 1.13
author:
- |-
Simon Cozens, C<simon at cpan.org>
@@ -18,12 +18,12 @@
provides:
B::Generate:
file: lib/B/Generate.pm
- version: 1.12_06
+ version: 1.13
B::OP:
file: lib/B/Generate.pm
no_index:
package: B::OP
-generated_by: Module::Build version 0.280801
+generated_by: Module::Build version 0.280802
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
version: 1.2
Modified: B-Generate/trunk/lib/B/Generate.pm
==============================================================================
--- B-Generate/trunk/lib/B/Generate.pm (original)
+++ B-Generate/trunk/lib/B/Generate.pm Sat Aug 16 11:31:11 2008
@@ -8,7 +8,7 @@
require DynaLoader;
use vars qw( @ISA $VERSION );
@ISA = qw(DynaLoader);
-$VERSION = '1.12_06';
+$VERSION = '1.13';
{
# 'no warnings' does not work.
@@ -21,7 +21,7 @@
package B::OP;
use constant OP_LIST => B::opnumber("list"); # MUST FIX CONSTANTS.
-use constant OPf_PARENS => 8; # *MUST* *FIX* *CONSTANTS*.
+use constant OPf_PARENS => 8; # *MUST* *FIX* *CONSTANTS*.
use constant OPf_KIDS => 4;
# This is where we implement op.c in Perl. Sssh.
@@ -118,17 +118,16 @@
1;
__END__
-# Below is stub documentation for your module. You better edit it!
=head1 NAME
-B::Generate - Create your own op trees.
+B::Generate - Create your own op trees.
=head1 SYNOPSIS
use B::Generate;
# Do nothing, slowly.
- CHECK {
+ CHECK {
my $null = new B::OP("null",0);
my $enter = new B::OP("enter",0);
my $cop = new B::COP(0, "hiya", 0);
@@ -143,7 +142,7 @@
# Tell Perl where to find our tree.
B::main_root($leave);
B::main_start($enter);
- }
+ }
=head1 WARNING
@@ -267,7 +266,12 @@
module. To find someone to actually maintain this, please try
contacting perl5-porters.
-Josh Jore, Michael Schwern, Jim Cromie, Scott Walters.
+Josh Jore, Michael Schwern, Jim Cromie, Scott Walters, Reini Urban,
+Anton Berezin, Dmitry Karasik.
+
+Maintainership permissions do have:
+Artur Bergman, Chia-liang Kao, Anton Berezin, Jim Cromie, Joshua ben Jore,
+Michael G Schwern, Matt S Trout, Reini Urban, Scott Walters.
=head1 LICENSE
Modified: B-Generate/trunk/lib/B/Generate.xs
==============================================================================
--- B-Generate/trunk/lib/B/Generate.xs (original)
+++ B-Generate/trunk/lib/B/Generate.xs Sat Aug 16 11:31:11 2008
@@ -5,6 +5,7 @@
#include "perlapi.h"
#include "XSUB.h"
+
#ifdef PERL_OBJECT
#undef PL_op_name
#undef PL_opargs
@@ -14,6 +15,14 @@
#define PL_op_desc (get_op_descs())
#endif
+#ifdef PERL_CUSTOM_OPS
+#define OP_CUSTOM_OPS \
+ if (typenum == OP_CUSTOM) \
+ o->op_ppaddr = custom_op_ppaddr(SvPV_nolen(type));
+#else
+#define OP_CUSTOM_OPS
+#endif
+
static char *svclassnames[] = {
"B::NULL",
"B::IV",
@@ -69,6 +78,12 @@
static SV *specialsv_list[6];
+AV * tmp_comppad, * tmp_comppad_name;
+I32 tmp_padix, tmp_reset_pending;
+OP * tmp_op;
+
+CV * my_curr_cv = NULL;
+
SV** my_current_pad;
SV** tmp_pad;
@@ -79,13 +94,40 @@
/* #define GEN_PAD */
/* #define OLD_PAD */
+#define SAVE_VARS \
+{ \
+ tmp_comppad = PL_comppad; \
+ tmp_comppad_name = PL_comppad_name; \
+ tmp_padix = PL_padix; \
+ tmp_reset_pending = PL_pad_reset_pending; \
+ tmp_pad = PL_curpad; \
+ tmp_op = PL_op; \
+ if ( my_curr_cv) { \
+ PL_comppad = (AV*) AvARRAY(CvPADLIST(my_curr_cv))[1]; \
+ PL_comppad_name = (AV*) AvARRAY(CvPADLIST(my_curr_cv))[0]; \
+ PL_padix = AvFILLp(PL_comppad_name); \
+ PL_pad_reset_pending = 0; \
+ } \
+ PL_curpad = AvARRAY(PL_comppad); \
+}
+
+#define RESTORE_VARS \
+{ \
+ PL_op = tmp_op; \
+ PL_comppad = tmp_comppad; \
+ PL_curpad = tmp_pad; \
+ PL_padix = tmp_padix; \
+ PL_comppad_name = tmp_comppad_name; \
+ PL_pad_reset_pending = tmp_reset_pending; \
+}
+
void
set_active_sub(SV *sv)
{
AV* padlist;
SV** svp;
/* dTHX; */
- // sv_dump(SvRV(sv));
+ /* sv_dump(SvRV(sv)); */
padlist = CvPADLIST(SvRV(sv));
if(!padlist) {
dTHX;
@@ -101,12 +143,11 @@
dTHX;
OP* root = o;
SV* key;
- SV* val;
HE* cached;
if(PL_compcv && SvTYPE(PL_compcv) == SVt_PVCV &&
!PL_eval_root) {
- // printf("Compcv\n");
+ /* printf("Compcv\n"); */
if(SvROK(PL_compcv))
sv_dump(SvRV(PL_compcv));
return newRV((SV*)PL_compcv);
@@ -123,6 +164,7 @@
cached = hv_fetch_ent(root_cache, key, 0, 0);
if(cached) {
+ SvREFCNT_dec(key);
return HeVAL(cached);
}
@@ -176,6 +218,7 @@
cached = hv_store_ent(root_cache, key, newRV((SV*)cv), 0);
}
+ SvREFCNT_dec(key);
return (SV*) HeVAL(cached);
}
@@ -260,7 +303,7 @@
(void)hv_iterinit(PL_custom_op_names);
while ((ent = hv_iternext(PL_custom_op_names))) {
if (strEQ(SvPV_nolen(hv_iterval(PL_custom_op_names,ent)),name))
- return (void*)SvIV(hv_iterkeysv(ent));
+ return INT2PTR(void*,SvIV(hv_iterkeysv(ent)));
}
return 0;
@@ -272,7 +315,7 @@
{
if (!o)
return OPc_NULL;
- // op_dump(o);
+ /* op_dump(o); */
if (o->op_type == 0)
return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
@@ -400,7 +443,7 @@
{
OP *o;
SV *result;
-
+ SAVE_VARS;
SV **sparepad = PL_curpad;
PL_curpad = AvARRAY(PL_comppad);
OP *saveop = PL_op;
@@ -416,14 +459,10 @@
sv = newSVsv(sv); // copy it unless it's cv
}
o = newSVOP(typenum, flags, SvREFCNT_inc(sv));
-#ifdef PERL_CUSTOM_OPS
- if (typenum == OP_CUSTOM)
- o->op_ppaddr = custom_op_ppaddr(SvPV_nolen(type));
-#endif
- //PL_curpad = sparepad;
+ OP_CUSTOM_OPS;
+ RESTORE_VARS;
result = sv_newmortal();
sv_setiv(newSVrv(result, "B::SVOP"), PTR2IV(o));
- PL_op = saveop;
return result;
}
@@ -499,6 +538,31 @@
OUTPUT:
RETVAL
+SV *
+B_cv_pad(...)
+ CV * old_cv = NO_INIT
+ PROTOTYPE: ;$
+ CODE:
+ old_cv = my_curr_cv;
+ if (items > 0) {
+ if (SvROK(ST(0))) {
+ IV tmp;
+ if (!sv_derived_from(ST(0), "B::CV"))
+ Perl_croak(aTHX_ "Reference is not a B::CV object");
+ tmp = SvIV((SV*)SvRV(ST(0)));
+ my_curr_cv = INT2PTR(CV*,tmp);
+ } else {
+ my_curr_cv = NULL;
+ }
+ }
+
+ if ( old_cv) {
+ ST(0) = sv_newmortal();
+ sv_setiv(newSVrv(ST(0), "B::CV"), PTR2IV(old_cv));
+ } else {
+ ST(0) = &PL_sv_undef;
+ }
+
#define OP_desc(o) PL_op_desc[o->op_type]
MODULE = B::Generate PACKAGE = B::OP PREFIX = OP_
@@ -536,7 +600,7 @@
B::OP o
CODE:
if (items > 1)
- o->op_ppaddr = (void*)SvIV(ST(1));
+ o->op_ppaddr = INT2PTR(void*,SvIV(ST(1)));
RETVAL = PTR2IV((void*)(o->op_ppaddr));
OUTPUT:
RETVAL
@@ -561,13 +625,13 @@
I32 old_comppad_name_fill = PL_comppad_name_fill;
I32 old_min_intro_pending = PL_min_intro_pending;
I32 old_max_intro_pending = PL_max_intro_pending;
- // int old_cv_has_eval = PL_cv_has_eval;
+ /* int old_cv_has_eval = PL_cv_has_eval; */
I32 old_pad_reset_pending = PL_pad_reset_pending;
SV **old_curpad = PL_curpad;
AV *old_comppad = PL_comppad;
AV *old_comppad_name = PL_comppad_name;
- // PTR2UV
+ /* PTR2UV */
PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
@@ -575,10 +639,12 @@
PL_padix = AvFILLp(PL_comppad_name);
PL_pad_reset_pending = 0;
- // <medwards> PL_comppad_name_fill appears irrelevant as long as you stick to pad_alloc, pad_swipe, pad_free.
- // PL_comppad_name_fill = 0;
- // PL_min_intro_pending = 0;
- // PL_cv_has_eval = 0;
+ /* <medwards> PL_comppad_name_fill appears irrelevant as long as you
+ stick to pad_alloc, pad_swipe, pad_free.
+ * PL_comppad_name_fill = 0;
+ * PL_min_intro_pending = 0;
+ * PL_cv_has_eval = 0;
+ */
o->op_targ = Perl_pad_alloc(aTHX_ 0, SVs_PADTMP);
@@ -586,7 +652,7 @@
PL_comppad_name_fill = old_comppad_name_fill;
PL_min_intro_pending = old_min_intro_pending;
PL_max_intro_pending = old_max_intro_pending;
- // PL_cv_has_eval = old_cv_has_eval;
+ /* PL_cv_has_eval = old_cv_has_eval; */
PL_pad_reset_pending = old_pad_reset_pending;
PL_curpad = old_curpad;
PL_comppad = old_comppad;
@@ -663,23 +729,18 @@
SV * class
SV * type
I32 flags
- SV** sparepad = NO_INIT
OP *o = NO_INIT
- OP *saveop = NO_INIT
I32 typenum = NO_INIT
CODE:
- sparepad = PL_curpad;
- saveop = PL_op;
- PL_curpad = AvARRAY(PL_comppad);
+ SAVE_VARS;
typenum = op_name_to_num(type);
o = newOP(typenum, flags);
#ifdef PERL_CUSTOM_OPS
if (typenum == OP_CUSTOM)
o->op_ppaddr = custom_op_ppaddr(SvPV_nolen(type));
#endif
- PL_curpad = sparepad;
- PL_op = saveop;
- ST(0) = sv_newmortal();
+ RESTORE_VARS;
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::OP"), PTR2IV(o));
void
@@ -688,17 +749,12 @@
I32 flags
char * label
B::OP oldo
- SV** sparepad = NO_INIT
OP *o = NO_INIT
- OP *saveop = NO_INIT
CODE:
- sparepad = PL_curpad;
- saveop = PL_op;
- PL_curpad = AvARRAY(PL_comppad);
+ SAVE_VARS;
o = newSTATEOP(flags, label, oldo);
- PL_curpad = sparepad;
- PL_op = saveop;
- ST(0) = sv_newmortal();
+ RESTORE_VARS;
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::LISTOP"), PTR2IV(o));
B::OP
@@ -778,20 +834,17 @@
first = Nullop;
{
I32 padflag = 0;
- SV**sparepad = PL_curpad;
- OP* saveop = PL_op;
- PL_curpad = AvARRAY(PL_comppad);
+ SAVE_VARS;
typenum = op_name_to_num(type);
o = newUNOP(typenum, flags, first);
#ifdef PERL_CUSTOM_OPS
if (typenum == OP_CUSTOM)
o->op_ppaddr = custom_op_ppaddr(SvPV_nolen(type));
#endif
- PL_curpad = sparepad;
- PL_op = saveop;
+ RESTORE_VARS;
}
- ST(0) = sv_newmortal();
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::UNOP"), PTR2IV(o));
MODULE = B::Generate PACKAGE = B::BINOP PREFIX = BINOP_
@@ -850,12 +903,10 @@
last = Nullop;
{
- SV**sparepad = PL_curpad;
- OP* saveop = PL_op;
I32 typenum = op_name_to_num(type);
- PL_curpad = AvARRAY(PL_comppad);
-
+ SAVE_VARS;
+
if (typenum == OP_SASSIGN || typenum == OP_AASSIGN)
o = newASSIGNOP(flags, first, 0, last);
else {
@@ -866,10 +917,9 @@
#endif
}
- PL_curpad = sparepad;
- PL_op = saveop;
+ RESTORE_VARS;
}
- ST(0) = sv_newmortal();
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::BINOP"), PTR2IV(o));
MODULE = B::Generate PACKAGE = B::LISTOP PREFIX = LISTOP_
@@ -912,20 +962,17 @@
last = Nullop;
{
- SV**sparepad = PL_curpad;
- OP* saveop = PL_op;
I32 typenum = op_name_to_num(type);
- PL_curpad = AvARRAY(PL_comppad);
+ SAVE_VARS;
o = newLISTOP(typenum, flags, first, last);
#ifdef PERL_CUSTOM_OPS
if (typenum == OP_CUSTOM)
o->op_ppaddr = custom_op_ppaddr(SvPV_nolen(type));
#endif
- PL_curpad = sparepad;
- PL_op = saveop;
+ RESTORE_VARS;
}
- ST(0) = sv_newmortal();
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::LISTOP"), PTR2IV(o));
MODULE = B::Generate PACKAGE = B::LOGOP PREFIX = LOGOP_
@@ -968,19 +1015,16 @@
last = Nullop;
{
- SV**sparepad = PL_curpad;
- OP* saveop = PL_op;
I32 typenum = op_name_to_num(type);
- PL_curpad = AvARRAY(PL_comppad);
+ SAVE_VARS;
o = newLOGOP(typenum, flags, first, last);
#ifdef PERL_CUSTOM_OPS
if (typenum == OP_CUSTOM)
o->op_ppaddr = custom_op_ppaddr(SvPV_nolen(type));
#endif
- PL_curpad = sparepad;
- PL_op = saveop;
+ RESTORE_VARS;
}
- ST(0) = sv_newmortal();
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::LOGOP"), PTR2IV(o));
void
@@ -1035,14 +1079,11 @@
elseo = Nullop;
{
- SV**sparepad = PL_curpad;
- OP* saveop = PL_op;
- PL_curpad = AvARRAY(PL_comppad);
+ SAVE_VARS;
o = newCONDOP(flags, first, last, elseo);
- PL_curpad = sparepad;
- PL_op = saveop;
+ RESTORE_VARS;
}
- ST(0) = sv_newmortal();
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::LOGOP"), PTR2IV(o));
B::OP
@@ -1165,7 +1206,30 @@
SVOP_gv(o)
B::SVOP o
-void
+#define NEW_SVOP(OP_class,B_class) \
+{ \
+ OP *o; \
+ SV* param; \
+ I32 typenum; \
+ SAVE_VARS; \
+ typenum = op_name_to_num(type); /* XXX More classes here! */ \
+ if (typenum == OP_GVSV) { \
+ if (*(SvPV_nolen(sv)) == '$') \
+ param = (SV*)gv_fetchpv(SvPVX(sv)+1, TRUE, SVt_PV); \
+ else \
+ Perl_croak(aTHX_ \
+ "First character to GVSV was not dollar"); \
+ } else \
+ param = newSVsv(sv); \
+ o = OP_class(typenum, flags, param); \
+ OP_CUSTOM_OPS \
+ RESTORE_VARS; \
+ ST(0) = sv_newmortal(); \
+ sv_setiv(newSVrv(ST(0), B_class), PTR2IV(o)); \
+}
+
+
+SV*
SVOP_new_svrv(class, type, flags, sv)
SV * class
SV * type
@@ -1181,9 +1245,8 @@
SV * type
I32 flags
SV * sv
- CODE:
- ST(0) = __svop_new(aTHX_ class, type, flags, sv);
-
+ CODE:
+ NEW_SVOP(newSVOP, "B::SVOP");
#define PADOP_padix(o) o->op_padix
@@ -1192,6 +1255,21 @@
&& SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \
? (GV*)PL_curpad[o->op_padix] : Nullgv)
+MODULE = B::Generate PACKAGE = B::GVOP PREFIX = GVOP_
+
+SV *
+GVOP_new(class, type, flags, sv)
+ SV * class
+ SV * type
+ I32 flags
+ SV * sv
+ CODE:
+#ifdef USE_ITHREADS
+ NEW_SVOP(newPADOP, "B::PADOP");
+#else
+ NEW_SVOP(newSVOP, "B::SVOP");
+#endif
+
MODULE = B::Generate PACKAGE = B::PADOP PREFIX = PADOP_
PADOFFSET
@@ -1257,7 +1335,9 @@
OUTPUT:
RETVAL
+#if PERL_VERSION < 11
#define COP_label(o) o->cop_label
+#endif
#define COP_stashpv(o) CopSTASHPV(o)
#define COP_stash(o) CopSTASH(o)
#define COP_file(o) CopFILE(o)
@@ -1271,10 +1351,14 @@
MODULE = B::Generate PACKAGE = B::COP PREFIX = COP_
+#if PERL_VERSION < 11
+
char *
COP_label(o)
B::COP o
+#endif
+
char *
COP_stashpv(o)
B::COP o
@@ -1353,6 +1437,10 @@
=cut
+#ifndef CopLABEL_alloc
+#define CopLABEL_alloc(x) Perl_savepv(aTHX_ x)
+#endif
+
B::COP
COP_new(class, flags, name, sv_first)
SV * class
@@ -1377,14 +1465,21 @@
first = Nullop;
{
- SV**sparepad = PL_curpad;
- OP* saveop = PL_op;
- PL_curpad = AvARRAY(PL_comppad);
- o = newSTATEOP(flags, name, first);
- PL_curpad = sparepad;
- PL_op = saveop;
+#if PERL_VERSION >= 10
+ yy_parser* saveparser = PL_parser, dummyparser;
+ if ( PL_parser == NULL) {
+ PL_parser = &dummyparser;
+ PL_parser-> copline = NOLINE;
}
- ST(0) = sv_newmortal();
+#endif
+ SAVE_VARS;
+ o = newSTATEOP(flags, CopLABEL_alloc(name), first);
+ RESTORE_VARS;
+#if PERL_VERSION >= 10
+ PL_parser = saveparser;
+#endif
+ }
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), "B::COP"), PTR2IV(o));
MODULE = B::Generate PACKAGE = B::SV PREFIX = Sv
@@ -1442,7 +1537,8 @@
RETVAL = mycv;
OUTPUT:
RETVAL
-
+
+
MODULE = B::Generate PACKAGE = B::PV PREFIX = Sv
Modified: B-Generate/trunk/t/inspect-btest.t
==============================================================================
--- B-Generate/trunk/t/inspect-btest.t (original)
+++ B-Generate/trunk/t/inspect-btest.t Sat Aug 16 11:31:11 2008
@@ -1,6 +1,6 @@
#!perl
-use Test::More tests => 30;
+use Test::More tests => 31;
use_ok 'B';
use_ok 'B::Generate';
Modified: B-Generate/trunk/t/inspect-this.t
==============================================================================
--- B-Generate/trunk/t/inspect-this.t (original)
+++ B-Generate/trunk/t/inspect-this.t Sat Aug 16 11:31:11 2008
@@ -1,6 +1,6 @@
#!perl
-use Test::More tests => 655;
+use Test::More tests => $] < 5.010 ? 658 : 648; # skip PV->LEN tests on 5.10
use_ok 'B';
#use_ok 'B::Generate'; # cannot use here, due to clash with B::Concise
Modified: B-Generate/trunk/t/op_list.t
==============================================================================
--- B-Generate/trunk/t/op_list.t (original)
+++ B-Generate/trunk/t/op_list.t Sat Aug 16 11:31:11 2008
@@ -14,6 +14,14 @@
145 => "5.011000",
142 => "5.010000",
141 => "5.008008", # probably should be 5.008(00[12])?
+ 141 => "5.008007",
+ 141 => "5.008006",
+ 141 => "5.008005",
+ 141 => "5.008004",
+ 141 => "5.008003",
+ 141 => "5.008002",
+ 141 => "5.008001",
+ 141 => "5.008000",
);
my $got = B::opnumber("list");
More information about the Jifty-commit
mailing list