re-enable (feature guarded) switch and re-enable smartmatch with a new feature guard

Also remove any deprecation warnings and corresponding documentation

Author: Tony Cook

MANIFEST

@@ -6131,6 +6131,8 @@ t/lib/feature/multidimensional		Tests for enabling/disabling $foo{$x, $y} => $fo
 t/lib/feature/nonesuch			Tests for enabling/disabling nonexistent feature
 t/lib/feature/removed			Tests for enabling/disabling removed feature
 t/lib/feature/say			Tests for enabling/disabling say feature
+t/lib/feature/smartmatch		Tests for enabling/disabling smartmatch feature
+t/lib/feature/switch			Tests for enabling/disabling switch feature
 t/lib/h2ph.h				Test header file for h2ph
 t/lib/h2ph.pht				Generated output from h2ph.h by h2ph, for comparison
 t/lib/locale/latin1			Part of locale.t in Latin 1
@@ -6432,6 +6434,7 @@ t/op/signatures.t			See if sub signatures work
 t/op/sigsystem.t			See if system and SIGCHLD handlers play together nicely
 t/op/sleep.t				See if sleep works
 t/op/smartkve.t				See if smart deref for keys/values/each works
+t/op/smartmatch.t			See if the ~~ operator works
 t/op/sort.t				See if sort works
 t/op/splice.t				See if splice works
 t/op/split.t				See if split works
@@ -6455,6 +6458,7 @@ t/op/substr_thr.t			See if substr works in another thread
 t/op/svflags.t				See if POK is set as expected.
 t/op/svleak.pl				Test file for svleak.t
 t/op/svleak.t				See if stuff leaks SVs
+t/op/switch.t				See if switches (given/when) work
 t/op/symbolcache.t			See if undef/delete works on stashes with functions
 t/op/sysio.t				See if sysread and syswrite work
 t/op/taint.t				See if tainting works

cop.h

