t/lineno-torture.t

   1 use warnings;
   2 use strict;
   3
   4 use Test::More;
   5
   6 use Function::Parameters;
   7
   8 fun actual_location_of_line_with($marker) {
   9         seek DATA, 0, 0 or die "seek DATA: $!";
  10         my $loc = 0;
  11         while (my $line = readline DATA) {
  12                 $loc++;
  13                 index($line, $marker) >= 0
  14                         and return $loc;
  15         }
  16         undef
  17 }
  18
  19 fun test_loc($marker) {
  20         my $expected = actual_location_of_line_with $marker;
  21         defined $expected or die "$marker: something done fucked up";
  22         my $got = (caller)[2];
  23         is $got, $expected, "location of '$marker'";
  24 }
  25
  26 sub {
  27         test_loc 'LT torture begin';
  28         use integer;
  29         my $r = shift;
  30
  31         my $a = shift;
  32         my $b = shift;
  33
  34         test_loc 'LT torture A';
  35         @_ = (
  36                 sub {
  37                         my $f = shift;
  38                         test_loc 'LT torture B';
  39                         @_ = (
  40                                 sub {
  41                                         my $f = shift;
  42                                         test_loc 'LT torture C';
  43                                         @_ = (
  44                                                 sub {
  45                                                         my $f = shift;
  46                                                         test_loc 'LT torture D';
  47                                                         @_ = (
  48                                                                 sub {
  49                                                                         my $n = shift;
  50                                                                         test_loc 'LT torture end';
  51                                                                         @_ = $n;
  52                                                                         goto &$r;
  53                                                                 },
  54                                                                 $b
  55                                                         );
  56                                                         goto &$f;
  57                                                 },
  58                                                 $a
  59                                         );
  60                                         goto &$f;
  61                                 },
  62                                 sub {
  63                                         my $r = shift;
  64                                         my $f = shift;
  65                                         @_ = sub {
  66                                                 my $r = shift;
  67                                                 my $x = shift;
  68                                                 @_ = sub {
  69                                                         my $r = shift;
  70                                                         my $y = shift;
  71                                                         test_loc 'LT torture body';
  72                                                         if ($x && $y) {
  73                                                                 @_ = (
  74                                                                         sub {
  75                                                                                 my $f = shift;
  76                                                                                 @_ = ($r, ($x & $y) << 1);
  77                                                                                 goto &$f;
  78                                                                         },
  79                                                                         $x ^ $y
  80                                                                 );
  81                                                                 goto &$f;
  82                                                         }
  83                                                         @_ = $x ^ $y;
  84                                                         goto &$r;
  85                                                 };
  86                                                 goto &$r;
  87                                         };
  88                                         goto &$r;
  89                                 }
  90                         );
  91                         goto &$f;
  92                 },
  93                 sub {
  94                         my $r = shift;
  95                         my $y = shift;
  96                         @_ = sub {
  97                                 my $r = shift;
  98                                 my $f = shift;
  99                                 @_ = sub {
 100                                         my $r = shift;
 101                                         my $x = shift;
 102                                         @_ = (
 103                                                 sub {
 104                                                         my $f = shift;
 105                                                         @_ = ($r, $x);
 106                                                         goto &$f;
 107                                                 },
 108                                                 sub {
 109                                                         my $r = shift;
 110                                                         my $x = shift;
 111                                                         @_ = (
 112                                                                 sub {
 113                                                                         my $g = shift;
 114                                                                         @_ = (
 115                                                                                 sub {
 116                                                                                         my $f = shift;
 117                                                                                         @_ = ($r, $x);
 118                                                                                         goto &$f;
 119                                                                                 },
 120                                                                                 $f
 121                                                                         );
 122                                                                         goto &$g;
 123                                                                 },
 124                                                                 $y
 125                                                         );
 126                                                         goto &$y;
 127                                                 }
 128                                         );
 129                                         goto &$f;
 130                                 };
 131                                 goto &$r;
 132                         };
 133                         goto &$r;
 134                 }
 135         );
 136
 137         goto & {
 138                 sub {
 139                         my $r = shift;
 140                         my $f = shift;
 141                         test_loc 'LT torture boot';
 142                         @_ = ($r, $f);
 143                         goto &$f;
 144                 }
 145         };
 146
 147 }->(sub { my $n = shift; is $n, 2, '1 + 1 = 2' }, 1, 1);
 148
 149 TODO: {
 150         local $TODO = 'line numbers all fucked up';
 151
 152         fun ($r, $a, $b) {
 153                 test_loc 'LX torture begin';
 154                 use integer;
 155                 test_loc 'LX torture A';
 156                 @_ = ( do { test_loc 'LX torture A-post'; () },
 157                         do { test_loc 'LX torture B-pre'; () }, fun ($f) { test_loc 'LX torture B-pre';
 158                                 test_loc 'LX torture B';
 159                                 @_ = (
 160                                         fun ($f) {
 161                                                 test_loc 'LX torture C';
 162                                                 @_ = (
 163                                                         fun ($f) {
 164                                                                 test_loc 'LX torture D';
 165                                                                 @_ = (
 166                                                                         fun ($n) {
 167                                                                                 test_loc 'LX torture end';
 168                                                                                 @_ = $n;
 169                                                                                 goto &$r;
 170                                                                         },
 171                                                                         $b
 172                                                                 );
 173                                                                 goto &$f;
 174                                                         },
 175                                                         $a
 176                                                 );
 177                                                 goto &$f;
 178                                         },
 179                                         fun ($r, $f) {
 180                                                 @_ = fun ($r, $x) {
 181                                                         @_ = fun ($r, $y) {
 182                                                                 test_loc 'LX torture body';
 183                                                                 if ($x && $y) {
 184                                                                         @_ = (
 185                                                                                 fun ($f) {
 186                                                                                         @_ = ($r, ($x & $y) << 1);
 187                                                                                         goto &$f;
 188                                                                                 },
 189                                                                                 $x ^ $y
 190                                                                         );
 191                                                                         goto &$f;
 192                                                                 }
 193                                                                 @_ = $x ^ $y;
 194                                                                 goto &$r;
 195                                                         };
 196                                                         goto &$r;
 197                                                 };
 198                                                 goto &$r;
 199                                         }
 200                                 );
 201                                 goto &$f;
 202                         },
 203                         fun ($r, $y) {
 204                                 @_ = fun ($r, $f) {
 205                                         @_ = fun ($r, $x) {
 206                                                 @_ = (
 207                                                         fun ($f) {
 208                                                                 @_ = ($r, $x);
 209                                                                 goto &$f;
 210                                                         },
 211                                                         fun ($r, $x) {
 212                                                                 @_ = (
 213                                                                         fun ($g) {
 214                                                                                 @_ = (
 215                                                                                         fun ($f) {
 216                                                                                                 @_ = ($r, $x);
 217                                                                                                 goto &$f;
 218                                                                                         },
 219                                                                                         $f
 220                                                                                 );
 221                                                                                 goto &$g;
 222                                                                         },
 223                                                                         $y
 224                                                                 );
 225                                                                 goto &$y;
 226                                                         }
 227                                                 );
 228                                                 goto &$f;
 229                                         };
 230                                         goto &$r;
 231                                 };
 232                                 goto &$r;
 233                         }
 234                 );
 235
 236                 goto & {
 237                         fun ($r, $f) {
 238                                 test_loc 'LX torture boot';
 239                                 @_ = ($r, $f);
 240                                 goto &$f;
 241                         }
 242                 };
 243
 244         }->(fun ($n) { is $n, 2, '1 + 1 = 2' }, 1, 1);
 245
 246 }
 247
 248 done_testing;
 249 __DATA__