Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Code for blog post on pattern searching
dummy:
test:
sh test.sh | diff - test.out
#!/usr/bin/perl
# Copyright 2012 Jeffrey Kegler
# This file is part of Marpa::R2. Marpa::R2 is free software: you can
# redistribute it and/or modify it under the terms of the GNU Lesser
# General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# Marpa::R2 is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser
# General Public License along with Marpa::R2. If not, see
# http://www.gnu.org/licenses/.
use 5.010;
use strict;
use warnings;
use English qw( -no_match_vars );
use Getopt::Long;
use Marpa::R2 2.024000;
sub usage {
die <<"END_OF_USAGE_MESSAGE";
$PROGRAM_NAME [-n] 'exp'
$PROGRAM_NAME [-n] < file
END_OF_USAGE_MESSAGE
} ## end sub usage
my $show_position_flag;
my $getopt_result = GetOptions( "n!" => \$show_position_flag, );
usage() if not $getopt_result;
my $string = join q{}, <>;
my $target_grammar = Marpa::R2::Grammar->new(
{ start => 'start',
rules => [ <<'END_OF_RULES' ]
start ::= prefix target
prefix ::= any_token*
target ::= expression
expression ::=
number | scalar | scalar postfix_op
|| op_lparen expression op_rparen assoc => group
|| unop expression
|| expression binop expression
END_OF_RULES
}
);
$target_grammar->precompute();
# Order matters !!
my @lexer_table = (
[ number => qr/(?:\d+(?:\.\d*)?|\.\d+)/xms ],
[ scalar => qr/ [\$] \w+ \b/xms ],
[ postfix_op => qr/ [-][-] | [+][+] /xms ],
[ unop => qr/ [-][-] | [+][+] /xms ],
[ binop => qr/
[*][*] | [>][>] | [<][<]
| [*] | [\/] | [%] | [x] \b
| [+] | [-] | [&] | [|] | [=] | [,]
/xms
],
[ unop => qr/ [-] | [+] | [!] | [~] /xms
],
[ op_lparen => qr/[(]/xms ],
[ op_rparen => qr/[)]/xms ],
);
sub My_Error::last_completed_range {
my ( $self, $symbol_name, $latest_earley_set ) = @_;
my $grammar = $self->{grammar};
my $recce = $self->{recce};
my @sought_rules = ();
for my $rule_id ( $grammar->rule_ids() ) {
my ($lhs) = $grammar->bnf_rule($rule_id);
push @sought_rules, $rule_id if $lhs eq $symbol_name;
}
die "Looking for completion of non-existent rule lhs: $symbol_name"
if not scalar @sought_rules;
$latest_earley_set //= $recce->latest_earley_set();
my $earley_set = $latest_earley_set;
# Initialize to one past the end, so we can tell if there were no hits
my $first_origin = $latest_earley_set + 1;
EARLEY_SET: while ( $earley_set >= 0 ) {
my $report_items = $recce->progress($earley_set);
ITEM: for my $report_item ( @{$report_items} ) {
my ( $rule_id, $dot_position, $origin ) = @{$report_item};
next ITEM if $dot_position != -1;
next ITEM if not scalar grep { $_ == $rule_id } @sought_rules;
next ITEM if $origin >= $first_origin;
$first_origin = $origin;
} ## end ITEM: for my $report_item ( @{$report_items} )
last EARLEY_SET if $first_origin <= $latest_earley_set;
$earley_set--;
} ## end EARLEY_SET: while ( $earley_set >= 0 )
return if $earley_set < 0;
return ( $first_origin, $earley_set );
} ## end sub My_Error::last_completed_range
my @positions = (0);
my $recce = Marpa::R2::Recognizer->new( { grammar => $target_grammar, } );
# A quasi-object, for internal use only
my $self = bless {
grammar => $target_grammar,
input => \$string,
recce => $recce,
positions => \@positions
},
'My_Error';
my $length = length $string;
pos $string = $positions[-1];
TOKEN: while ( pos $string < $length ) {
# In this application, we do not skip comments --
# Expressions inside strings or commments may be of
# interest
next TOKEN if $string =~ m/\G\s+/gcxms; # skip whitespace
my $position = pos $string;
FIND_ALTERNATIVE: {
TOKEN_TYPE: for my $t (@lexer_table) {
my ( $token_name, $regex ) = @{$t};
next TOKEN_TYPE if not $string =~ m/\G($regex)/gcxms;
if ( not defined $recce->alternative($token_name) ) {
pos $string = $position; # reset position for matching
next TOKEN_TYPE;
}
$recce->alternative('any_token');
last FIND_ALTERNATIVE;
} ## end TOKEN_TYPE: for my $t (@lexer_table)
## Nothing in the lexer table matched
## Just read the currrent character as an 'any_token'
pos $string = $position + 1;
$recce->alternative('any_token');
} ## end FIND_ALTERNATIVE:
$recce->earleme_complete();
my $latest_earley_set_ID = $recce->latest_earley_set();
$positions[$latest_earley_set_ID] = pos $string;
} ## end TOKEN: while ( pos $string < $length )
# Given a string, an earley set to position mapping,
# and two earley sets, return the slice of the string
sub My_Error::input_slice {
my ( $self, $start, $end ) = @_;
my $positions = $self->{positions};
return if not defined $start;
my $start_position = $positions->[$start];
my $length = $positions->[$end] - $start_position;
return substr ${ $self->{input} }, $start_position, $length;
} ## end sub My_Error::input_slice
my $end_of_search;
my @results = ();
RESULTS: while (1) {
my ( $origin, $end ) =
$self->last_completed_range( 'target', $end_of_search );
last RESULTS if not defined $origin;
push @results, [ $origin, $end ];
$end_of_search = $origin;
} ## end RESULTS: while (1)
for my $result ( reverse @results ) {
my ( $origin, $end ) = @{$result};
my $slice = $self->input_slice( $origin, $end );
$slice =~ s/ \A \s* //xms;
$slice =~ s/ \s* \z //xms;
$slice =~ s/ \n / /gxms;
$slice =~ s/ \s+ / /gxms;
print qq{$origin-$end: } if $show_position_flag;
say $slice;
} ## end for my $result ( reverse @results )
# vim: expandtab shiftwidth=4:
@ary = (1, 3, sort 4, 2);
print @ary; # prints 1324
# These evaluate exit before doing the print:
print($foo, exit); # Obviously not what you want.
print $foo, exit; # Nor is this.
# These do the print before evaluating exit:
(print $foo), exit; # This is what you want.
print($foo), exit; # Or this.
print ($foo), exit; # Or even this.
print ($foo & 255) + 1, "\n";
1 + 1, "\n"; # Obviously not what you meant.
print(($foo & 255) + 1, "\n");
$i = 0; $j = 0;
print $i++; # prints 0
print ++$j; # prints 1
$i = $i ++;
print ++ $i + $i ++;
print ++($foo = '99'); # prints '100'
print ++($foo = 'a0'); # prints 'a1'
print ++($foo = 'Az'); # prints 'Ba'
print ++($foo = 'zz'); # prints 'aaa'
'\\' =~ q'\\';
print '-' x 80; # print row of dashes
print "\t" x ($tab/8), ' ' x ($tab%8); # tab over
@ones = (1) x 80; # a list of 80 1's
@ones = (5) x @ones; # set all elements to 5
chdir $foo || die; # (chdir $foo) || die
chdir($foo) || die; # (chdir $foo) || die
chdir ($foo) || die; # (chdir $foo) || die
chdir +($foo) || die; # (chdir $foo) || die
chdir $foo * 20; # chdir ($foo * 20)
chdir($foo) * 20; # (chdir $foo) * 20
chdir ($foo) * 20; # (chdir $foo) * 20
chdir +($foo) * 20; # chdir ($foo * 20)
rand 10 * 20; # rand (10 * 20)
rand(10) * 20; # (rand 10) * 20
rand (10) * 20; # (rand 10) * 20
rand +(10) * 20; # rand (10 * 20)
perl -le '$a = "NaN"; print "No NaN support here" if $a == $a'
perl -le '$a = "NaN"; print "NaN support here" if $a != $a'
print "Even\n" if ($x & 1) == 0;
print "false\n" if (8 | 2) != 10;
@a = @b || @c; # this is wrong
@a = scalar(@b) || @c; # really meant this
@a = @b ? @b : @c; # this works fine, though
$a = $ok ? @b : @c; # oops, that's just a count!
($a_or_b ? $a : $b) = $c;
$a % 2 ? $a += 10 : $a += 2
(($a % 2) ? ($a += 10) : $a) += 2
($a % 2) ? ($a += 10) : ($a += 2)
$a += ($a % 2) ? 10 : 2;
$a += 2;
$a = $a + 2;
($tmp = $global) =~ tr [A-Z] [a-z];
($a += 2) *= 3;
$a += 2;
$a *= 3;
use constant FOO => "something";
my %h = ( FOO => 23 );
my %h = ("FOO", 23);
my %h = ("something", 23);
%hash = ( $key => $value );
login( $username => $password );
open HANDLE, "filename"
or die "Can't open: $!\n";
print FH $data or die "Can't write to FH: $!";
$a = $b or $c; # bug: this is wrong
($a = $b) or $c; # really means this
$a = $b || $c; # better written this way
$foo = 150 | 105; # yields 255 (0x96 | 0x69 is 0xFF)
$foo = '150' | 105; # yields 255
$foo = 150 | '105'; # yields 255
$foo = '150' | '105'; # yields string '155' (under ASCII)
$baz = 0+$foo & 0+$bar; # both ops explicitly numeric
$biz = "$foo" ^ "$bar"; # both ops explicitly stringy
use integer;
no integer;
printf "%.20g\n", 123456789123456789;
# produces 123456789123456784
$x = Math::BigInt->new('123456789123456789');
print $x * $x;
# prints +15241578780673678515622620750190521
===
In: @ary = (1, 3, sort 4, 2);
Found:
1, 3
4, 2
===
In: print @ary; # prints 1324
Found:
1324
===
In: # These evaluate exit before doing the print:
Found:
===
In: print($foo, exit); # Obviously not what you want.
Found:
$foo
===
In: print $foo, exit; # Nor is this.
Found:
$foo
===
In: # These do the print before evaluating exit:
Found:
===
In: (print $foo), exit; # This is what you want.
Found:
$foo
===
In: print($foo), exit; # Or this.
Found:
($foo)
===
In: print ($foo), exit; # Or even this.
Found:
($foo)
===
In: print ($foo & 255) + 1, "n";
Found:
($foo & 255) + 1
===
In: 1 + 1, "n"; # Obviously not what you meant.
Found:
1 + 1
===
In: print(($foo & 255) + 1, "n");
Found:
($foo & 255) + 1
===
In: $i = 0; $j = 0;
Found:
$i = 0
$j = 0
===
In: print $i++; # prints 0
Found:
$i++
0
===
In: print ++$j; # prints 1
Found:
++$j
1
===
In: $i = $i ++;
Found:
$i = $i ++
===
In: print ++ $i + $i ++;
Found:
++ $i + $i ++
===
In: print ++($foo = '99'); # prints '100'
Found:
$foo
99
100
===
In: print ++($foo = 'a0'); # prints 'a1'
Found:
$foo
0
1
===
In: print ++($foo = 'Az'); # prints 'Ba'
Found:
$foo
===
In: print ++($foo = 'zz'); # prints 'aaa'
Found:
$foo
===
In: '\' =~ q'\';
Found:
===
In: print '-' x 80; # print row of dashes
Found:
80
===
In: print "t" x ($tab/8), ' ' x ($tab%8); # tab over
Found:
($tab/8)
($tab%8)
===
In: @ones = (1) x 80; # a list of 80 1's
Found:
(1) x 80
80
1
===
In: @ones = (5) x @ones; # set all elements to 5
Found:
(5)
5
===
In: chdir $foo || die; # (chdir $foo) || die
Found:
$foo
$foo
===
In: chdir($foo) || die; # (chdir $foo) || die
Found:
($foo)
$foo
===
In: chdir ($foo) || die; # (chdir $foo) || die
Found:
($foo)
$foo
===
In: chdir +($foo) || die; # (chdir $foo) || die
Found:
+($foo)
$foo
===
In: chdir $foo * 20; # chdir ($foo * 20)
Found:
$foo * 20
($foo * 20)
===
In: chdir($foo) * 20; # (chdir $foo) * 20
Found:
($foo) * 20
$foo
20
===
In: chdir ($foo) * 20; # (chdir $foo) * 20
Found:
($foo) * 20
$foo
20
===
In: chdir +($foo) * 20; # chdir ($foo * 20)
Found:
+($foo) * 20
($foo * 20)
===
In: rand 10 * 20; # rand (10 * 20)
Found:
10 * 20
(10 * 20)
===
In: rand(10) * 20; # (rand 10) * 20
Found:
(10) * 20
10
20
===
In: rand (10) * 20; # (rand 10) * 20
Found:
(10) * 20
10
20
===
In: rand +(10) * 20; # rand (10 * 20)
Found:
+(10) * 20
(10 * 20)
===
In: perl -le '$a = "NaN"; print "No NaN support here" if $a == $a'
Found:
$a
$a
$a
===
In: perl -le '$a = "NaN"; print "NaN support here" if $a != $a'
Found:
$a
$a
$a
===
In: print "Evenn" if ($x & 1) == 0;
Found:
($x & 1)
0
===
In: print "falsen" if (8 | 2) != 10;
Found:
(8 | 2)
10
===
In: @a = @b || @c; # this is wrong
Found:
===
In: @a = scalar(@b) || @c; # really meant this
Found:
===
In: @a = @b ? @b : @c; # this works fine, though
Found:
===
In: $a = $ok ? @b : @c; # oops, that's just a count!
Found:
$a = $ok
===
In: ($a_or_b ? $a : $b) = $c;
Found:
$a_or_b
$a
$b
$c
===
In: $a % 2 ? $a += 10 : $a += 2
Found:
$a % 2
$a
10
$a
2
===
In: (($a % 2) ? ($a += 10) : $a) += 2
Found:
($a % 2)
$a
10
$a
2
===
In: ($a % 2) ? ($a += 10) : ($a += 2)
Found:
($a % 2)
$a
10
$a
2
===
In: $a += ($a % 2) ? 10 : 2;
Found:
$a
($a % 2)
10
2
===
In: $a += 2;
Found:
$a
2
===
In: $a = $a + 2;
Found:
$a = $a + 2
===
In: ($tmp = $global) =~ tr [A-Z] [a-z];
Found:
($tmp = $global)
===
In: ($a += 2) *= 3;
Found:
$a
2
3
===
In: $a += 2;
Found:
$a
2
===
In: $a *= 3;
Found:
$a
3
===
In: use constant FOO => "something";
Found:
===
In: my %h = ( FOO => 23 );
Found:
23
===
In: my %h = ("FOO", 23);
Found:
23
===
In: my %h = ("something", 23);
Found:
23
===
In: %hash = ( $key => $value );
Found:
$key
$value
===
In: login( $username => $password );
Found:
$username
$password
===
In: open HANDLE, "filename"
Found:
===
In: or die "Can't open: $!n";
Found:
===
In: print FH $data or die "Can't write to FH: $!";
Found:
$data
===
In: $a = $b or $c; # bug: this is wrong
Found:
$a = $b
$c
===
In: ($a = $b) or $c; # really means this
Found:
($a = $b)
$c
===
In: $a = $b || $c; # better written this way
Found:
$a = $b
$c
===
In: $foo = 150 | 105; # yields 255 (0x96 | 0x69 is 0xFF)
Found:
$foo = 150 | 105
255
0
96 | 0
69
0
===
In: $foo = '150' | 105; # yields 255
Found:
$foo
150
105
255
===
In: $foo = 150 | '105'; # yields 255
Found:
$foo = 150
105
255
===
In: $foo = '150' | '105'; # yields string '155' (under ASCII)
Found:
$foo
150
105
155
===
In: $baz = 0+$foo & 0+$bar; # both ops explicitly numeric
Found:
$baz = 0+$foo & 0+$bar
===
In: $biz = "$foo" ^ "$bar"; # both ops explicitly stringy
Found:
$biz
$foo
$bar
===
In: use integer;
Found:
===
In: no integer;
Found:
===
In: printf "%.20gn", 123456789123456789;
Found:
.20
123456789123456789
===
In: # produces 123456789123456784
Found:
123456789123456784
===
In: $x = Math::BigInt->new('123456789123456789');
Found:
$x
123456789123456789
===
In: print $x * $x;
Found:
$x * $x
===
In: # prints +15241578780673678515622620750190521
Found:
+15241578780673678515622620750190521
cat test.in | while read f
do echo "==="
echo "In: $f"
echo "Found:"
echo "$f" | perl search.pl
done
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.