On 1/23/2011 5:11 AM, Michael Meskes wrote:
On Sat, Jan 22, 2011 at 08:40:13PM -0500, Andrew Dunstan wrote:
I think these really need to be rewritten from scratch. They look
like they were written by someone who never heard of Perl 5 (it's
only about 16 years old).
You might remember that we had this discussion before. The script was written
in awk and then translated to perl by a2p. We knew that this code was less than
optimal, but at least it works.
As I already said when the script was introduced, I would love to have a real
perl solution, but I'm not a perl programmer by any means.
Michael
I thought Kris was going to work on this, but saw no progress, and I was
bored the other day, so I started working on it.
Here is a parse.pl, with some major refactoring.
I named it with a 2 so I could run it beside the original and diff em:
time perl parse.pl . < ../../../backend/parser/gram.y > preproc.y
real 0m10.636s
user 0m8.793s
sys 0m0.050s
time perl parse2.pl . < ../../../backend/parser/gram.y > preproc2.y
real 0m0.289s
user 0m0.214s
sys 0m0.009s
diff preproc.y preproc2.y
I am sure there are new bugs. I have not run it on anything but 9.0.1.
Are there other .y files you might feed it? (something other than
backend/parser/gram.y?)
I touched pretty much everything, and I broke a few things and had to go
back and fix 'em, so it would not surprise me at all if there were still
a few bugs.
Anyway, feedback, suggestions, etc are welcomed. (oh, yeah, I probably
need to go add some documentation)
-Andy
#!/usr/bin/perl
# src/interfaces/ecpg/preproc/parse.pl
# parser generater for ecpg
# call with backend parser as stdin
#
# Copyright (c) 2007-2010, PostgreSQL Global Development Group
#
# Written by Mike Aubury <mike.aub...@aubit.com>
# Michael Meskes <mes...@postgresql.org>
#
# Placed under the same license as PostgreSQL.
#
use strict;
use warnings;
no warnings 'uninitialized';
my $path = shift @ARGV;
$path = "." unless $path;
my $copymode = 0;
my $brace_indent = 0;
my $yaccmode = 0;
my $header_included = 0;
my $feature_not_supported = 0;
my $tokenmode = 0;
my(%buff, $infield, $comment, %tokens, %addons );
my($stmt_mode, @fields);
my($line, $non_term_id);
# some token have to be replaced by other symbols
# either in the rule
my %replace_token = (
'BCONST' => 'ecpg_bconst',
'FCONST' => 'ecpg_fconst',
'Sconst' => 'ecpg_sconst',
'IDENT' => 'ecpg_ident',
'PARAM' => 'ecpg_param',
);
# or in the block
my %replace_string = (
'WITH_TIME' => 'with time',
'NULLS_FIRST' => 'nulls first',
'NULLS_LAST' => 'nulls last',
'TYPECAST' => '::',
'DOT_DOT' => '..',
'COLON_EQUALS' => ':=',
);
# specific replace_types for specific non-terminals - never include the ':'
# ECPG-only replace_types are defined in ecpg-replace_types
my %replace_types = (
'PrepareStmt' => '<prep>',
'opt_array_bounds' => '<index>',
# "ignore" means: do not create type and rules for this non-term-id
'stmtblock' => 'ignore',
'stmtmulti' => 'ignore',
'CreateAsStmt' => 'ignore',
'DeallocateStmt' => 'ignore',
'ColId' => 'ignore',
'type_function_name' => 'ignore',
'ColLabel' => 'ignore',
'Sconst' => 'ignore',
);
# these replace_line commands excise certain keywords from the core keyword
# lists. Be sure to account for these in ColLabel and related productions.
my %replace_line = (
'unreserved_keywordCONNECTION' => 'ignore',
'unreserved_keywordCURRENT_P' => 'ignore',
'unreserved_keywordDAY_P' => 'ignore',
'unreserved_keywordHOUR_P' => 'ignore',
'unreserved_keywordINPUT_P' => 'ignore',
'unreserved_keywordMINUTE_P' => 'ignore',
'unreserved_keywordMONTH_P' => 'ignore',
'unreserved_keywordSECOND_P' => 'ignore',
'unreserved_keywordYEAR_P' => 'ignore',
'col_name_keywordCHAR_P' => 'ignore',
'col_name_keywordINT_P' => 'ignore',
'col_name_keywordVALUES' => 'ignore',
'reserved_keywordTO' => 'ignore',
'reserved_keywordUNION' => 'ignore',
# some other production rules have to be ignored or replaced
'fetch_argsFORWARDopt_from_incursor_name' => 'ignore',
'fetch_argsBACKWARDopt_from_incursor_name' => 'ignore',
"opt_array_boundsopt_array_bounds'['Iconst']'" => 'ignore',
'VariableShowStmtSHOWvar_name' => 'SHOW var_name
ecpg_into',
'VariableShowStmtSHOWTIMEZONE' => 'SHOW TIME ZONE ecpg_into',
'VariableShowStmtSHOWTRANSACTIONISOLATIONLEVEL' => 'SHOW TRANSACTION
ISOLATION LEVEL ecpg_into',
'VariableShowStmtSHOWSESSIONAUTHORIZATION' => 'SHOW SESSION
AUTHORIZATION ecpg_into',
'returning_clauseRETURNINGtarget_list' => 'RETURNING target_list
ecpg_into',
'ExecuteStmtEXECUTEnameexecute_param_clause' => 'EXECUTE prepared_name
execute_param_clause execute_rest',
'ExecuteStmtCREATEOptTempTABLEcreate_as_targetASEXECUTEnameexecute_param_clause'
=>
'CREATE OptTemp TABLE create_as_target AS EXECUTE
prepared_name execute_param_clause',
'PrepareStmtPREPAREnameprep_type_clauseASPreparableStmt' =>
'PREPARE prepared_name prep_type_clause AS
PreparableStmt',
'var_nameColId' => 'ECPGColId',
);
preload_addons();
main();
dump_buffer('header');
dump_buffer('tokens');
dump_buffer('types');
dump_buffer('ecpgtype');
dump_buffer('orig_tokens');
print '%%', "\n";
print 'prog: statements;', "\n";
dump_buffer('rules');
include_file( 'trailer', 'ecpg.trailer' );
dump_buffer('trailer');
sub main
{
line: while (<>)
{
if (/ERRCODE_FEATURE_NOT_SUPPORTED/)
{
$feature_not_supported = 1;
next line;
}
chomp;
# comment out the line below to make the result file match
(blank line wise)
# the prior version.
#next if ($_ eq '');
# Dump the action for a rule -
# stmt_mode indicates if we are processing the 'stmt:'
# rule (mode==0 means normal, mode==1 means stmt:)
# flds are the fields to use. These may start with a '$' - in
# which case they are the result of a previous non-terminal
#
# if they dont start with a '$' then they are token name
#
# len is the number of fields in flds...
# leadin is the padding to apply at the beginning (just use for
formatting)
if (/^%%/) {
$tokenmode = 2;
$copymode = 1;
$yaccmode++;
$infield = 0;
}
my $prec = 0;
# Make sure any braces are split
s/{/ { /g;
s/}/ } /g;
# Any comments are split
s|\/\*| /* |g;
s|\*\/| */ |g;
# Now split the line into individual fields
my @arr = split(' ');
if ( $arr[0] eq '%token' && $tokenmode == 0 )
{
$tokenmode = 1;
include_file( 'tokens', 'ecpg.tokens' );
}
elsif ( $arr[0] eq '%type' && $header_included == 0 )
{
include_file( 'header', 'ecpg.header' );
include_file( 'ecpgtype', 'ecpg.type' );
$header_included = 1;
}
if ( $tokenmode == 1 )
{
my $str = '';
my $prior = '';
for my $a (@arr)
{
if ( $a eq '/*' )
{
$comment++;
next;
}
if ( $a eq '*/' )
{
$comment--;
next;
}
if ($comment)
{
next;
}
if ( substr( $a, 0, 1 ) eq '<' ) {
next;
# its a type
}
$tokens{ $a } = 1;
$str = $str . ' ' . $a;
if ( $a eq 'IDENT' && $prior eq '%nonassoc' )
{
# add two more tokens to the list
$str = $str . "\n%nonassoc
CSTRING\n%nonassoc UIDENT";
}
$prior = $a;
}
add_to_buffer( 'orig_tokens', $str );
next line;
}
# Dont worry about anything if we're not in the right section
of gram.y
if ( $yaccmode != 1 )
{
next line;
}
# Go through each field in turn
for (my $fieldIndexer = 0 ; $fieldIndexer < scalar(@arr) ;
$fieldIndexer++ )
{
if ( $arr[$fieldIndexer] eq '*/' && $comment )
{
$comment = 0;
next;
}
elsif ($comment)
{
next;
}
elsif ( $arr[$fieldIndexer] eq '/*' )
{
# start of a multiline comment
$comment = 1;
next;
}
elsif ( $arr[$fieldIndexer] eq '//' )
{
next line;
}
elsif ( $arr[$fieldIndexer] eq '}' )
{
$brace_indent--;
next;
}
elsif ( $arr[$fieldIndexer] eq '{' )
{
$brace_indent++;
next;
}
if ( $brace_indent > 0 )
{
next;
}
if ( $arr[$fieldIndexer] eq ';' )
{
if ($copymode)
{
if ( $infield )
{
dump_line( $stmt_mode, \@fields
);
}
add_to_buffer( 'rules', ";\n\n" );
}
else
{
$copymode = 1;
}
@fields = ();
$infield = 0;
$line = '';
next;
}
if ( $arr[$fieldIndexer] eq '|' )
{
if ($copymode)
{
if ( $infield )
{
$infield = $infield +
dump_line( $stmt_mode, \@fields );
}
if ( $infield > 1 )
{
$line = '| ';
}
}
@fields = ();
next;
}
if ( exists $replace_token{ $arr[$fieldIndexer] } )
{
$arr[$fieldIndexer] = $replace_token{
$arr[$fieldIndexer] };
}
# Are we looking at a declaration of a non-terminal ?
if ( ( $arr[$fieldIndexer] =~ /[A-Za-z0-9]+:/ )
|| $arr[ $fieldIndexer + 1 ] eq ':' )
{
$non_term_id = $arr[$fieldIndexer];
$non_term_id =~ tr/://d;
if ( not defined $replace_types{$non_term_id} )
{
$replace_types{$non_term_id} = '<str>';
$copymode = 1;
}
elsif ( $replace_types{$non_term_id} eq
'ignore' )
{
$copymode = 0;
$line = '';
next line;
}
$line = $line . ' ' . $arr[$fieldIndexer];
# Do we have the : attached already ?
# If yes, we'll have already printed the ':'
if ( !( $arr[$fieldIndexer] =~ '[A-Za-z0-9]+:'
) )
{
# Consume the ':' which is next...
$line = $line . ':';
$fieldIndexer++;
}
# Special mode?
if ( $non_term_id eq 'stmt' )
{
$stmt_mode = 1;
}
else
{
$stmt_mode = 0;
}
my $tstr = '%type ' .
$replace_types{$non_term_id} . ' ' . $non_term_id;
add_to_buffer( 'types', $tstr );
if ($copymode)
{
add_to_buffer( 'rules', $line );
}
$line = '';
@fields = ();
$infield = 1;
next;
}
elsif ($copymode) {
$line = $line . ' ' . $arr[$fieldIndexer];
}
if ( $arr[$fieldIndexer] eq '%prec' )
{
$prec = 1;
next;
}
if ( $copymode
&& !$prec
&& !$comment
&& length( $arr[$fieldIndexer] )
&& $infield )
{
if (
$arr[$fieldIndexer] ne 'Op'
&& ( $tokens{ $arr[$fieldIndexer] } > 0
|| $arr[$fieldIndexer] =~ /'.+'/ )
|| $stmt_mode == 1
)
{
my $S;
if ( exists $replace_string{
$arr[$fieldIndexer] } )
{
$S = $replace_string{
$arr[$fieldIndexer] };
}
else
{
$S = $arr[$fieldIndexer];
}
$S =~ s/_P//g;
$S =~ tr/'//d;
if ( $stmt_mode == 1 )
{
push(@fields, $S);
}
else
{
push(@fields, lc($S));
}
}
else
{
push(@fields, '$' .
(scalar(@fields)+1));
}
}
}
}
}
# append a file onto a buffer.
# Arguments: buffer_name, filename (without path)
sub include_file
{
my ($buffer, $filename) = @_;
my $full = "$path/$filename";
open(my $fh, '<', $full) or die;
while ( <$fh> )
{
chomp;
add_to_buffer( $buffer, $_ );
}
close($fh);
}
sub include_addon
{
my($buffer, $block, $fields, $stmt_mode) = @_;
my $rec = $addons{$block};
return 0 unless $rec;
if ( $rec->{type} eq 'rule' )
{
dump_fields( $stmt_mode, $fields, ' { ' );
}
elsif ( $rec->{type} eq 'addon' )
{
add_to_buffer( 'rules', ' { ' );
}
#add_to_buffer( $stream, $_ );
#We have an array to add to the buffer, we'll add it ourself instead of
#calling add_to_buffer, which does not know about arrays
push( @{ $buff{$buffer} }, @{ $rec->{lines} } );
if ( $rec->{type} eq 'addon' )
{
dump_fields( $stmt_mode, $fields, '' );
}
# if we added something (ie there are lines in our array), return 1
return 1 if (scalar(@{ $rec->{lines} }) > 0);
return 0;
}
# include_addon does this same thing, but does not call this
# sub... so if you change this, you need to fix include_addon too
# Pass: buffer_name, string_to_append
sub add_to_buffer
{
push( @{ $buff{$_[0]} }, "$_[1]\n" );
}
sub dump_buffer
{
my($buffer) = @_;
print '/* ', $buffer, ' */',"\n";
my $ref = $buff{$buffer};
print @$ref;
}
sub dump_fields
{
my ( $mode, $flds, $ln ) = @_;
my $len = scalar(@$flds);
if ( $mode == 0 )
{
#Normal
add_to_buffer( 'rules', $ln );
if ( $feature_not_supported == 1 )
{
# we found an unsupported feature, but we have to
# filter out ExecuteStmt: CREATE OptTemp TABLE ...
# because the warning there is only valid in some
situations
if ( $flds->[0] ne 'create' || $flds->[2] ne 'table' )
{
add_to_buffer( 'rules',
'mmerror(PARSE_ERROR, ET_WARNING,
"unsupported feature will be passed to server");'
);
}
$feature_not_supported = 0;
}
if ( $len == 0 )
{
# We have no fields ?
add_to_buffer( 'rules', ' $$=EMPTY; }' );
}
else
{
# Go through each field and try to 'aggregate' the
tokens
# into a single 'make_str' where possible
my @flds_new;
my $str;
for ( my $z = 0 ; $z < $len ; $z++ )
{
if ( substr( $flds->[$z], 0, 1 ) eq '$' )
{
push(@flds_new, $flds->[$z]);
next;
}
$str = $flds->[$z];
while (1)
{
if ( $z >= $len - 1 || substr( $flds->[
$z + 1 ], 0, 1 ) eq '$' )
{
# We're at the end...
push(@flds_new,
"make_str(\"$str\")");
last;
}
$z++;
$str = $str . ' ' . $flds->[$z];
}
}
# So - how many fields did we end up with ?
$len = scalar(@flds_new);
if ( $len == 1 )
{
# Straight assignement
$str = ' $$ = ' . $flds_new[0] . ';';
add_to_buffer( 'rules', $str );
}
else
{
# Need to concatenate the results to form
# our final string
$str = ' $$ = cat_str(' . $len . ',' .
join(',', @flds_new) . ');';
add_to_buffer( 'rules', $str );
}
add_to_buffer( 'rules', '}' );
}
}
else
{
# we're in the stmt: rule
if ($len)
{
# or just the statement ...
add_to_buffer( 'rules', ' { output_statement($1, 0,
ECPGst_normal); }' );
}
else
{
add_to_buffer( 'rules', ' { $$ = NULL; }' );
}
}
}
sub dump_line
{
my($stmt_mode, $fields) = @_;
my $block = $non_term_id . $line;
$block =~ tr/ |//d;
my $rep = $replace_line{$block};
if ($rep)
{
if ($rep eq 'ignore' )
{
return 0;
}
if ( index( $line, '|' ) != -1 )
{
$line = '| ' . $rep;
}
else
{
$line = $rep;
}
$block = $non_term_id . $line;
$block =~ tr/ |//d;
}
add_to_buffer( 'rules', $line );
my $i = include_addon( 'rules', $block, $fields, $stmt_mode);
if ( $i == 0 )
{
dump_fields( $stmt_mode, $fields, ' { ' );
}
return 1;
}
=top
load addons into cache
%addons = {
stmtClosePortalStmt => { 'type' => 'block', 'lines' => [ "{",
"if (INFORMIX_MODE)" ..., "}" ] },
stmtViewStmt => { 'type' => 'rule', 'lines' => [ "|
ECPGAllocateDescr", ... ] }
}
=cut
sub preload_addons
{
my $filename = $path . "/ecpg.addons";
open(my $fh, '<', $filename) or die;
# there may be multple lines starting ECPG: and then multiple lines of
code.
# the code need to be add to all prior ECPG records.
my (@needsRules, @code, $record);
# there may be comments before the first ECPG line, skip them
my $skip = 1;
while ( <$fh> )
{
if (/^ECPG:\s(\S+)\s?(\w+)?/)
{
$skip = 0;
if (@code)
{
for my $x (@needsRules)
{
push(@{ $x->{lines} }, @code);
}
@code = ();
@needsRules = ();
}
$record = {};
$record->{type} = $2;
$record->{lines} = [];
if (exists $addons{$1}) { die "Ga! there are dups!\n"; }
$addons{$1} = $record;
push(@needsRules, $record);
}
else
{
next if $skip;
push(@code, $_);
}
}
close($fh);
if (@code)
{
for my $x (@needsRules)
{
push(@{ $x->{lines} }, @code);
}
}
}
--
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
