1 files changed, 217 insertions, 0 deletions
diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl
new file mode 100644
index 0000000..0deccd3
--- /dev/null
+++ b/contrib/perl5/t/pragma/warn/pp_ctl
@@ -0,0 +1,217 @@
+  pp_ctl.c	AOK
+ 
+     Not enough format arguments	
+ 	format STDOUT =
+ 	@<<< @<<<
+ 	$a
+ 	.
+ 	write;
+     
+
+    Exiting substitution via %s
+	$_ = "abc" ;
+	while ($i ++ == 0)
+	{
+    	    s/ab/last/e ;
+	}
+
+    Exiting subroutine via %s		
+	sub fred { last }
+	{ fred() }
+
+    Exiting eval via %s	
+	{ eval "last" }
+
+    Exiting pseudo-block via %s 
+	@a = (1,2) ; @b = sort { last } @a ;
+
+    Exiting substitution via %s
+	$_ = "abc" ;
+	last fred:
+	while ($i ++ == 0)
+	{
+    	    s/ab/last fred/e ;
+	}
+
+
+    Exiting subroutine via %s
+	sub fred { last joe }
+	joe: { fred() }
+
+    Exiting eval via %s
+	fred: { eval "last fred" }
+
+    Exiting pseudo-block via %s 
+	@a = (1,2) ; fred: @b = sort { last fred } @a ;
+
+
+    Deep recursion on subroutine \"%s\"
+	sub fred
+	{
+    	  fred() if $a++ < 200
+	}
+	 
+	fred()
+
+      (in cleanup) foo bar
+	package Foo;
+	DESTROY { die "foo bar" }
+	{ bless [], 'Foo' for 1..10 }
+
+__END__
+# pp_ctl.c
+use warnings 'syntax' ;
+format STDOUT =
+@<<< @<<<
+1
+.
+write;
+EXPECT
+Not enough format arguments at - line 5.
+1
+########
+# pp_ctl.c
+no warnings 'syntax' ;
+format =
+@<<< @<<<
+1
+.
+write ;
+EXPECT
+1
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+$_ = "abc" ;
+ 
+while ($i ++ == 0)
+{
+    s/ab/last/e ;
+}
+no warnings 'exiting' ;
+while ($i ++ == 0)
+{
+    s/ab/last/e ;
+}
+EXPECT
+Exiting substitution via last at - line 7.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+sub fred { last }
+{ fred() }
+no warnings 'exiting' ;
+sub joe { last }
+{ joe() }
+EXPECT
+Exiting subroutine via last at - line 3.
+########
+# pp_ctl.c
+{
+  eval "use warnings 'exiting' ; last;" 
+}
+print STDERR $@ ;
+{
+  eval "no warnings 'exiting' ;last;" 
+} 
+print STDERR $@ ;
+EXPECT
+Exiting eval via last at (eval 1) line 1.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+@a = (1,2) ;
+@b = sort { last } @a ;
+no warnings 'exiting' ;
+@b = sort { last } @a ;
+EXPECT
+Exiting pseudo-block via last at - line 4.
+Can't "last" outside a loop block at - line 4.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+$_ = "abc" ;
+fred: 
+while ($i ++ == 0)
+{
+    s/ab/last fred/e ;
+}
+no warnings 'exiting' ;
+while ($i ++ == 0)
+{
+    s/ab/last fred/e ;
+}
+EXPECT
+Exiting substitution via last at - line 7.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+sub fred { last joe }
+joe: { fred() }
+no warnings 'exiting' ;
+sub Fred { last Joe }
+Joe: { Fred() }
+EXPECT
+Exiting subroutine via last at - line 3.
+########
+# pp_ctl.c
+joe:
+{ eval "use warnings 'exiting' ; last joe;" }
+print STDERR $@ ;
+Joe:
+{ eval "no warnings 'exiting' ; last Joe;" }
+print STDERR $@ ;
+EXPECT
+Exiting eval via last at (eval 1) line 1.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+@a = (1,2) ;
+fred: @b = sort { last fred } @a ;
+no warnings 'exiting' ;
+Fred: @b = sort { last Fred } @a ;
+EXPECT
+Exiting pseudo-block via last at - line 4.
+Label not found for "last fred" at - line 4.
+########
+# pp_ctl.c
+use warnings 'recursion' ;
+BEGIN { warn "PREFIX\n" ;}
+sub fred
+{
+    fred() if $a++ < 200
+}
+ 
+fred()
+EXPECT
+Deep recursion on subroutine "main::fred" at - line 6.
+########
+# pp_ctl.c
+no warnings 'recursion' ;
+BEGIN { warn "PREFIX\n" ;}
+sub fred
+{
+    fred() if $a++ < 200
+}
+ 
+fred()
+EXPECT
+########
+# pp_ctl.c
+use warnings 'misc' ;
+package Foo;
+DESTROY { die "@{$_[0]} foo bar" }
+{ bless ['A'], 'Foo' for 1..10 }
+{ bless ['B'], 'Foo' for 1..10 }
+EXPECT
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+########
+# pp_ctl.c
+no warnings 'misc' ;
+package Foo;
+DESTROY { die "@{$_[0]} foo bar" }
+{ bless ['A'], 'Foo' for 1..10 }
+{ bless ['B'], 'Foo' for 1..10 }
+EXPECT
+