Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[PATCH] [perl5db] Add more tests + Revert back to C-style for loops #12378

Closed
p5pRT opened this issue Sep 5, 2012 · 8 comments
Closed

[PATCH] [perl5db] Add more tests + Revert back to C-style for loops #12378

p5pRT opened this issue Sep 5, 2012 · 8 comments
Labels

Comments

@p5pRT
Copy link

p5pRT commented Sep 5, 2012

Migrated from rt.perl.org#114756 (status was 'resolved')

Searchable as RT114756$

@p5pRT
Copy link
Author

p5pRT commented Sep 5, 2012

From @shlomif

Hi all,

This patch to lib/perl5db.pl and lib/perl5db.t adds more tests for the L and S commands
and reverts some changes from C-style for loops to while+continue loops which were
not very popular.

Please look into applying it. It can also be found here​:

https://github.com/shlomif/perl/tree/shlomif-perl-d-add-tests-take-4

(But with merge commits/etc., so it's not recommended).

Regards,

  Shlomi Fish

Inline Patch
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 39c18e5..5b966e3 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -1756,7 +1756,7 @@ sub DB {
                 # If there's any call stack in place, turn off single
                 # stepping into subs throughout the stack.
             for my $i (0 .. $stack_depth) {
-                $stack[ $i++ ] &= ~1;
+                $stack[ $i ] &= ~1;
             }
 
             # And we are now no longer in single-step mode.
@@ -2002,9 +2002,7 @@ number information, and print that.
 
             # Scan forward, stopping at either the end or the next
             # unbreakable line.
-            {
-                my $i = $line + 1;
-                while ( $i <= $max && $dbline[$i] == 0 )
+            for ( my $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
             {    #{ vi
 
                 # Drop out on null statements, block closers, and comments.
@@ -2029,12 +2027,7 @@ number information, and print that.
                 else {
                     depth_print_lineinfo($explicit_stop, $incr_pos);
                 }
-            }
-            continue
-            {
-                $i++;
-            }## end while ($i = $line + 1 ; $i...
-            }
+            } ## end for ($i = $line + 1 ; $i...
         } ## end else [ if ($slave_editor)
     } ## end if ($single || ($trace...
 
@@ -2965,15 +2958,10 @@ If a command is found, it is placed in C<$cmd> and executed via C<redo>.
                     pop(@hist) if length($cmd) > 1;
 
                     # Look backward through the history.
