Root/old-boom/match.pl

1#!/usr/bin/perl
2
3use re 'eval';
4
5
6#
7# "sub" populates the following global variables:
8#
9# $end[rule-number] = 0 / 1
10# $match[rule-number]{field}[0] = original-pattern
11# $match[rule-number]{field}[1] = RE1
12# $match[rule-number]{field}[2] = RE2
13# $action[rule-number]{field} = value
14#
15# $match_stack[depth]{field}[0] = original-pattern
16# $match_stack[depth]{field}[1] = RE1
17# $match_stack[depth]{field}[2] = RE2
18# $action_stack[depth]{field} = value
19# $may_cont = 0 / 1
20# $last
21# $last_action
22#
23
24#
25# $cvn_from{internal-handle} = index
26# $cvn_to{internal-handle} = index
27# $cvn_unit{internal-handle} = unit-name
28# $cvn_num = internal-handle
29# $found{field-or-subfield} = string
30
31
32#
33# We convert each input pattern into two regular expressions: the first matches
34# units in the nXn notation, e.g., 4u7 or 100R. The second matches them in SI
35# notation (sans space).
36#
37# When matching (sub_match), we first apply the first expression. Each time we
38# encounter a unit ($R, $F, etc.), __cvn is called. __cvn stores the index of
39# the unit in %cvn_from and %cvn_to.
40#
41# We then pick these substrings from the input string and convert the units to
42# SI notation. At the same time, we normalize the mantissa. Once done, we run
43# the second expression. This one always matches (hopefully :-)
44#
45# All (...) ranges in the original pattern have been replaced with named
46# capture buffers in the second expression, so all these subfields are now
47# gathered in the $+ array. (The same also happened in the first pass, but we
48# ignore it.)
49#
50# Finally, when expanding a value (sub_expand), we look for $field and
51# $field:index, and expand accordingly.
52#
53
54
55sub __cvn
56{
57    local ($num) = @_;
58
59    $cvn_from{$num} = $-[$#-];
60    $cvn_to{$num} = $+[$#+];
61}
62
63
64sub sub_match
65{
66    local ($s, $field, $m1, $m2) = @_;
67
68    #
69    # Perform the first match and record where we saw $<unit> patterns.
70    #
71    undef %cvn_from;
72    undef %cvn_to;
73    return undef unless $s =~ $m1;
74
75    #
76    # Convert the unit patterns to almost-SI notation. (We don't put a space
77    # after the number, but the rest is SI-compliant.)
78    #
79    my $off = 0;
80    for (keys %cvn_from) {
81    my $unit = $cvn_unit{$_};
82    my $from = $cvn_from{$_}+$off;
83    my $len = $cvn_to{$_}-$cvn_from{$_};
84    die unless substr($s, $from, $len) =~
85        /(\d+)$unit(\d*)|(\d+)([GMkmunpf])(\d*)/;
86
87    #
88    # Normalize to \d+.\d*
89    #
90    my $v = "$1$3.$2$5";
91    my $exp = $4 eq "" ? " " : $4;
92
93    #
94    # Remove leading zeroes.
95    #
96    $v =~ s/^0*(\d+)/\1/;
97
98    #
99    # Mantissa must be < 1000.
100    # Do the math as string operation to avoid rounding errors.
101    #
102    while ($v =~ /(\d+)(\d{3})\./) {
103        $v = "$1.$2$'";
104        $exp =~ tr/GMk munpf/TGMk munp/;
105    }
106
107    #
108    # Mantissa must be >= 1.
109    #
110    while ($v =~ /\b0\.(\d+)/) {
111        if (length $1 < 3) {
112        $v = $1.("0" x (3-length $1)).".";
113        } else {
114        $v = substr($1, 0, 3).".".substr($1, 3);
115        }
116        $exp =~ tr/GMk munpf/Mk munpa/;
117    }
118
119    #
120    # Remove trailing zeroes
121    #
122    $v =~ s/(\.[1-9]*)0*/\1/;
123
124    $exp =~ s/ //;
125    $v =~ s/\.$//;
126    $v = $v.$exp.$unit;
127    $off += length($v)-$len;
128    substr($s, $from, $len, $v);
129    }
130
131    #
132    # Run the second match on the string to process any (...) patterns
133    #
134    $found{$field} = $s;
135    die $m2 unless $s =~ $m2;
136    for (keys %+) {
137    $found{$_} = $+{$_};
138    }
139    return $s;
140}
141
142
143sub sub_expand
144{
145    local ($s) = @_;
146
147    while ($s =~ /^([^\$]*)\$([A-Za-z_]\w*)(:(\d+))?|^([^\$]*)\${([A-Za-z_]\w*)(:(\d+))?}/) {
148    my $name = "$2$6";
149    $name .= "__$4$8" if defined($4) || defined($8);
150    if (!defined $found{$name}) {
151        die "don't know \"$name\"".
152          (defined $__match_error ?
153          " (processing \"$__match_error\")" : "");
154    }
155    $s = $1.$5.$found{$name}.$';
156    }
157    return $s;
158}
159
160
161#
162# return 0 if all rules have been exhausted, 1 if there was an explicit halt.
163#
164
165sub apply_rules
166{
167    RULE: for (my $i = 0; $i <= $#match; $i++) {
168    print STDERR "RULE #$i\n" if $debug;
169    %found = %field;
170    FIELD: for my $f (keys %{ $match[$i] }) {
171        my @f = $f ne "FN" ? ($f) :
172          ("F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9");
173        for (@f) {
174        print STDERR " MATCH $_=$match[$i]{$f}[0] " if $debug;
175        if (!defined $found{$_}) {
176            print STDERR "NO FIELD\n" if $debug;
177            next;
178        }
179        print STDERR "FIELD $found{$_} " if $debug;
180        if (!defined &sub_match($found{$_}, $f,
181          $match[$i]{$f}[1], $match[$i]{$f}[2])) {
182            print STDERR "MISS\n" if $debug;
183            next;
184        }
185        print STDERR "MATCH\n" if $debug;
186        next FIELD;
187        }
188        next RULE;
189    }
190    for (keys %{ $action[$i] }) {
191        my $s = &sub_expand($action[$i]{$_});
192        print STDERR " SET $_=$action[$i]{$_} => $s\n" if $debug;
193        $field{$_} = $s;
194    }
195    if ($end[$i]) {
196        print STDERR " END\n" if $debug;
197        return 1;
198    }
199    }
200    return 0;
201}
202
203
204sub match_set_error
205{
206    $__match_error = $_[0];
207}
208
209
210return 1;
211

Archive Download this file

Branches:
master



interactive