Root/old-boom/parser.pl

1#!/usr/bin/perl
2
3use re 'eval';
4use IO::File;
5
6
7#
8# "sanitize" converts all "special" characters to underscores. This is used to
9# avoid part names that could conflict with other uses of meta-characters, such
10# as spaces or hash signs.
11#
12
13sub sanitize
14{
15    local (*s) = @_;
16    my $ok = '[^-a-zA-Z0-9._%,:()=+\/]';
17
18    print STDERR "converting special character(s) in $s\n" if $s =~ /$ok/;
19    $s =~ s/$ok/_/g;
20}
21
22
23sub skip
24{
25    # do nothing
26}
27
28
29#
30# "bom" populates the following global variable:
31#
32# $cmp{component-reference}[0] = value
33# $cmp{component-reference}[1] = footprint
34# $cmp{component-reference}[2] = field1
35# ...
36#
37
38sub bom
39{
40    if (/^#End Cmp/) {
41    $mode = *skip;
42    return;
43    }
44    die unless /^\|\s+(\S+)\s+/;
45    my $ref = $1;
46    my @f = split(/\s*;\s*/, $');
47    next if $f[0] eq "NC";
48    for (@f) {
49    s/\s+$//;
50    &sanitize(\$_);
51    }
52    $cmp{$ref} = [ @f ];
53}
54
55
56#
57# "equ" populates the following global variables:
58#
59# $id{item-number} = "namespace item-number"
60# This is used for heuristics that look up parts commonly referred to by
61# their part number.
62#
63# $eq{"namespace0 item-number0"}[] = ("namespace1 item-number1", ...)
64# List of all parts a given part is equivalent to.
65#
66
67sub equ
68{
69    my @f = split(/\s+/);
70    &sanitize(\$f[1]);
71    &sanitize(\$f[3]);
72    my $a = "$f[0] $f[1]";
73    my $b = "$f[2] $f[3]";
74    $id{$f[1]} = $a;
75    $id{$f[3]} = $b;
76    push @{ $eq{$a} }, $b;
77    push @{ $eq{$b} }, $a;
78}
79
80
81#
82# "inv" populates the following global variables:
83#
84# $id{item-number} = "namespace item-number"
85# This is used for heuristics that look up parts commonly referred to by
86# their part number.
87#
88# $inv{"namespace item-number"}[0] = items-in-stock
89# $inv{"namespace item-number"}[1] = currency
90# $inv{"namespace item-number"}[2] = order-quantity
91# $inv{"namespace item-number"}[3] = unit-price
92# [2] and [3] may repeat.
93#
94
95sub inv
96{
97    my @f = split(/\s+/);
98    &sanitize(\$f[1]);
99    my $id = "$f[0] $f[1]";
100    shift @f;
101    my $ref = shift @f;
102    die "duplicate inventory entry for \"$id\"" if defined $inv{$id};
103    $id{$ref} = $id;
104    $inv{$id} = [ @f ];
105    $inv{$id}[0] = 999999 unless defined $inv{$id}[0];
106    $inv{$id}[1] = "N/A" unless defined $inv{$id}[1];
107    $inv{$id}[2] = 1 unless defined $inv{$id}[2];
108    $inv{$id}[3] = 999999 unless defined $inv{$id}[3];
109}
110
111
112#
113# "par" populates the following global variables:
114#
115# $parts{component-ref}[0] = namespace
116# $parts{component-ref}[1] = item-number
117# [0] and [1] may repeat
118#
119# $want{"namespace item"} = number of times we may use the part. If multiple
120# parts are eligible for a component, each of them is counted as desirable
121# for each component.
122#
123# $comps{"namespace item"}{component-ref} = 1
124# Set of components a part may be used for.
125#
126
127sub par
128{
129    my @f = split(/\s+/);
130    my $ref = shift @f;
131    $parts{$ref} = [ @f ];
132    while (@f) {
133    my @id = splice(@f, 0, 2);
134    my $id = "$id[0] $id[1]";
135    $want{$id}++;
136    $comps{$id}{$ref} = 1;
137    }
138}
139
140
141#
142# "chr" populates the following global variable:
143#
144# $chr{"namespace item-number"}{parameter} = value
145#
146# $last is used internally for continuation lines.
147#
148
149sub chr
150{
151    my @f;
152    if (/^\s+/) {
153    @f = split(/\s+/, $');
154    } else {
155    @f = split(/\s+/);
156    my $ref = shift @f;
157    my $num = shift @f;
158    $last = "$ref $num";
159    }
160    for (@f) {
161    die "\"=\" missing in $_" unless /=/;
162    $chr{$last}{uc($`)} = $';
163    }
164}
165
166
167#
168# "sub" populates the following global variables:
169#
170# $end[rule-number] = 0 / 1
171# $match[rule-number]{field}[0] = original-pattern
172# $match[rule-number]{field}[1] = RE1
173# $match[rule-number]{field}[2] = RE2
174# $action[rule-number]{field} = value
175#
176# $match_stack[depth]{field}[0] = original-pattern
177# $match_stack[depth]{field}[1] = RE1
178# $match_stack[depth]{field}[2] = RE2
179# $action_stack[depth]{field} = value
180# $may_cont = 0 / 1
181# $last
182# $last_action
183#
184
185#
186# $cvn_from{internal-handle} = index
187# $cvn_to{internal-handle} = index
188# $cvn_unit{internal-handle} = unit-name
189# $cvn_num = internal-handle
190# $found{field-or-subfield} = string
191
192
193sub sub_pattern
194{
195    local ($field, $p) = @_;
196    my $n = 0;
197    $p =~ s/\./\\./g;
198    $p =~ s/\+/\\+/g;
199    $p =~ s/\?/./g;
200    $p =~ s/\*/.*/g;
201    my $tmp = "";
202    while ($p =~ /^([^\(]*)\(/) {
203    $n++;
204    $tmp .= "$1(?'${field}__$n'";
205    $p = $';
206    }
207    $p = "^".$tmp.$p."\$";
208    my $q = $p;
209    while ($p =~ /^([^\$]*)\$(.)/) {
210    $p = "$1(\\d+$2\\d*|\\d+[GMkmunpf$2]\\d*)(?{ &__cvn($cvn_num); })$'";
211    $cvn_unit{$cvn_num} = $2;
212    die unless $q =~ /^([^\$]*)\$(.)/;
213    $q = "$1(\\d+(\.\\d+)?[GMkmunpf]?$2)$'";
214    $cvn_num++;
215    }
216    return ($p, $q);
217}
218
219
220sub sub_value
221{
222    return $_[0];
223}
224
225
226sub sub
227{
228    /^(\s*)/;
229    my $indent = $1;
230    my @f = split(/\s+/, $');
231    my $f;
232    my $in = 0; # indentation level
233    while (length $indent) {
234    my $c = substr($indent, 0, 1, "");
235    if ($c eq " ") {
236        $in++;
237    } elsif ($c eq "\t") {
238        $in = ($in+8) & ~7;
239    } else {
240        die;
241    }
242    }
243    if ($may_cont && $in > $last) {
244    pop(@match);
245    pop(@action);
246    pop(@end);
247    } else {
248    $match_stack[0] = undef;
249    $action_stack[0] = undef;
250    $last_action = 0;
251    $last = $in;
252    }
253    if (!$last_action) {
254    while (@f) {
255        $f = shift @f;
256        last if $f eq "->" || $f eq "{" || $f eq "}" || $f eq "!";
257        if ($f =~ /=/) {
258        $match_stack[0]{uc($`)} = [ $', &sub_pattern(uc($`), $') ];
259        } else {
260        $match_stack[0]{"REF"} = [ &sub_pattern("REF", $f) ];
261        }
262    }
263    $last_action = 1 if $f eq "->";
264    }
265    if ($last_action) {
266    while (@f) {
267        $f = shift @f;
268        last if $f eq "{" || $f eq "!";
269        die unless $f =~ /=/;
270        $action_stack[0]{uc($`)} = &sub_value($');
271    }
272    }
273    $may_cont = 0;
274    if ($f eq "{") {
275    unshift(@match_stack, undef);
276    unshift(@action_stack, undef);
277    die "items following {" if @f;
278    } elsif ($f eq "}") {
279    shift @match_stack;
280    shift @action_stack;
281    die "items following }" if @f;
282    } else {
283    die "items following !" if @f && $f eq "!";
284    push(@end, $f eq "!");
285    $may_cont = $f ne "!";
286    my $n = $#end;
287    push(@match, undef);
288    push(@action, undef);
289    for my $m (reverse @match_stack) {
290        for (keys %{ $m }) {
291        $match[$n]{$_} = $m->{$_};
292        }
293    }
294    for my $a (reverse @action_stack) {
295        for (keys %{ $a }) {
296        $action[$n]{$_} = $a->{$_};
297        }
298    }
299    }
300}
301
302
303#
304# "ord" populates the following global variables:
305#
306# $order{"namespace item-number"}[0] = quantity to order
307# $order{"namespace item-number"}[1] = currency
308# $order{"namespace item-number"}[2] = total cost in above currency
309# $order{"namespace item-number"}[3] = component reference
310# ...
311#
312
313sub ord
314{
315    my @f = split(/\s+/);
316    my @id = splice(@f, 0, 2);
317    @{ $order{"$id[0] $id[1]"} } = @f;
318}
319
320
321#
322# "dsc" populates the following global variable:
323#
324# $dsc{"namespace item-number"} = description
325#
326
327sub dsc
328{
329    my @f = split(/\s+/);
330    my @id = splice(@f, 0, 2);
331    $dsc{"$id[0] $id[1]"} = join(" ", @f);
332}
333
334
335#
336# "eeschema" populates the following global variable:
337#
338# $eeschema[] = line
339#
340
341
342sub eeschema
343{
344    push(@eeschema, $_[0]);
345    if ($_[0] =~ /^\$EndSCHEMATC/) {
346    $mode = *skip;
347    undef $raw;
348    }
349}
350
351
352sub babylonic
353{
354    if ($_[0] =~ /^#/) {
355    $hash++;
356    if ($hash == 2) {
357        $mode = *skip;
358        undef $raw;
359    }
360    return;
361    }
362    &bom($_[0]) if $hash == 1;
363}
364
365
366sub dirname
367{
368    local ($name) = @_;
369
370    return $name =~ m|/[^/]*$| ? $` : ".";
371}
372
373
374sub rel_path
375{
376    local ($cwd, $path) = @_;
377
378    return $path =~ m|^/| ? $path : "$cwd/$path";
379}
380
381
382sub parse_one
383{
384    local ($name) = @_;
385
386    my $file = new IO::File->new($name) || die "$name: $!";
387    my $dir = &dirname($name);
388
389    while (1) {
390    $_ = <$file>;
391    if (!defined $_) {
392        $file->close();
393        return unless @inc;
394        $file = pop @inc;
395        $dir = pop @dir;
396        next;
397    }
398    if (/^\s*include\s+(.*?)\s*$/) {
399        push(@inc, $file);
400        push(@dir, $dir);
401        $name = &rel_path($dir, $1);
402        $dir = &dirname($name);
403        $file = new IO::File->new($name) || die "$name: $!";
404        next;
405    }
406    chop;
407
408# ----- KiCad BOM parsing. Alas, the BOM is localized, so there are almost no
409# reliable clues for the parser. Below would be good clues for the English
410# version:
411    if (0 && /^#Cmp.*order = Reference/) {
412        $mode = *bom;
413        next;
414    }
415    if (0 && /^#Cmp.*order = Value/) {
416        $mode = *skip;
417        next;
418    }
419    if (0 && /^eeschema \(/) { # hack to allow loading in any order
420        $mode = *skip;
421        next;
422    }
423# ----- now an attempt at a "generic" version:
424    if (/^eeschema \(/) {
425        $mode = *babylonic;
426        $hash = 0;
427        $raw = 1;
428        next;
429    }
430# -----
431    if (/^EESchema Schematic/) {
432        $mode = *eeschema;
433        $raw = 1;
434        die "only one schematic allowed" if defined @eeschema;
435        &eeschema($_);
436        next;
437    }
438    if (/^#EQU\b/) {
439        $mode = *equ;
440        next;
441    }
442    if (/^#INV\b/) {
443        $mode = *inv;
444        next;
445    }
446    if (/^#PAR\b/) {
447        $mode = *par;
448        next;
449    }
450    if (/^#CHR\b/) {
451        $mode = *chr;
452        undef $last;
453        next;
454    }
455    if (/^#(SUB|GEN)\b/) {
456        $mode = *sub;
457        undef $last;
458        undef $last_action;
459        undef $may_cont;
460        next;
461    }
462    if (/^#ORD\b/) {
463        $mode = *ord;
464        next;
465    }
466    if (/^#DSC\b/) {
467        $mode = *dsc;
468        next;
469    }
470    if (/^#END\b\(/) { # for commenting things out
471        $mode = *skip;
472        next;
473    }
474    if (!$raw) {
475        s/#.*//;
476        next if /^\s*$/;
477    }
478    &$mode($_);
479    }
480}
481
482
483sub parse
484{
485    $mode = *skip;
486    for (@ARGV) {
487    &parse_one($_);
488    }
489}
490
491#
492# in case user calls directly &parse_one and not &parse
493#
494$mode = *skip;
495
496return 1;
497

Archive Download this file

Branches:
master



interactive