-                    $i = $#hist;
-                    while ($i) {
-
+                    for ( $i = $#hist ; $i ; --$i ) {
                         # Stop if we find it.
                         last if $hist[$i] =~ /$pat/;
                     }
-                    continue {
-                        $i--;
-                    }
 
                     if ( !$i ) {
 
@@ -3045,16 +3033,12 @@ Prints the contents of C<@hist> (if any).
                     # Start at the end of the array.
                     # Stay in while we're still above the ending value.
                     # Tick back by one each time around the loop.
-                    $i = $#hist;
-                    while ( $i > $end ) {
+                    for ( $i = $#hist ; $i > $end ; $i-- ) {
 
                         # Print the command  unless it has no arguments.
                         print $OUT "$i: ", $hist[$i], "\n"
                           unless $hist[$i] =~ /^.?$/;
                     }
-                    continue {
-                        $i--;
-                    }
                     next CMD;
                 };
 
@@ -5067,7 +5051,7 @@ sub cmd_l {
         # - whether a line has a break or not
         # - whether a line has an action or not
         else {
-            while ($i <= $end) {
+            for ( ; $i <= $end ; $i++ ) {
 
                 # Check for breakpoints and actions.
                 my ( $stop, $action );
@@ -5090,10 +5074,7 @@ sub cmd_l {
 
                 # Move on to the next line. Drop out on an interrupt.
                 $i++, last if $signal;
-            }
-            continue {
-                $i++;
-            }## end while (; $i <= $end ; $i++)
+            } ## end for (; $i <= $end ; $i++)
 
             # Line the prompt up; print a newline if the last line listed
             # didn't have a newline.
@@ -5854,11 +5835,11 @@ sub dump_trace {
     # number of stack frames, or we run out - caller() returns nothing - we
     # quit.
     # Up the stack frame index to go back one more level each time.
-    {
-        my $i = $skip;
-    while (
+    for (
+        my $i = $skip ;
         $i < $count
-        and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i)
+        and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
+        $i++
     )
     {
 
@@ -5945,11 +5926,7 @@ sub dump_trace {
 
         # Stop processing frames if the user hit control-C.
         last if $signal;
-    } ## end while ($i)
-    continue {
-        $i++;
-    }
-    }
+    } ## end for ($i = $skip ; $i < ...
 
     # Restore the trace value again.
     $trace = $otrace;
diff --git a/lib/perl5db.t b/lib/perl5db.t
index 9276fad..f873a01 100644
--- a/lib/perl5db.t
+++ b/lib/perl5db.t
@@ -28,7 +28,7 @@ BEGIN {
     }
 }
 
-plan(40);
+plan(48);
 
 my $rc_filename = '.perldb';
 
@@ -395,6 +395,13 @@ sub contents_like {
     ::like($self->_contents(), $re, $msg);
 }
 
+sub contents_unlike {
+    my ($self, $re, $msg) = @_;
+
+    local $::Level = $::Level + 1;
+    ::unlike($self->_contents(), $re, $msg);
+}
+
 package main;
 
 # Testing that we can set a line in the middle of the file.
@@ -1097,6 +1104,179 @@ package main;
     );
 }
 
+# Test the L command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'b 6',
+                'b 13 ($q == 5)',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^\S*?eval-line-bug:\n
+        \s*6:\s*my\ \$i\ =\ 5;\n
+        \s*break\ if\ \(1\)\n
+        \s*13:\s*\$i\ \+=\ \$q;\n
+        \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
+        #msx,
+        "L command is listing breakpoints",
+    );
+}
+
+# Test the L command for watch expressions.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'w (5+6)',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^Watch-expressions:\n
+        \s*\(5\+6\)\n
+        #msx,
+        "L command is listing watch expressions",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'w (5+6)',
+                'w (11*23)',
+                'W (5+6)',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^Watch-expressions:\n
+        \s*\(11\*23\)\n
+        ^auto\(
+        #msx,
+        "L command is not listing deleted watch expressions",
+    );
+}
+
+# Test the L command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'b 6',
+                'a 13 print $i',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^\S*?eval-line-bug:\n
+        \s*6:\s*my\ \$i\ =\ 5;\n
+        \s*break\ if\ \(1\)\n
+        \s*13:\s*\$i\ \+=\ \$q;\n
+        \s*action:\s+print\ \$i\n
+        #msx,
+        "L command is listing actions and breakpoints",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'S',
+                'q',
+            ],
+            prog =>  '../lib/perl5db/t/rt-104168',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^main::bar\n
+        main::baz\n
+        main::foo\n
+        #msx,
+        "S command - 1",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'S ^main::ba',
+                'q',
+            ],
+            prog =>  '../lib/perl5db/t/rt-104168',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^main::bar\n
+        main::baz\n
+        auto\(
+        #msx,
+        "S command with regex",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'S !^main::ba',
+                'q',
+            ],
+            prog =>  '../lib/perl5db/t/rt-104168',
+        }
+    );
+
+    $wrapper->contents_unlike(
+        qr#
+        ^main::ba
+        #msx,
+        "S command with negative regex",
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^main::foo\n
+        #msx,
+        "S command with negative regex - what it still matches",
+    );
+}
+
 END {
     1 while unlink ($rc_filename, $out_fn);
 }


-- 

Shlomi Fish http​://www.shlomifish.org/
Interview with Ben Collins-Sussman - http​://shlom.in/sussman

Learn Perl from “Learning Perl in 24 Minutes Unleashed, in a Nutshell for
Dummies.”
  — based on Shlomi Fish and f00li5h on #perl

Please reply to list if it's a mailing list post - http​://shlom.in/reply .

@p5pRT
Copy link
Author

p5pRT commented Sep 9, 2012

From @shlomif

This is a more recent patcht hat can be applied instead of the previous
test. More tests were added, and I also fixed a problem with the
debugger actions that was reported on p5p.

Regards,

-- Shlomi Fish

@p5pRT
Copy link
Author

p5pRT commented Sep 9, 2012

From @shlomif

perl-d-add-tests-and-convert-back-to-c-style-for-loops-v2.patch
diff --git a/MANIFEST b/MANIFEST
index c0bfe2d..e5d92e9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4329,6 +4329,7 @@ lib/perl5db/t/taint		Tests for the Perl debugger
 lib/perl5db/t/test-l-statement-1	Tests for the Perl debugger
 lib/perl5db/t/test-l-statement-2	Tests for the Perl debugger
 lib/perl5db/t/test-r-statement	Tests for the Perl debugger
