Perl · syberrus · Jul 24, 2014
diff --git a/AUTHORS b/AUTHORS
@@ -886,6 +886,7 @@ Offer Kaye			<offer.kaye@gmail.com>
 Olaf Flebbe			<o.flebbe@science-computing.de>
 Olaf Titz			<olaf@bigred.inka.de>
 Oleg Nesterov			<oleg@redhat.com>
+Oleg Pronin			<syber@crazypanda.ru>
 Olivier Blin			<blino@mandriva.com>
 Olli Savia
 Ollivier Robert			<roberto@keltia.freenix.fr>

diff --git a/MANIFEST b/MANIFEST
@@ -3884,6 +3884,7 @@ haiku/Haiku/Haiku.xs		Haiku extension external subroutines
 haiku/haikuish.h		Header for the Haiku port
 haiku/Haiku/Makefile.PL		Haiku extension makefile writer
 handy.h				Handy definitions
+hashmap.h			Hashmap implementation
 hints/aix_3.sh			Hints for named architecture
 hints/aix_4.sh			Hints for named architecture
 hints/aix.sh			Hints for named architecture

diff --git a/dump.c b/dump.c
@@ -1084,6 +1084,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
     case OP_CONST:
     case OP_HINTSEVAL:
     case OP_METHOD_NAMED:
+    case OP_METHOD_SUPER:
+    case OP_METHOD_REDIR:
 #ifndef USE_ITHREADS
 	/* with ITHREADS, consts are stored in the pad, and the right pad
 	 * may not be active here, so skip */
@@ -1776,9 +1778,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	    if (SvMAGIC(sv))
 		do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
 	}
-	if (SvSTASH(sv))
+	if (SvSTASH(sv) && !(type == SVt_PVHV && HvNAME(sv))) /* dont dump stash on stashes (they have destructor CV* addr there) */
 	    do_hv_dump(level, file, "  STASH", SvSTASH(sv));
-
 	if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
 	    Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
 	}
@@ -2495,7 +2496,6 @@ Perl_debprofdump(pTHX)
     }
 }
 
