mirror of
https://github.com/pragma-/pbot.git
synced 2024-11-16 08:59:34 +01:00
131 lines
3.7 KiB
Perl
Executable File
131 lines
3.7 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# SPDX-FileCopyrightText: 2014-2023 Pragmatic Software <pragma78@gmail.com>
|
|
# SPDX-License-Identifier: MIT
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use lib '.';
|
|
|
|
use Parse::RecDescent;
|
|
use Getopt::Std;
|
|
|
|
sub precompile_grammar {
|
|
print STDERR "Precompiling grammar...\n";
|
|
open GRAMMAR, 'CGrammar.pm' or die "Could not open CGrammar.pm: $!";
|
|
local $/;
|
|
my $grammar = <GRAMMAR>;
|
|
close GRAMMAR;
|
|
Parse::RecDescent->Precompile($grammar, "PCGrammar") or die "Could not precompile: $!";
|
|
}
|
|
|
|
sub flatten {
|
|
map { ref eq 'ARRAY' ? flatten(@$_) : $_ } @_
|
|
}
|
|
|
|
sub isfalse {
|
|
istrue($_[0], 'zero')
|
|
}
|
|
|
|
sub istrue {
|
|
my @parts = split /(?<!,) and /, $_[0];
|
|
my $truthy = defined $_[1] ? $_[1] : 'nonzero';
|
|
my ($result, $and) = ('', '');
|
|
foreach my $part (@parts) {
|
|
$result .= $and;
|
|
if($part !~ /(discard the result|result discarded|greater|less|equal|false$)/) {
|
|
$result .= "$part is $truthy";
|
|
} else {
|
|
$result .= $part;
|
|
}
|
|
$and = ' and ';
|
|
}
|
|
$result =~ s/is $truthy and the result discarded/is evaluated and the result discarded/g;
|
|
$result =~ s/is ((?:(?!evaluated).)+) and the result discarded/is evaluated to be $1 and the result discarded/g;
|
|
return $result;
|
|
}
|
|
|
|
sub main {
|
|
my %opts;
|
|
|
|
getopts('TPo:', \%opts);
|
|
|
|
|
|
if ($opts{T}) {
|
|
print STDERR "Tracing enabled.\n";
|
|
$::RD_TRACE = 1;
|
|
}
|
|
|
|
$::RD_HINT = 1;
|
|
$Parse::RecDescent::skip = '\s*';
|
|
|
|
my $parser;
|
|
|
|
if ($opts{P} or !eval { require PCGrammar }) {
|
|
precompile_grammar();
|
|
require PCGrammar;
|
|
}
|
|
|
|
$parser = PCGrammar->new or die "Bad grammar!\n";
|
|
|
|
if ($opts{o}) {
|
|
open(OUTFILE, ">>$opts{o}");
|
|
*STDOUT = *OUTFILE{IO};
|
|
}
|
|
|
|
my $text;
|
|
|
|
foreach my $arg (@ARGV) {
|
|
print STDERR "Opening file $arg\n";
|
|
|
|
open(CFILE, "$arg") or die "Could not open $arg.\n";
|
|
local $/;
|
|
$text = <CFILE>;
|
|
close(CFILE);
|
|
|
|
print STDERR "parsing...\n";
|
|
|
|
my $result = $parser->startrule(\$text) or die "Bad text!\n$text\n";
|
|
|
|
$text =~ s/^\s+|\s+$//g;
|
|
|
|
if(length $text) {
|
|
print "Bad parse at: $text";
|
|
} else {
|
|
my $output = join('', flatten($result));
|
|
|
|
# beautification
|
|
my @quotes;
|
|
$output =~ s/(?:\"((?:\\\"|(?!\").)*)\")/push @quotes, $1; '"' . ('-' x length $1) . '"'/ge;
|
|
|
|
$output =~ s/\ban un/a un/g;
|
|
$output =~ s/\ban UTF/a UTF/g;
|
|
$output =~ s/the value the expression/the value of the expression/g;
|
|
$output =~ s/the value the member/the value of the member/g;
|
|
$output =~ s/the value the/the/g;
|
|
$output =~ s/of evaluate/of/g;
|
|
$output =~ s/the evaluate the/the/g;
|
|
$output =~ s/by evaluate the/by the/g;
|
|
$output =~ s/the a /the /g;
|
|
$output =~ s/Then if it has the value/If it has the value/g;
|
|
$output =~ s/result of the expression a generic-selection/result of a generic-selection/g;
|
|
$output =~ s/the result of the expression (an?) (16-bit character|32-bit character|wide character|UTF-8) string/$1 $2 string/gi;
|
|
$output =~ s/the function a generic-selection/the function resulting from a generic-selection/g;
|
|
$output =~ s/\.\s+Then exit switch block/ and then exit switch block/g;
|
|
$output =~ s/,\././g;
|
|
$output =~ s/of unspecified length //g;
|
|
while($output =~ s/const const/const/g){};
|
|
|
|
foreach my $quote (@quotes) {
|
|
next unless $quote;
|
|
$output =~ s/"-+"/"$quote"/;
|
|
}
|
|
|
|
print $output;
|
|
}
|
|
}
|
|
}
|
|
|
|
main;
|