+lib/perl5db/t/test-w-statement-1	Tests for the Perl debugger
 lib/perl5db/t/uncalled-subroutine	Tests for the Perl debugger
 lib/perl5db/t/with-subroutine		Tests for the Perl debugger
 lib/PerlIO.pm			PerlIO support module
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 39c18e5..c8596df 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -1756,7 +1756,7 @@ sub DB {
                 # If there's any call stack in place, turn off single
                 # stepping into subs throughout the stack.
             for my $i (0 .. $stack_depth) {
-                $stack[ $i++ ] &= ~1;
+                $stack[ $i ] &= ~1;
             }
 
             # And we are now no longer in single-step mode.
@@ -1804,27 +1804,33 @@ sub DB {
     $max = $#dbline;
 
     # if we have something here, see if we should break.
-    if ( $dbline{$line}
-        && _is_breakpoint_enabled($filename, $line)
-        && ( my ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
     {
+        # $stop is lexical and local to this block - $action on the other hand
+        # is global.
+        my $stop;
 
-        # Stop if the stop criterion says to just stop.
-        if ( $stop eq '1' ) {
-            $signal |= 1;
-        }
+        if ( $dbline{$line}
+            && _is_breakpoint_enabled($filename, $line)
+            && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
+        {
 
-        # It's a conditional stop; eval it in the user's context and
-        # see if we should stop. If so, remove the one-time sigil.
-        elsif ($stop) {
-            $evalarg = "\$DB::signal |= 1 if do {$stop}";
-            &eval;
-            # If the breakpoint is temporary, then delete its enabled status.
-            if ($dbline{$line} =~ s/;9($|\0)/$1/) {
-                _cancel_breakpoint_temp_enabled_status($filename, $line);
+            # Stop if the stop criterion says to just stop.
+            if ( $stop eq '1' ) {
+                $signal |= 1;
             }
-        }
-    } ## end if ($dbline{$line} && ...
+
+            # It's a conditional stop; eval it in the user's context and
+            # see if we should stop. If so, remove the one-time sigil.
+            elsif ($stop) {
+                $evalarg = "\$DB::signal |= 1 if do {$stop}";
+                &eval;
+                # If the breakpoint is temporary, then delete its enabled status.
+                if ($dbline{$line} =~ s/;9($|\0)/$1/) {
+                    _cancel_breakpoint_temp_enabled_status($filename, $line);
+                }
+            }
+        } ## end if ($dbline{$line} && ...
+    }
 
     # Preserve the current stop-or-not, and see if any of the W
     # (watch expressions) has changed.
@@ -2002,9 +2008,7 @@ number information, and print that.
 
             # Scan forward, stopping at either the end or the next
             # unbreakable line.
-            {
-                my $i = $line + 1;
-                while ( $i <= $max && $dbline[$i] == 0 )
+            for ( my $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
             {    #{ vi
 
                 # Drop out on null statements, block closers, and comments.
@@ -2029,12 +2033,7 @@ number information, and print that.
                 else {
                     depth_print_lineinfo($explicit_stop, $incr_pos);
                 }
-            }
-            continue
-            {
-                $i++;
-            }## end while ($i = $line + 1 ; $i...
-            }
+            } ## end for ($i = $line + 1 ; $i...
         } ## end else [ if ($slave_editor)
     } ## end if ($single || ($trace...
 
@@ -2965,15 +2964,10 @@ If a command is found, it is placed in C<$cmd> and executed via C<redo>.
                     pop(@hist) if length($cmd) > 1;
 
                     # Look backward through the history.
-                    $i = $#hist;
-                    while ($i) {
-
+                    for ( $i = $#hist ; $i ; --$i ) {
                         # Stop if we find it.
                         last if $hist[$i] =~ /$pat/;
                     }
-                    continue {
-                        $i--;
-                    }
 
                     if ( !$i ) {
 
@@ -3045,16 +3039,12 @@ Prints the contents of C<@hist> (if any).
                     # Start at the end of the array.
                     # Stay in while we're still above the ending value.
                     # Tick back by one each time around the loop.
-                    $i = $#hist;
-                    while ( $i > $end ) {
+                    for ( $i = $#hist ; $i > $end ; $i-- ) {
 
                         # Print the command  unless it has no arguments.
                         print $OUT "$i: ", $hist[$i], "\n"
                           unless $hist[$i] =~ /^.?$/;
                     }
-                    continue {
-                        $i--;
-                    }
                     next CMD;
                 };
 
@@ -4001,6 +3991,8 @@ sub cmd_a {
 
                 # Add the action to the line.
                 $dbline{$lineno} .= "\0" . action($expr);
+
+                _set_breakpoint_enabled_status($filename, $lineno, 1);
             }
         } ## end if (length $expr)
     } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
@@ -5067,7 +5059,7 @@ sub cmd_l {
         # - whether a line has a break or not
         # - whether a line has an action or not
         else {
-            while ($i <= $end) {
+            for ( ; $i <= $end ; $i++ ) {
 
                 # Check for breakpoints and actions.
                 my ( $stop, $action );
@@ -5090,10 +5082,7 @@ sub cmd_l {
 
                 # Move on to the next line. Drop out on an interrupt.
                 $i++, last if $signal;
-            }
-            continue {
-                $i++;
-            }## end while (; $i <= $end ; $i++)
+            } ## end for (; $i <= $end ; $i++)
 
             # Line the prompt up; print a newline if the last line listed
             # didn't have a newline.
@@ -5854,11 +5843,11 @@ sub dump_trace {
     # number of stack frames, or we run out - caller() returns nothing - we
     # quit.
     # Up the stack frame index to go back one more level each time.
-    {
-        my $i = $skip;
-    while (
+    for (
+        my $i = $skip ;
         $i < $count
-        and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i)
+        and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
+        $i++
     )
     {
 
@@ -5945,11 +5934,7 @@ sub dump_trace {
 
         # Stop processing frames if the user hit control-C.
         last if $signal;
-    } ## end while ($i)
-    continue {
-        $i++;
-    }
-    }
+    } ## end for ($i = $skip ; $i < ...
 
     # Restore the trace value again.
     $trace = $otrace;
diff --git a/lib/perl5db.t b/lib/perl5db.t
index 9276fad..10b87ad 100644
--- a/lib/perl5db.t
+++ b/lib/perl5db.t
@@ -28,7 +28,7 @@ BEGIN {
     }
 }
 
-plan(40);
+plan(73);
 
 my $rc_filename = '.perldb';
 
@@ -388,6 +388,13 @@ sub output_like {
     ::like($self->_output(), $re, $msg);
 }
 
+sub output_unlike {
+    my ($self, $re, $msg) = @_;
+
+    local $::Level = $::Level + 1;
+    ::unlike($self->_output(), $re, $msg);
+}
+
 sub contents_like {
     my ($self, $re, $msg) = @_;
 
@@ -395,6 +402,13 @@ sub contents_like {
     ::like($self->_contents(), $re, $msg);
 }
 
+sub contents_unlike {
+    my ($self, $re, $msg) = @_;
+
+    local $::Level = $::Level + 1;
+    ::unlike($self->_contents(), $re, $msg);
+}
+
 package main;
 
 # Testing that we can set a line in the middle of the file.
@@ -1097,6 +1111,539 @@ package main;
     );
 }
 
+# Test the L command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'b 6',
+                'b 13 ($q == 5)',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^\S*?eval-line-bug:\n
+        \s*6:\s*my\ \$i\ =\ 5;\n
+        \s*break\ if\ \(1\)\n
+        \s*13:\s*\$i\ \+=\ \$q;\n
+        \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
+        #msx,
+        "L command is listing breakpoints",
+    );
+}
+
+# Test the L command for watch expressions.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'w (5+6)',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^Watch-expressions:\n
+        \s*\(5\+6\)\n
+        #msx,
+        "L command is listing watch expressions",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'w (5+6)',
+                'w (11*23)',
+                'W (5+6)',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^Watch-expressions:\n
+        \s*\(11\*23\)\n
+        ^auto\(
+        #msx,
+        "L command is not listing deleted watch expressions",
+    );
+}
+
+# Test the L command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'b 6',
+                'a 13 print $i',
+                'L',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^\S*?eval-line-bug:\n
+        \s*6:\s*my\ \$i\ =\ 5;\n
+        \s*break\ if\ \(1\)\n
+        \s*13:\s*\$i\ \+=\ \$q;\n
+        \s*action:\s+print\ \$i\n
+        #msx,
+        "L command is listing actions and breakpoints",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'S',
+                'q',
+            ],
+            prog =>  '../lib/perl5db/t/rt-104168',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^main::bar\n
+        main::baz\n
+        main::foo\n
+        #msx,
+        "S command - 1",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'S ^main::ba',
+                'q',
+            ],
+            prog =>  '../lib/perl5db/t/rt-104168',
+        }
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^main::bar\n
+        main::baz\n
+        auto\(
+        #msx,
+        "S command with regex",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'S !^main::ba',
+                'q',
+            ],
+            prog =>  '../lib/perl5db/t/rt-104168',
+        }
+    );
+
+    $wrapper->contents_unlike(
+        qr#
+        ^main::ba
+        #msx,
+        "S command with negative regex",
+    );
+
+    $wrapper->contents_like(
+        qr#
+        ^main::foo\n
+        #msx,
+        "S command with negative regex - what it still matches",
+    );
+}
+
+# Test the a command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'a 13 print "\nVar<Q>=$q\n"',
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->output_like(qr#
+        \nVar<Q>=1\n
+        \nVar<Q>=2\n
+        \nVar<Q>=3\n
+        #msx,
+        "a command is working",
+    );
+}
+
+# Test the 'A' command
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'a 13 print "\nVar<Q>=$q\n"',
+                'A 13',
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->output_like(
+        qr#\A\z#msx, # The empty string.
+        "A command (for removing actions) is working",
+    );
+}
+
+# Test the 'A *' command
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'a 6 print "\nFail!\n"',
+                'a 13 print "\nVar<Q>=$q\n"',
+                'A *',
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/eval-line-bug',
+        }
+    );
+
+    $wrapper->output_like(
+        qr#\A\z#msx, # The empty string.
+        "'A *' command (for removing all actions) is working",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'n',
+                'w $foo',
+                'c',
+                'print "\nIDX=<$idx>\n"',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/test-w-statement-1',
+        }
+    );
+
+
+    $wrapper->contents_like(qr#
+        \$foo\ changed:\n
+        \s+old\ value:\s+'1'\n
+        \s+new\ value:\s+'2'\n
+        #msx,
+        'w command - watchpoint changed',
+    );
+    $wrapper->output_like(qr#
+        \nIDX=<20>\n
+        #msx,
+        "w command - correct output from IDX",
+    );
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'n',
+                'w $foo',
+                'W $foo',
+                'c',
+                'print "\nIDX=<$idx>\n"',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/test-w-statement-1',
+        }
+    );
+
+    $wrapper->contents_unlike(qr#
+        \$foo\ changed:
+        #msx,
+        'W command - watchpoint was deleted',
+    );
+
+    $wrapper->output_like(qr#
+        \nIDX=<>\n
+        #msx,
+        "W command - stopped at end.",
+    );
+}
+
+# Test the W * command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'n',
+                'w $foo',
+                'w ($foo*$foo)',
+                'W *',
+                'c',
+                'print "\nIDX=<$idx>\n"',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/test-w-statement-1',
+        }
+    );
+
+    $wrapper->contents_unlike(qr#
+        \$foo\ changed:
+        #msx,
+        '"W *" command - watchpoint was deleted',
+    );
+
+    $wrapper->output_like(qr#
+        \nIDX=<>\n
+        #msx,
+        '"W *" command - stopped at end.',
+    );
+}
+
+# Test the 'o' command (without further arguments).
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'o',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/test-w-statement-1',
+        }
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*warnLevel\ =\ '1'\n
+        #msx,
+        q#"o" command (without arguments) displays warnLevel#,
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*signalLevel\ =\ '1'\n
+        #msx,
+        q#"o" command (without arguments) displays signalLevel#,
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*dieLevel\ =\ '1'\n
+        #msx,
+        q#"o" command (without arguments) displays dieLevel#,
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*hashDepth\ =\ 'N/A'\n
+        #msx,
+        q#"o" command (without arguments) displays hashDepth#,
+    );
+}
+
+# Test the 'o' query command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'o hashDepth? signalLevel?',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/test-w-statement-1',
+        }
+    );
+
+    $wrapper->contents_unlike(qr#warnLevel#,
+        q#"o" query command does not display warnLevel#,
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*signalLevel\ =\ '1'\n
+        #msx,
+        q#"o" query command displays signalLevel#,
+    );
+
+    $wrapper->contents_unlike(qr#dieLevel#,
+        q#"o" query command does not display dieLevel#,
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*hashDepth\ =\ 'N/A'\n
+        #msx,
+        q#"o" query command displays hashDepth#,
+    );
+}
+
+# Test the 'o' set command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'o signalLevel=0',
+                'o',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/test-w-statement-1',
+        }
+    );
+
+    $wrapper->contents_like(qr/
+        ^\s*(signalLevel\ =\ '0'\n)
+        .*?
+        ^\s*\1
+        /msx,
+        q#o set command works#,
+    );
+
+    $wrapper->contents_like(qr#
+        ^\s*hashDepth\ =\ 'N/A'\n
+        #msx,
+        q#o set command - hashDepth#,
+    );
+}
+
+# Test the '<' and "< ?" commands.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                q/< print "\nX=<$x>\n"/,
+                q/b 7/,
+                q/< ?/,
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/disable-breakpoints-1',
+        }
+    );
+
+    $wrapper->contents_like(qr/
+        ^pre-perl\ commands:\n
+        \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
+        /msx,
+        q#Test < and < ? commands - contents.#,
+    );
+
+    $wrapper->output_like(qr#
+        ^X=<FirstVal>\n
+        #msx,
+        q#Test < and < ? commands - output.#,
+    );
+}
+
+# Test the '< *' command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                q/< print "\nX=<$x>\n"/,
+                q/b 7/,
+                q/< */,
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/disable-breakpoints-1',
+        }
+    );
+
+    $wrapper->output_unlike(qr/FirstVal/,
+        q#Test the '< *' command.#,
+    );
+}
+
+# Test the '>' and "> ?" commands.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                q/$::foo = 500;/,
+                q/> print "\nFOO=<$::foo>\n"/,
+                q/b 7/,
+                q/> ?/,
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/disable-breakpoints-1',
+        }
+    );
+
+    $wrapper->contents_like(qr/
+        ^post-perl\ commands:\n
+        \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
+        /msx,
+        q#Test > and > ? commands - contents.#,
+    );
+
+    $wrapper->output_like(qr#
+        ^FOO=<500>\n
+        #msx,
+        q#Test > and > ? commands - output.#,
+    );
+}
+
+# Test the '> *' command.
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                q/> print "\nFOO=<$::foo>\n"/,
+                q/b 7/,
+                q/> */,
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/disable-breakpoints-1',
+        }
+    );
+
+    $wrapper->output_unlike(qr/FOO=/,
+        q#Test the '> *' command.#,
+    );
+}
+
 END {
     1 while unlink ($rc_filename, $out_fn);
 }
