Permalink
Browse files

Try a better from of syntax checking. Many thanks to cpansprout for t…

…he suggestion.
  • Loading branch information...
Rocky Bernstein
Rocky Bernstein committed Sep 5, 2012
1 parent a0cb5f5 commit 0067b6ce3faf5626f7ccba26cfb942e76c05fb03
@@ -25,10 +25,10 @@ use strict; use vars qw(@ISA); @ISA = @CMD_ISA;
use vars @CMD_VARS; # Value inherited from parent
our $NAME = set_name();
-our $HELP = <<"HELP";
+our $HELP = <<'HELP';
=pod
-${NAME} I<bp-number> I<perl-expression>
+condition I<bp-number> I<perl-expression>
I<bp-number> is a breakpoint number. I<perl-expresion> is a Perl
expression which must evaluate to true before the breakpoint is
@@ -37,8 +37,8 @@ i.e., the breakpoint is made unconditional.
=head2 Examples:
- ${NAME} 5 x > 10 # Breakpoint 5 now has condition x > 10
- ${NAME} 5 # Remove above condition
+ condition 5 x > 10 # Breakpoint 5 now has condition x > 10
+ condition 5 # Remove above condition
See also C<break>, C<enable> and C<disable>.
=cut
@@ -61,8 +61,11 @@ sub run($$) {
my @args = @{$args};
shift @args; shift @args;
$condition = join(' ', @args);
- unless (is_valid_condition($condition)) {
+ my $msg = &DB::eval_not_ok($condition);
+ if ($msg) {
$proc->errmsg("Invalid condition: $condition");
+ chomp $msg;
+ $proc->errmsg($msg);
return
}
} else {
@@ -1,5 +1,8 @@
# -*- coding: utf-8 -*-
# Copyright (C) 2011 Rocky Bernstein <rocky@cpan.org>
+# NOTE: this does syntax checking and has problems on MS Windows.
+# More specific context checking can be had in DB::Eval::eval_not_ok()
+# and that is gnereally (I think) we will be using.
use strict; use warnings;
package Devel::Trepan::Condition;
use English qw( -no_match_vars );
@@ -101,4 +101,51 @@ sub eval_with_return {
}
}
}
+
+# Evaluate the argument and return 0 if there's no error.
+# If there is an error we return the error message.
+sub eval_not_ok ($)
+{
+ my $code = shift;
+ my $wrapped = sprintf "$DB::namespace_package; sub { $code }";
+ no strict;
+ eval $wrapped;
+ if ($@) {
+ my $msg = $@;
+ $msg =~ s/ at .* line \d+[.,]//g;
+ $msg =~ s/ at EOF$/ at end of string/;
+ return $msg;
+ } else {
+ return 0;
+ }
+}
+
+unless (caller) {
+ eval {
+ sub doit($) {
+ my $code = shift;
+ my $msg = eval_not_ok($code);
+ print "code: $code\n";
+ if ($msg) {
+ print "$msg";
+ } else {
+ print "code ok\n";
+ }
+ }
+ };
+
+ $DB::namespace_package = 'package DB;';
+ doit 'doit(1,2,3)';
+ doit "1+";
+ doit '$x+2';
+ doit "foo(";
+ doit '$foo =';
+ doit 'BEGIN { $x = 1; ';
+ doit 'package foo; 1';
+
+}
+
+# doit '$x = 1; __END__ $y=';
+
+
1;
View
@@ -50,4 +50,21 @@ is($DB::eval_result{'foo'}, 'bar');
my @keys = keys(%DB::eval_result);
is(scalar @keys, 2);
+sub test_code($$)
+{
+ my ($code, $is_good) = @_;
+ my $msg = DB::eval_not_ok($code);
+ ok (!$msg == $is_good, "${code}" . ($msg ? ": $msg" : ''));
+}
+
+$DB::namespace_package = 'package main;';
+test_code 'test_code(1,2)', 1;
+test_code 'test_code(1)', 0;
+test_code '$x+2', 1;
+test_code "foo(", 0;
+test_code '$foo =', 0;
+test_code 'BEGIN { $x = 1;', 0;
+test_code 'package foo; 1', 1;
+
+
done_testing;

0 comments on commit 0067b6c

Please sign in to comment.