git.maemo.org Git - pkg-perl/blob - deb-src/libsub-uplevel-perl/libsub-uplevel-perl-0.1901/t/03_nested_uplevels.t

   1 #!perl
   2 use strict;
   3 use Test::More;
   4
   5 use Sub::Uplevel;
   6
   7 package Wrap;
   8 use Sub::Uplevel;
   9
  10 sub wrap {
  11     my ($n, $f, $depth, $up, @case) = @_;
  12
  13     if ($n > 1) {
  14         $n--;
  15         return wrap( $n, $f, $depth, $up, @case );
  16     }
  17     else {
  18         return uplevel( $up , $f, $depth, $up, @case );
  19     }
  20 }
  21
  22 package Call;
  23
  24 sub recurse_call_check {
  25     my ($depth, $up, @case) = @_;
  26
  27     if ( $depth ) {
  28         $depth--;
  29         my @result;
  30         push @result, recurse_call_check($depth, $up, @case, 'Call' );
  31         for my $n ( 1 .. $up ) {
  32             push @result, Wrap::wrap( $n, \&recurse_call_check,
  33                 $depth, $n, @case,
  34                 $n == 1 ? "Wrap(Call)" : "Wrap(Call) x $n" ),
  35             ;
  36         }
  37         return @result;
  38     }
  39     else {
  40         my (@uplevel_callstack, @real_callstack);
  41         my $i = 0;
  42         while ( defined( my $caller = caller($i++) ) ) {
  43             push @uplevel_callstack, $caller;
  44         }
  45         $i = 0;
  46         while ( defined( my $caller = CORE::caller($i++) ) ) {
  47             push @real_callstack, $caller;
  48         }
  49         return [
  50             join( q{, }, @case ),
  51             join( q{, }, reverse @uplevel_callstack ),
  52             join( q{, }, reverse @real_callstack ),
  53         ];
  54     }
  55 }
  56
  57 package main;
  58
  59 my $depth = 4;
  60 my $up = 3;
  61 my $cases = 104;
  62
  63 plan tests => $cases;
  64
  65 my @results = Call::recurse_call_check( $depth, $up, 'Call' );
  66
  67 is( scalar @results, $cases,
  68     "Right number of cases"
  69 );
  70
  71 my $expected = shift @results;
  72
  73 for my $got ( @results ) {
  74     is( $got->[1], $expected->[1],
  75         "Case: $got->[0]"
  76     ) or diag( "Real callers: $got->[2]" );
  77 }
  78