diff --git a/lib/perl5db/t/test-w-statement-1 b/lib/perl5db/t/test-w-statement-1
new file mode 100644
index 0000000..bfd5ccd
--- /dev/null
+++ b/lib/perl5db/t/test-w-statement-1
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use vars qw($foo);
+
+$foo = 1;
+
+print "Hello\n";
+
+for my $idx (map { $_ * 10 } 1 .. 10)
+{
+    if ($idx > 17)
+    {
+        $foo = 2;
+        print "Baz\n";
+    }
+}
+

@p5pRT
Copy link
Author

p5pRT commented Sep 9, 2012

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Sep 11, 2012

From @rjbs

* Shlomi Fish via RT <perlbug-followup@​perl.org> [2012-09-09T12​:15​:43]

This is a more recent patcht hat can be applied instead of the previous
test. More tests were added, and I also fixed a problem with the
debugger actions that was reported on p5p.

What are you using to generate your patches?

It doesn't seem to be git-format-patch. Could you please use that in the
future? It will allow us to apply your patches without having to then commit
them with --author, etc.

If you would like some realtime help in sorting out your repo so that we can
just pull from you, I would be happy to assist you sometime on IRC or via the
list.

--
rjbs

@p5pRT
Copy link
Author

p5pRT commented Sep 11, 2012

From @rjbs

Thanks, applied as 72d7d80.

@p5pRT
Copy link
Author

p5pRT commented Sep 11, 2012

From [Unknown Contact. See original ticket]

Thanks, applied as 72d7d80.

@p5pRT
Copy link
Author

p5pRT commented Sep 11, 2012

@rjbs - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
Projects
None yet
Development

No branches or pull requests

1 participant