lib/perl5db.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10 use warnings;
  11 use Config;
  12
  13 BEGIN {
  14     if (! -c "/dev/null") {
  15         print "1..0 # Skip: no /dev/null\n";
  16         exit 0;
  17     }
  18
  19     my $dev_tty = '/dev/tty';
  20     $dev_tty = 'TT:' if ($^O eq 'VMS');
  21     if (! -c $dev_tty) {
  22         print "1..0 # Skip: no $dev_tty\n";
  23         exit 0;
  24     }
  25     if ($ENV{PERL5DB}) {
  26         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
  27         exit 0;
  28     }
  29 }
  30
  31 plan(16);
  32
  33 my $rc_filename = '.perldb';
  34
  35 sub rc {
  36     open my $rc_fh, '>', $rc_filename
  37         or die $!;
  38     print {$rc_fh} @_;
  39     close ($rc_fh);
  40
  41     # overly permissive perms gives "Must not source insecure rcfile"
  42     # and hangs at the DB(1> prompt
  43     chmod 0644, $rc_filename;
  44 }
  45
  46 sub _slurp
  47 {
  48     my $filename = shift;
  49
  50     open my $in, '<', $filename
  51         or die "Cannot open '$filename' for slurping - $!";
  52
  53     local $/;
  54     my $contents = <$in>;
  55
  56     close($in);
  57
  58     return $contents;
  59 }
  60
  61 my $out_fn = 'db.out';
  62
  63 sub _out_contents
  64 {
  65     return _slurp($out_fn);
  66 }
  67
  68 {
  69     my $target = '../lib/perl5db/t/eval-line-bug';
  70
  71     rc(
  72         <<"EOF",
  73     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
  74
  75     sub afterinit {
  76         push(\@DB::typeahead,
  77             'b 23',
  78             'n',
  79             'n',
  80             'n',
  81             'c', # line 23
  82             'n',
  83             "p \\\@{'main::_<$target'}",
  84             'q',
  85         );
  86     }
  87 EOF
  88     );
  89
  90     {
  91         local $ENV{PERLDB_OPTS} = "ReadLine=0";
  92         runperl(switches => [ '-d' ], progfile => $target);
  93     }
  94 }
  95
  96 like(_out_contents(), qr/sub factorial/,
  97     'The ${main::_<filename} variable in the debugger was not destroyed'
  98 );
  99
 100 {
 101     local $ENV{PERLDB_OPTS} = "ReadLine=0";
 102     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
 103     like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
 104 }
 105
 106 {
 107     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 108     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
 109     like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
 110 }
 111
 112 SKIP: {
 113     if ( $Config{usethreads} ) {
 114         skip('This perl has threads, skipping non-threaded debugger tests');
 115     } else {
 116         my $error = 'This Perl not built to support threads';
 117         my $output = runperl( switches => [ '-dt' ], stderr => 1 );
 118         like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
 119     }
 120
 121 }
 122 SKIP: {
 123     if ( $Config{usethreads} ) {
 124         local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 125         my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
 126         like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
 127     } else {
 128         skip("This perl is not threaded, skipping threaded debugger tests");
 129     }
 130 }
 131
 132
 133 # Test [perl #61222]
 134 {
 135     rc(
 136         <<'EOF',
 137         &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 138
 139         sub afterinit {
 140             push(@DB::typeahead,
 141                 'm Pie',
 142                 'q',
 143             );
 144         }
 145 EOF
 146     );
 147
 148     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
 149     unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
 150 }
 151
 152
 153
 154 # Test for Proxy constants
 155 {
 156     rc(
 157         <<'EOF',
 158
 159 &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
 160
 161 sub afterinit {
 162     push(@DB::typeahead,
 163         'm main->s1',
 164         'q',
 165     );
 166 }
 167
 168 EOF
 169     );
 170
 171     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
 172     is($output, "", "proxy constant subroutines");
 173 }
 174
 175 # Testing that we can set a line in the middle of the file.
 176 {
 177     rc(<<'EOF');
 178 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 179
 180 sub afterinit {
 181     push (@DB::typeahead,
 182     'b ../lib/perl5db/t/MyModule.pm:12',
 183     'c',
 184     q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
 185     'c',
 186     'q',
 187     );
 188
 189 }
 190 EOF
 191
 192     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/filename-line-breakpoint');
 193
 194     like($output, qr/
 195         ^Var=Bar$
 196             .*
 197         ^In\ MyModule\.$
 198             .*
 199         ^In\ Main\ File\.$
 200             .*
 201         /msx,
 202         "Can set breakpoint in a line in the middle of the file.");
 203 }
 204
 205
 206 # [perl #66110] Call a subroutine inside a regex
 207 {
 208     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 209     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
 210     like($output, "All tests successful.", "[perl #66110]");
 211 }
 212
 213 # [perl 104168] level option for tracing
 214 {
 215     rc(<<'EOF');
 216 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 217
 218 sub afterinit {
 219     push (@DB::typeahead,
 220     't 2',
 221     'c',
 222     'q',
 223     );
 224
 225 }
 226 EOF
 227
 228     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-104168');
 229     my $contents;
 230     {
 231         local $/;
 232         open I, "<", 'db.out' or die $!;
 233         $contents = <I>;
 234         close(I);
 235     }
 236     like($contents, qr/level 2/, "[perl #104168]");
 237     unlike($contents, qr/baz/, "[perl #104168]");
 238 }
 239
 240 # taint tests
 241
 242 {
 243     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 244     my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
 245         progfile => '../lib/perl5db/t/taint');
 246     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
 247     is($output, '[$^X][done]', "taint");
 248 }
 249
 250 # Testing that we can set a breakpoint
 251 {
 252     rc(<<'EOF');
 253 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 254
 255 sub afterinit {
 256     push (@DB::typeahead,
 257     'b 6',
 258     'c',
 259     q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
 260     'c',
 261     'q',
 262     );
 263
 264 }
 265 EOF
 266
 267     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/breakpoint-bug');
 268
 269     like($output, qr/
 270         X=\{Two\}
 271         /msx,
 272         "Can set breakpoint in a line.");
 273 }
 274
 275
 276 # Testing that we can disable a breakpoint at a numeric line.
 277 {
 278     rc(<<'EOF');
 279 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 280
 281 sub afterinit {
 282     push (@DB::typeahead,
 283     'b 7',
 284     'b 11',
 285     'disable 7',
 286     'c',
 287     q/print "X={$x}\n";/,
 288     'c',
 289     'q',
 290     );
 291
 292 }
 293 EOF
 294
 295     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); +
 296     like($output, qr/
 297         X=\{SecondVal\}
 298         /msx,
 299         "Can set breakpoint in a line.");
 300 }
 301
 302 # Testing that we can re-enable a breakpoint at a numeric line.
 303 {
 304     rc(<<'EOF');
 305 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 306
 307 sub afterinit {
 308     push (@DB::typeahead,
 309     'b 8',
 310     'b 24',
 311     'disable 24',
 312     'c',
 313     'enable 24',
 314     'c',
 315     q/print "X={$x}\n";/,
 316     'c',
 317     'q',
 318     );
 319
 320 }
 321 EOF
 322
 323     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-2');
 324     like($output, qr/
 325         X=\{SecondValOneHundred\}
 326         /msx,
 327         "Can set breakpoint in a line.");
 328 }
 329 # clean up.
 330
 331 # Disable and enable for breakpoints on outer files.
 332 {
 333     rc(<<'EOF');
 334 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 335
 336 sub afterinit {
 337     push (@DB::typeahead,
 338     'b 10',
 339     'b ../lib/perl5db/t/EnableModule.pm:14',
 340     'disable ../lib/perl5db/t/EnableModule.pm:14',
 341     'c',
 342     'enable ../lib/perl5db/t/EnableModule.pm:14',
 343     'c',
 344     q/print "X={$x}\n";/,
 345     'c',
 346     'q',
 347     );
 348
 349 }
 350 EOF
 351
 352     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-3'); +
 353     like($output, qr/
 354         X=\{SecondValTwoHundred\}
 355         /msx,
 356         "Can set breakpoint in a line.");
 357 }
 358 END {
 359     1 while unlink ($rc_filename, $out_fn);
 360 }