-
 /*
  * Local variables:
  * c-indentation-style: bsd

diff --git a/embed.fnc b/embed.fnc
@@ -511,6 +511,7 @@ Apd	|GV*	|gv_fetchmeth_pv	|NULLOK HV* stash|NN const char* name \
                                         |I32 level|U32 flags
 Apd	|GV*	|gv_fetchmeth_pvn	|NULLOK HV* stash|NN const char* name \
                                         |STRLEN len|I32 level|U32 flags
+Apd	|GV*	|gv_fetchmeth_ent	|NULLOK HV* stash|NN const SVMAP_ENT* entry|I32 level|U32 flags
 Amd	|GV*	|gv_fetchmeth_autoload	|NULLOK HV* stash \
 					|NN const char* name|STRLEN len \
 					|I32 level
@@ -525,8 +526,8 @@ Apd	|GV*	|gv_fetchmethod_autoload|NN HV* stash|NN const char* name \
 ApM	|GV*	|gv_fetchmethod_sv_flags|NN HV* stash|NN SV* namesv|U32 flags
 ApM	|GV*	|gv_fetchmethod_pv_flags|NN HV* stash|NN const char* name \
  				|U32 flags
-ApM	|GV*	|gv_fetchmethod_pvn_flags|NN HV* stash|NN const char* name \
-				|const STRLEN len|U32 flags
+ApM	|GV*	|gv_fetchmethod_pvn_flags|NN HV* stash|NN const char* name|STRLEN len|U32 flags
+ApM |GV*    |gv_fetchmethod_ent|NN HV* stash|NN const SVMAP_ENT* entry|U32 flags
 Ap	|GV*	|gv_fetchpv	|NN const char *nambeg|I32 add|const svtype sv_type
 Ap	|void	|gv_fullname	|NN SV* sv|NN const GV* gv
 Apmb	|void	|gv_fullname3	|NN SV* sv|NN const GV* gv|NULLOK const char* prefix
@@ -547,8 +548,16 @@ px	|GV *	|gv_override	|NN const char * const name \
 				|const STRLEN len
 XMpd	|void	|gv_try_downgrade|NN GV* gv
 Apd	|HV*	|gv_stashpv	|NN const char* name|I32 flags
-Apd	|HV*	|gv_stashpvn	|NN const char* name|U32 namelen|I32 flags
+Apd	|HV*	|gv_stashpvn	|NN const char* name|STRLEN namelen|I32 flags
+Apd	|HV*	|gv_stashent	|NN const SVMAP_ENT* entry|I32 flags
+Apd |void   |gv_stashpvn_cache_invalidate    |NN const char* name|STRLEN namelen|I32 flags
+Apd |void   |gv_stashsv_cache_invalidate    |NN SV* sv
+Apd |void   |gv_stash_cache_invalidate
+Apd |void   |gv_stash_cache_init
+Apd |void   |gv_stash_cache_destroy
 Apd	|HV*	|gv_stashsv	|NN SV* sv|I32 flags
+Ap  |HV*    |curmethod_stash|NN SV** objptr|NULLOK CV* sub
+Ap  |HV*    |method_stash   |NN SV** objptr|NULLOK SV* meth
 Apd	|void	|hv_clear	|NULLOK HV *hv
 : used in SAVEHINTS() and op.c
 ApdR	|HV *	|hv_copy_hints_hv|NULLOK HV *const ohv
@@ -1017,6 +1026,8 @@ Apd	|SV*	|newSVrv	|NN SV *const rv|NULLOK const char *const classname
 Apda	|SV*	|newSVsv	|NULLOK SV *const old
 Apda	|SV*	|newSV_type	|const svtype type
 Apda	|OP*	|newUNOP	|I32 type|I32 flags|NULLOK OP* first
+Apda    |OP*    |newMETHOP  |I32 type|I32 flags|NULLOK OP* dynamic_meth
+Apda    |OP*    |newMETHOPnamed|I32 type|I32 flags|NN SV* const_meth
 Apda	|OP*	|newWHENOP	|NULLOK OP* cond|NN OP* block
 Apda	|OP*	|newWHILEOP	|I32 flags|I32 debuggable|NULLOK LOOP* loop \
 				|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
@@ -2041,7 +2052,7 @@ s	|OP*	|do_smartmatch	|NULLOK HV* seen_this \
 
 #if defined(PERL_IN_PP_HOT_C)
 s	|void	|do_oddball	|NN SV **oddkey|NN SV **firstkey
-sR	|SV*	|method_common	|NN SV* meth|NULLOK U32* hashp
+sR	|HV*	|opmethod_stash	|NN METHOP* op|NN SV* meth
 #endif
 
 #if defined(PERL_IN_PP_SORT_C)
@@ -2598,6 +2609,7 @@ sMd	|SV*	|find_uninit_var|NULLOK const OP *const obase \
 		|NULLOK const SV *const uninit_sv|bool top
 #endif
 
+Ap	|HV*	|gv_stashof_pvn|NN const char *name|STRLEN len|I32 flags|const svtype sv_type|NULLOK const char** name_ret|NULLOK STRLEN *len_ret|NULLOK GV** gv_ret
 Ap	|GV*	|gv_fetchpvn_flags|NN const char* name|STRLEN len|I32 flags|const svtype sv_type
 Ap	|GV*	|gv_fetchsv|NN SV *name|I32 flags|const svtype sv_type
 
@@ -2696,6 +2708,7 @@ s	|void	|mro_gather_and_rename|NN HV * const stashes \
 pd	|void   |mro_isa_changed_in|NN HV* stash
 Apd	|void	|mro_method_changed_in	|NN HV* stash
 pdx	|void	|mro_package_moved	|NULLOK HV * const stash|NULLOK HV * const oldstash|NN const GV * const gv|U32 flags
+Ap  |void   |mro_global_method_cache_clear
 : Only used in perl.c
 p	|void   |boot_core_mro
 Apon	|void	|sys_init	|NN int* argc|NN char*** argv

diff --git a/embed.h b/embed.h
@@ -95,6 +95,7 @@
 #define croak_no_modify		Perl_croak_no_modify
 #define croak_sv(a)		Perl_croak_sv(aTHX_ a)
 #define croak_xs_usage		Perl_croak_xs_usage
+#define curmethod_stash(a,b)	Perl_curmethod_stash(aTHX_ a,b)
 #define custom_op_desc(a)	Perl_custom_op_desc(aTHX_ a)
 #define custom_op_name(a)	Perl_custom_op_name(aTHX_ a)
 #define cv_clone(a)		Perl_cv_clone(aTHX_ a)
@@ -188,13 +189,15 @@
 #define gv_efullname4(a,b,c,d)	Perl_gv_efullname4(aTHX_ a,b,c,d)
 #define gv_fetchfile(a)		Perl_gv_fetchfile(aTHX_ a)
 #define gv_fetchfile_flags(a,b,c)	Perl_gv_fetchfile_flags(aTHX_ a,b,c)
+#define gv_fetchmeth_ent(a,b,c,d)	Perl_gv_fetchmeth_ent(aTHX_ a,b,c,d)
 #define gv_fetchmeth_pv(a,b,c,d)	Perl_gv_fetchmeth_pv(aTHX_ a,b,c,d)
 #define gv_fetchmeth_pv_autoload(a,b,c,d)	Perl_gv_fetchmeth_pv_autoload(aTHX_ a,b,c,d)
 #define gv_fetchmeth_pvn(a,b,c,d,e)	Perl_gv_fetchmeth_pvn(aTHX_ a,b,c,d,e)
 #define gv_fetchmeth_pvn_autoload(a,b,c,d,e)	Perl_gv_fetchmeth_pvn_autoload(aTHX_ a,b,c,d,e)
 #define gv_fetchmeth_sv(a,b,c,d)	Perl_gv_fetchmeth_sv(aTHX_ a,b,c,d)
 #define gv_fetchmeth_sv_autoload(a,b,c,d)	Perl_gv_fetchmeth_sv_autoload(aTHX_ a,b,c,d)
 #define gv_fetchmethod_autoload(a,b,c)	Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
+#define gv_fetchmethod_ent(a,b,c)	Perl_gv_fetchmethod_ent(aTHX_ a,b,c)
 #define gv_fetchmethod_pv_flags(a,b,c)	Perl_gv_fetchmethod_pv_flags(aTHX_ a,b,c)
 #define gv_fetchmethod_pvn_flags(a,b,c,d)	Perl_gv_fetchmethod_pvn_flags(aTHX_ a,b,c,d)
 #define gv_fetchmethod_sv_flags(a,b,c)	Perl_gv_fetchmethod_sv_flags(aTHX_ a,b,c)
@@ -208,9 +211,16 @@
 #define gv_init_pvn(a,b,c,d,e)	Perl_gv_init_pvn(aTHX_ a,b,c,d,e)
 #define gv_init_sv(a,b,c,d)	Perl_gv_init_sv(aTHX_ a,b,c,d)
 #define gv_name_set(a,b,c,d)	Perl_gv_name_set(aTHX_ a,b,c,d)
+#define gv_stash_cache_destroy()	Perl_gv_stash_cache_destroy(aTHX)
+#define gv_stash_cache_init()	Perl_gv_stash_cache_init(aTHX)
+#define gv_stash_cache_invalidate()	Perl_gv_stash_cache_invalidate(aTHX)
+#define gv_stashent(a,b)	Perl_gv_stashent(aTHX_ a,b)
+#define gv_stashof_pvn(a,b,c,d,e,f,g)	Perl_gv_stashof_pvn(aTHX_ a,b,c,d,e,f,g)
 #define gv_stashpv(a,b)		Perl_gv_stashpv(aTHX_ a,b)
 #define gv_stashpvn(a,b,c)	Perl_gv_stashpvn(aTHX_ a,b,c)
+#define gv_stashpvn_cache_invalidate(a,b,c)	Perl_gv_stashpvn_cache_invalidate(aTHX_ a,b,c)
 #define gv_stashsv(a,b)		Perl_gv_stashsv(aTHX_ a,b)
+#define gv_stashsv_cache_invalidate(a)	Perl_gv_stashsv_cache_invalidate(aTHX_ a)
 #define hv_clear(a)		Perl_hv_clear(aTHX_ a)
 #define hv_clear_placeholders(a)	Perl_hv_clear_placeholders(aTHX_ a)
 #define hv_common(a,b,c,d,e,f,g,h)	Perl_hv_common(aTHX_ a,b,c,d,e,f,g,h)
@@ -317,6 +327,7 @@
 #define mess			Perl_mess
 #endif
 #define mess_sv(a,b)		Perl_mess_sv(aTHX_ a,b)
+#define method_stash(a,b)	Perl_method_stash(aTHX_ a,b)
 #define mg_clear(a)		Perl_mg_clear(aTHX_ a)
 #define mg_copy(a,b,c,d)	Perl_mg_copy(aTHX_ a,b,c,d)
 #define mg_find			Perl_mg_find
@@ -331,6 +342,7 @@
 #define mini_mktime		Perl_mini_mktime
 #define moreswitches(a)		Perl_moreswitches(aTHX_ a)
 #define mro_get_linear_isa(a)	Perl_mro_get_linear_isa(aTHX_ a)
+#define mro_global_method_cache_clear()	Perl_mro_global_method_cache_clear(aTHX)
 #define mro_method_changed_in(a)	Perl_mro_method_changed_in(aTHX_ a)
 #define my_atof(a)		Perl_my_atof(aTHX_ a)
 #define my_atof2(a,b)		Perl_my_atof2(aTHX_ a,b)
@@ -367,6 +379,8 @@
 #define newLOGOP(a,b,c,d)	Perl_newLOGOP(aTHX_ a,b,c,d)
 #define newLOOPEX(a,b)		Perl_newLOOPEX(aTHX_ a,b)
 #define newLOOPOP(a,b,c,d)	Perl_newLOOPOP(aTHX_ a,b,c,d)
+#define newMETHOP(a,b,c)	Perl_newMETHOP(aTHX_ a,b,c)
+#define newMETHOPnamed(a,b,c)	Perl_newMETHOPnamed(aTHX_ a,b,c)
 #define newMYSUB(a,b,c,d,e)	Perl_newMYSUB(aTHX_ a,b,c,d,e)
 #define newNULLLIST()		Perl_newNULLLIST(aTHX)
 #define newOP(a,b)		Perl_newOP(aTHX_ a,b)
@@ -1585,7 +1599,7 @@
 #  endif
 #  if defined(PERL_IN_PP_HOT_C)
 #define do_oddball(a,b)		S_do_oddball(aTHX_ a,b)
-#define method_common(a,b)	S_method_common(aTHX_ a,b)
+#define opmethod_stash(a,b)	S_opmethod_stash(aTHX_ a,b)
 #  endif
 #  if defined(PERL_IN_PP_PACK_C)
 #define bytes_to_uni		S_bytes_to_uni

diff --git a/embedvar.h b/embedvar.h
@@ -192,6 +192,7 @@
 #define PL_maxsysfd		(vTHX->Imaxsysfd)
 #define PL_memory_debug_header	(vTHX->Imemory_debug_header)
 #define PL_mess_sv		(vTHX->Imess_sv)
+#define PL_methstash		(vTHX->Imethstash)
 #define PL_min_intro_pending	(vTHX->Imin_intro_pending)
 #define PL_minus_E		(vTHX->Iminus_E)
 #define PL_minus_F		(vTHX->Iminus_F)

diff --git a/ext/B/B.xs b/ext/B/B.xs
@@ -1259,6 +1259,38 @@ oplist(o)
 	SP = oplist(aTHX_ o, SP);
 
 
+MODULE = B	PACKAGE = B::SVOP
+
+void
+class_sv (o)
+	B::SVOP	o
+ALIAS:
+	rclass_sv   = 1
+	class_targ  = 2
+	rclass_targ = 3
+PPCODE:
+	SV* sv;
+	if (o->op_type != OP_METHOD && o->op_type != OP_METHOD_NAMED && o->op_type != OP_METHOD_SUPER &&
+	    o->op_type != OP_METHOD_REDIR)
+		croak("B::SVOP::const_* : wrong op_type");
+	switch (ix) {
+		case 0:
+			if (!cMETHOPx(o)->op_class_hash) XSRETURN_UNDEF;
+			sv = cMETHOPx(o)->op_class_sv;
+			break;
+		case 1:
+			if (o->op_type != OP_METHOD_REDIR) croak("B::SVOP::const_rclass: wrong op_type");
+			sv = cMETHOPx(o)->op_rclass_sv;
+			break;
+		case 2:
+			XSRETURN_UV(cMETHOPx(o)->op_class_targ);
+		case 3:
+			XSRETURN_UV(cMETHOPx(o)->op_rclass_targ);
+	}
+	ST(0) = make_sv_object(aTHX_ sv);
+	XSRETURN(1);
+
+
 MODULE = B	PACKAGE = B::SV
 
 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
-our $VERSION   = "0.992";
+our $VERSION   = "0.993";
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
 		     concise_subref concise_cv concise_main
@@ -659,6 +659,7 @@ $priv{$_}{128} = "+1" for qw(caller wantarray runcv);
 @{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK);
 $priv{$_}{128} = "UTF" for qw(last redo next goto dump);
 $priv{split}{128} = "IMPLIM";
+$priv{method_redir}{1} = "SUPER";
 
 our %hints; # used to display each COP's op_hints values
 
@@ -892,7 +893,7 @@ sub concise_op {
     elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
 	unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
 	    my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
-	    my $preferpv = $h{name} eq "method_named";
+	    my $preferpv = ($h{name} =~ /^method_/) ? 1 : 0;
 	    if ($h{class} eq "PADOP" or !${$op->sv}) {
 		my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
 		$h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";

diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
@@ -176,6 +176,7 @@ my $testpkgs = {
 		     OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
 		     OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
 		     $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (),
+		     $] >= 5.020 ? qw(OPpMETHOD_SUPER) : (),
 		    'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
 		    ],
 		 },

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
@@ -6,7 +6,7 @@ use strict;
 
 our($VERSION, @ISA, @EXPORT_OK);
 
-$VERSION = "1.27";
+$VERSION = "1.28";
 
 use Carp;
 use Exporter ();
@@ -339,7 +339,8 @@ invert_opset function.
 
     rv2cv anoncode prototype coreargs
 
-    entersub leavesub leavesublv return method method_named
+    entersub leavesub leavesublv return method method_named method_super
+    method_redir
      -- XXX loops via recursion?
 
     leaveeval -- needed for Safe to operate, is safe

diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs
@@ -312,13 +312,16 @@ PPCODE:
 
     /* Invalidate ISA and method caches */
     ++PL_sub_generation;