@@ -1127,21 +1127,27 @@ struct context {
    and a static array of context names in pp_ctl.c  */
 #define CXTYPEMASK	0xf
 #define CXt_NULL	0 /* currently only used for sort BLOCK */
-#define CXt_BLOCK	1
+#define CXt_WHEN	1
+#define CXt_BLOCK	2
+/* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
+   jump table in pp_ctl.c
+   The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
+*/
+#define CXt_GIVEN	3
 
 /* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP,
  * CxFOREACH compare ranges */
-#define CXt_LOOP_ARY	2 /* for (@ary)     { ...; } */
-#define CXt_LOOP_LAZYSV	3 /* for ('a'..'z') { ...; } */
-#define CXt_LOOP_LAZYIV	4 /* for (1..9)     { ...; } */
-#define CXt_LOOP_LIST	5 /* for (1,2,3)    { ...; } */
-#define CXt_LOOP_PLAIN	6 /* while (...)    { ...; }
+#define CXt_LOOP_ARY	4 /* for (@ary)     { ...; } */
+#define CXt_LOOP_LAZYSV	5 /* for ('a'..'z') { ...; } */
+#define CXt_LOOP_LAZYIV	6 /* for (1..9)     { ...; } */
+#define CXt_LOOP_LIST	7 /* for (1,2,3)    { ...; } */
+#define CXt_LOOP_PLAIN	8 /* while (...)    { ...; }
                              or plain block { ...; } */
-#define CXt_SUB		7
-#define CXt_FORMAT      8
-#define CXt_EVAL        9 /* eval'', eval{}, try{} */
-#define CXt_SUBST      10
-#define CXt_DEFER      11
+#define CXt_SUB		9
+#define CXt_FORMAT     10
+#define CXt_EVAL       11 /* eval'', eval{}, try{} */
+#define CXt_SUBST      12
+#define CXt_DEFER      13
 /* SUBST doesn't feature in all switch statements.  */
 
 /* private flags for CXt_SUB and CXt_FORMAT */

dist/Safe/Safe.pm

@@ -3,7 +3,7 @@ package Safe;
 use 5.003_11;
 use Scalar::Util qw(reftype refaddr);
 
-$Safe::VERSION = "2.47";
+$Safe::VERSION = "2.46";
 
 # *** Don't declare any lexicals above this point ***
 #

dist/Safe/t/safeops.t

@@ -45,7 +45,7 @@ plan(tests => scalar @op + 3);
 sub testop {
     my ($op, $opname, $code) = @_;
     pass("$op : skipped") and return if $code =~ /^SKIP/;
-    pass("$op : skipped") and return if $code eq "//" && $] < 5.010;
+    pass("$op : skipped") and return if $code =~ m://|~~: && $] < 5.010;
     my $c = new Safe;
     $c->deny_only($op);
     $c->reval($code);
@@ -453,6 +453,7 @@ dor		$x // $y
 dorassign	$x //= $y
 once		SKIP {use feature 'state'; state $foo = 42;}
 say		SKIP {use feature 'say'; say "foo";}
+smartmatch	no warnings 'deprecated'; $x ~~ $y
 aeach		SKIP each @t
 akeys		SKIP keys @t
 avalues		SKIP values @t

dump.c

@@ -1448,6 +1448,8 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
     case OP_DORASSIGN:
     case OP_ANDASSIGN:
     case OP_ARGDEFELEM:
+    case OP_ENTERGIVEN:
+    case OP_ENTERWHEN:
     case OP_ENTERTRY:
     case OP_ONCE:
         S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");

embed.fnc

@@ -2213,6 +2213,9 @@ ARdp	|OP *	|newFOROP	|I32 flags				\
 				|NN OP *expr				\
 				|NULLOK OP *block			\
 				|NULLOK OP *cont
+ARdp	|OP *	|newGIVENOP	|NN OP *cond				\
+				|NN OP *block				\
+				|PADOFFSET defsv_off
 : Used in scope.c
 eopx	|GP *	|newGP		|NN GV * const gv
 Adm	|GV *	|newGVgen	|NN const char *pack
@@ -2357,6 +2360,8 @@ ERXopx	|char * |new_warnings_bitfield					\
 				|NULLOK char *buffer			\
 				|NN const char * const bits		\
 				|STRLEN size
+ARdp	|OP *	|newWHENOP	|NULLOK OP *cond			\
+				|NN OP *block
 ARdp	|OP *	|newWHILEOP	|I32 flags				\
 				|I32 debuggable 			\
 				|NULLOK LOOP *loop			\
@@ -4861,6 +4866,7 @@ RST	|bool	|is_handle_constructor					\
 Ti	|bool	|is_standard_filehandle_name				\
 				|NN const char *fhname
 S	|OP *	|listkids	|NULLOK OP *o
+S	|bool	|looks_like_bool|NN const OP *o
 S	|OP *	|modkids	|NULLOK OP *o				\
 				|I32 type
 S	|void	|move_proto_attr|NN OP **proto				\
@@ -4870,6 +4876,11 @@ S	|void	|move_proto_attr|NN OP **proto				\
 S	|OP *	|my_kid 	|NULLOK OP *o				\
 				|NULLOK OP *attrs			\
 				|NN OP **imopsp
+S	|OP *	|newGIVWHENOP	|NULLOK OP *cond			\
+				|NN OP *block				\
+				|I32 enter_opcode			\
+				|I32 leave_opcode			\
+				|PADOFFSET entertarg
 RS	|OP *	|new_logop	|I32 type				\
 				|I32 flags				\
 				|NN OP **firstp 			\
@@ -4893,6 +4904,8 @@ S	|bool	|process_special_blocks 				\
 				|NN const char * const fullname 	\
 				|NN GV * const gv			\
 				|NN CV * const cv
+S	|OP *	|ref_array_or_hash					\
+				|NULLOK OP *cond
 S	|OP *	|refkids	|NULLOK OP *o				\
 				|I32 type
 S	|OP *	|scalarboolean	|NN OP *o
@@ -5071,6 +5084,7 @@ p	|UV	|_to_upper_title_latin1 				\
 #if defined(PERL_IN_PP_CTL_C)
 RS	|PerlIO *|check_type_and_open					\
 				|NN SV *name
+S	|void	|destroy_matcher|NN PMOP *matcher
 RSd	|OP *	|docatch	|Perl_ppaddr_t firstpp
 S	|bool	|doeval_compile |U8 gimme				\
 				|NULLOK CV *outside			\
@@ -5084,12 +5098,21 @@ RS	|OP *	|dofindlabel	|NN OP *o				\
 				|NN OP **oplimit
 S	|MAGIC *|doparseform	|NN SV *sv
 RS	|I32	|dopoptoeval	|I32 startingblock
+RS	|I32	|dopoptogivenfor|I32 startingblock
 RS	|I32	|dopoptolabel	|NN const char *label			\
 				|STRLEN len				\
 				|U32 flags
 RS	|I32	|dopoptoloop	|I32 startingblock
 RS	|I32	|dopoptosub_at	|NN const PERL_CONTEXT *cxstk		\
 				|I32 startingblock
+RS	|I32	|dopoptowhen	|I32 startingblock
+S	|OP *	|do_smartmatch	|NULLOK HV *seen_this			\
+				|NULLOK HV *seen_other			\
+				|const bool copied
+RS	|PMOP * |make_matcher	|NN REGEXP *re
+RS	|bool	|matcher_matches_sv					\
+				|NN PMOP *matcher			\
+				|NN SV *sv
 RST	|bool	|num_overflow	|NV value				\
 				|I32 fldsize				\
 				|I32 frcsize
@@ -6194,11 +6217,13 @@ CTp	|Malloc_t|mem_log_realloc					\
 Cipx	|void	|cx_popblock	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popeval	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popformat	|NN PERL_CONTEXT *cx
+Cipx	|void	|cx_popgiven	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_poploop	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popsub	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popsub_args |NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popsub_common					\
 				|NN PERL_CONTEXT *cx
+Cipx	|void	|cx_popwhen	|NN PERL_CONTEXT *cx
 Cipx	|PERL_CONTEXT *|cx_pushblock					\
 				|U8 type				\
 				|U8 gimme				\
@@ -6211,6 +6236,8 @@ Cipx	|void	|cx_pushformat	|NN PERL_CONTEXT *cx			\
 				|NN CV *cv				\
 				|NULLOK OP *retop			\
 				|NULLOK GV *gv
+Cipx	|void	|cx_pushgiven	|NN PERL_CONTEXT *cx			\
+				|NULLOK SV *orig_defsv
 Cipx	|void	|cx_pushloop_for|NN PERL_CONTEXT *cx			\
 				|NN void *itervarp			\
 				|NULLOK SV *itersave
@@ -6222,6 +6249,7 @@ Cipx	|void	|cx_pushsub	|NN PERL_CONTEXT *cx			\
 				|bool hasargs
 Cipx	|void	|cx_pushtry	|NN PERL_CONTEXT *cx			\
 				|NULLOK OP *retop
+Cipx	|void	|cx_pushwhen	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_topblock	|NN PERL_CONTEXT *cx
 Cipx	|U8	|gimme_V
 #endif /* !defined(PERL_NO_INLINE_FUNCTIONS) */

embed.h

@@ -425,6 +425,7 @@
 # define newDEFSVOP()                           Perl_newDEFSVOP(aTHX)
 # define newFORM(a,b,c)                         Perl_newFORM(aTHX_ a,b,c)
 # define newFOROP(a,b,c,d,e)                    Perl_newFOROP(aTHX_ a,b,c,d,e)
+# define newGIVENOP(a,b,c)                      Perl_newGIVENOP(aTHX_ a,b,c)
 # define newGVOP(a,b,c)                         Perl_newGVOP(aTHX_ a,b,c)
 # define newGVREF(a,b)                          Perl_newGVREF(aTHX_ a,b)
 # define newGVgen_flags(a,b)                    Perl_newGVgen_flags(aTHX_ a,b)
@@ -480,6 +481,7 @@
 # define newTRYCATCHOP(a,b,c,d)                 Perl_newTRYCATCHOP(aTHX_ a,b,c,d)
 # define newUNOP(a,b,c)                         Perl_newUNOP(aTHX_ a,b,c)
 # define newUNOP_AUX(a,b,c,d)                   Perl_newUNOP_AUX(aTHX_ a,b,c,d)
+# define newWHENOP(a,b)                         Perl_newWHENOP(aTHX_ a,b)
 # define newWHILEOP(a,b,c,d,e,f,g)              Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
 # define newXS(a,b,c)                           Perl_newXS(aTHX_ a,b,c)
 # define newXS_flags(a,b,c,d,e)                 Perl_newXS_flags(aTHX_ a,b,c,d,e)
@@ -1351,6 +1353,7 @@
 #     define ck_scmp(a)                         Perl_ck_scmp(aTHX_ a)
 #     define ck_select(a)                       Perl_ck_select(aTHX_ a)
 #     define ck_shift(a)                        Perl_ck_shift(aTHX_ a)
+#     define ck_smartmatch(a)                   Perl_ck_smartmatch(aTHX_ a)
 #     define ck_sort(a)                         Perl_ck_sort(aTHX_ a)
 #     define ck_spair(a)                        Perl_ck_spair(aTHX_ a)
 #     define ck_split(a)                        Perl_ck_split(aTHX_ a)
@@ -1545,9 +1548,11 @@
 #     define is_handle_constructor              S_is_handle_constructor
 #     define is_standard_filehandle_name        S_is_standard_filehandle_name
 #     define listkids(a)                        S_listkids(aTHX_ a)
+#     define looks_like_bool(a)                 S_looks_like_bool(aTHX_ a)
 #     define modkids(a,b)                       S_modkids(aTHX_ a,b)
 #     define move_proto_attr(a,b,c,d)           S_move_proto_attr(aTHX_ a,b,c,d)
 #     define my_kid(a,b,c)                      S_my_kid(aTHX_ a,b,c)
+#     define newGIVWHENOP(a,b,c,d,e)            S_newGIVWHENOP(aTHX_ a,b,c,d,e)
 #     define newMETHOP_internal(a,b,c,d)        S_newMETHOP_internal(aTHX_ a,b,c,d)
 #     define new_logop(a,b,c,d)                 S_new_logop(aTHX_ a,b,c,d)
 #     define no_fh_allowed(a)                   S_no_fh_allowed(aTHX_ a)
@@ -1556,6 +1561,7 @@
 #     define opslab_slot_offset                 S_opslab_slot_offset
 #     define pmtrans(a,b,c)                     S_pmtrans(aTHX_ a,b,c)
 #     define process_special_blocks(a,b,c,d)    S_process_special_blocks(aTHX_ a,b,c,d)
+#     define ref_array_or_hash(a)               S_ref_array_or_hash(aTHX_ a)
 #     define refkids(a,b)                       S_refkids(aTHX_ a,b)
 #     define scalar_mod_type                    S_scalar_mod_type
 #     define scalarboolean(a)                   S_scalarboolean(aTHX_ a)
@@ -1631,14 +1637,20 @@
 #   endif
 #   if defined(PERL_IN_PP_CTL_C)
 #     define check_type_and_open(a)             S_check_type_and_open(aTHX_ a)
+#     define destroy_matcher(a)                 S_destroy_matcher(aTHX_ a)
+#     define do_smartmatch(a,b,c)               S_do_smartmatch(aTHX_ a,b,c)
 #     define docatch(a)                         S_docatch(aTHX_ a)
 #     define doeval_compile(a,b,c,d)            S_doeval_compile(aTHX_ a,b,c,d)
 #     define dofindlabel(a,b,c,d,e,f)           S_dofindlabel(aTHX_ a,b,c,d,e,f)
 #     define doparseform(a)                     S_doparseform(aTHX_ a)
 #     define dopoptoeval(a)                     S_dopoptoeval(aTHX_ a)
+#     define dopoptogivenfor(a)                 S_dopoptogivenfor(aTHX_ a)
 #     define dopoptolabel(a,b,c)                S_dopoptolabel(aTHX_ a,b,c)
 #     define dopoptoloop(a)                     S_dopoptoloop(aTHX_ a)
 #     define dopoptosub_at(a,b)                 S_dopoptosub_at(aTHX_ a,b)
+#     define dopoptowhen(a)                     S_dopoptowhen(aTHX_ a)
+#     define make_matcher(a)                    S_make_matcher(aTHX_ a)
+#     define matcher_matches_sv(a,b)            S_matcher_matches_sv(aTHX_ a,b)
 #     define num_overflow                       S_num_overflow
 #     define path_is_searchable                 S_path_is_searchable
 #     define run_user_filter(a,b,c)             S_run_user_filter(aTHX_ a,b,c)
@@ -2223,17 +2235,21 @@
 #   define cx_popblock(a)                       Perl_cx_popblock(aTHX_ a)
 #   define cx_popeval(a)                        Perl_cx_popeval(aTHX_ a)
 #   define cx_popformat(a)                      Perl_cx_popformat(aTHX_ a)
+#   define cx_popgiven(a)                       Perl_cx_popgiven(aTHX_ a)
 #   define cx_poploop(a)                        Perl_cx_poploop(aTHX_ a)
 #   define cx_popsub(a)                         Perl_cx_popsub(aTHX_ a)
 #   define cx_popsub_args(a)                    Perl_cx_popsub_args(aTHX_ a)
 #   define cx_popsub_common(a)                  Perl_cx_popsub_common(aTHX_ a)
+#   define cx_popwhen(a)                        Perl_cx_popwhen(aTHX_ a)
 #   define cx_pushblock(a,b,c,d)                Perl_cx_pushblock(aTHX_ a,b,c,d)
 #   define cx_pusheval(a,b,c)                   Perl_cx_pusheval(aTHX_ a,b,c)
 #   define cx_pushformat(a,b,c,d)               Perl_cx_pushformat(aTHX_ a,b,c,d)
+#   define cx_pushgiven(a,b)                    Perl_cx_pushgiven(aTHX_ a,b)
 #   define cx_pushloop_for(a,b,c)               Perl_cx_pushloop_for(aTHX_ a,b,c)
 #   define cx_pushloop_plain(a)                 Perl_cx_pushloop_plain(aTHX_ a)
 #   define cx_pushsub(a,b,c,d)                  Perl_cx_pushsub(aTHX_ a,b,c,d)
 #   define cx_pushtry(a,b)                      Perl_cx_pushtry(aTHX_ a,b)
+#   define cx_pushwhen(a)                       Perl_cx_pushwhen(aTHX_ a)
 #   define cx_topblock(a)                       Perl_cx_topblock(aTHX_ a)
 #   define gimme_V()                            Perl_gimme_V(aTHX)
 # endif /* !defined(PERL_NO_INLINE_FUNCTIONS) */

ext/Opcode/Opcode.pm

@@ -1,4 +1,4 @@
-package Opcode 1.68;
+package Opcode 1.69;
 
 use strict;
 
@@ -436,6 +436,11 @@ These are a hotchpotch of opcodes still waiting to be considered
     entertry leavetry -- can be used to 'hide' fatal errors
     entertrycatch poptry catch leavetrycatch -- similar
 
+    entergiven leavegiven
+    enterwhen leavewhen
+    break continue
+    smartmatch
+
     pushdefer
 
     custom -- where should this go