Add ARM files

[dh-make-perl] / dev / arm / libsub-uplevel-perl / libsub-uplevel-perl-0.1901 / t / 03_nested_uplevels.t

diff --git a/dev/arm/libsub-uplevel-perl/libsub-uplevel-perl-0.1901/t/03_nested_uplevels.t b/dev/arm/libsub-uplevel-perl/libsub-uplevel-perl-0.1901/t/03_nested_uplevels.t
new file mode 100644 (file)
index 0000000..ba49484
--- /dev/null
+++ b/dev/arm/libsub-uplevel-perl/libsub-uplevel-perl-0.1901/t/03_nested_uplevels.t
@@ -0,0 +1,78 @@
+#!perl
+use strict;
+use Test::More;
+
+use Sub::Uplevel;
+
+package Wrap;
+use Sub::Uplevel;
+
+sub wrap {
+    my ($n, $f, $depth, $up, @case) = @_;
+    
+    if ($n > 1) {
+        $n--;
+        return wrap( $n, $f, $depth, $up, @case );
+    }
+    else {
+        return uplevel( $up , $f, $depth, $up, @case );
+    }
+}
+
+package Call;
+
+sub recurse_call_check {
+    my ($depth, $up, @case) = @_;
+
+    if ( $depth ) {
+        $depth--;
+        my @result;
+        push @result, recurse_call_check($depth, $up, @case, 'Call' );
+        for my $n ( 1 .. $up ) {
+            push @result, Wrap::wrap( $n, \&recurse_call_check, 
+                $depth, $n, @case, 
+                $n == 1 ? "Wrap(Call)" : "Wrap(Call) x $n" ),
+            ;
+        }
+        return @result;
+    }
+    else {
+        my (@uplevel_callstack, @real_callstack);
+        my $i = 0;
+        while ( defined( my $caller = caller($i++) ) ) {
+            push @uplevel_callstack, $caller;
+        }
+        $i = 0;
+        while ( defined( my $caller = CORE::caller($i++) ) ) {
+            push @real_callstack, $caller;
+        }
+        return [ 
+            join( q{, }, @case ),
+            join( q{, }, reverse @uplevel_callstack ),
+            join( q{, }, reverse @real_callstack ),
+        ];      
+    }
+}
+
+package main;
+
+my $depth = 4;
+my $up = 3;
+my $cases = 104;
+
+plan tests => $cases;
+
+my @results = Call::recurse_call_check( $depth, $up, 'Call' );
+
+is( scalar @results, $cases, 
+    "Right number of cases"
+);
+
+my $expected = shift @results;
+
+for my $got ( @results ) {
+    is( $got->[1], $expected->[1], 
+        "Case: $got->[0]"
+    ) or diag( "Real callers: $got->[2]" );
+}
+