-    hv_clear(PL_stashcache);
+    gv_stash_cache_invalidate();
 
     PUSHMARK(SP);
     perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
     sv_free( (SV *) dummy_hv);  /* get rid of what save_hash gave us*/
     SPAGAIN; /* for the PUTBACK added by xsubpp */
     LEAVE;
+
+    ++PL_sub_generation;
+    gv_stash_cache_invalidate();
 
 
 int

diff --git a/ext/XS-APItest/t/gv_fetchmeth.t b/ext/XS-APItest/t/gv_fetchmeth.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 40;
+use Test::More tests => 36;
 
 use_ok('XS::APItest');
 
@@ -24,7 +24,8 @@ for my $type ( 0..3 ) {
     ok !$::{$meth}, "...and doesn't vivify the glob.";
 
     ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false.";
-    ok $::{$meth}, "...but does vivify the glob.";
+    # commented out - perl no longer stores it's method cache in stash's HV
+    #ok $::{$meth}, "...but does vivify the glob.";
 }
 
 {

diff --git a/ext/XS-APItest/t/gv_fetchmeth_autoload.t b/ext/XS-APItest/t/gv_fetchmeth_autoload.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 53;
+use Test::More tests => 49;
 
 use_ok('XS::APItest');
 
@@ -30,7 +30,8 @@ for my $type ( 0..3 ) {
     ok !$::{$meth}, "...and doesn't vivify the glob.";
 
     ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false.";
-    ok $::{$meth}, "...but does vivify the glob.";
+    # commented out - perl no longer stores it's method cache in stash's HV
+    #ok $::{$meth}, "...but does vivify the glob.";
 
     ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "$types[$type] fails when the glob doesn't exist and AUTOLOAD is undefined,";
     local *AUTOLOAD = sub { 1 };