granicus.if.org Git - postgresql/blob - src/interfaces/ecpg/preproc/parse.pl

   1 #!/usr/bin/perl
   2 # src/interfaces/ecpg/preproc/parse.pl
   3 # parser generater for ecpg version 2
   4 # call with backend parser as stdin
   5 #
   6 # Copyright (c) 2007-2018, PostgreSQL Global Development Group
   7 #
   8 # Written by Mike Aubury <mike.aubury@aubit.com>
   9 #            Michael Meskes <meskes@postgresql.org>
  10 #            Andy Colson <andy@squeakycode.net>
  11 #
  12 # Placed under the same license as PostgreSQL.
  13 #
  14
  15 use strict;
  16 use warnings;
  17 no warnings 'uninitialized';
  18
  19 my $path = shift @ARGV;
  20 $path = "." unless $path;
  21
  22 my $copymode              = 0;
  23 my $brace_indent          = 0;
  24 my $yaccmode              = 0;
  25 my $header_included       = 0;
  26 my $feature_not_supported = 0;
  27 my $tokenmode             = 0;
  28
  29 my (%buff, $infield, $comment, %tokens, %addons);
  30 my ($stmt_mode, @fields);
  31 my ($line,      $non_term_id);
  32
  33
  34 # some token have to be replaced by other symbols
  35 # either in the rule
  36 my %replace_token = (
  37         'BCONST' => 'ecpg_bconst',
  38         'FCONST' => 'ecpg_fconst',
  39         'Sconst' => 'ecpg_sconst',
  40         'IDENT'  => 'ecpg_ident',
  41         'PARAM'  => 'ecpg_param',);
  42
  43 # or in the block
  44 my %replace_string = (
  45         'NOT_LA'         => 'not',
  46         'NULLS_LA'       => 'nulls',
  47         'WITH_LA'        => 'with',
  48         'TYPECAST'       => '::',
  49         'DOT_DOT'        => '..',
  50         'COLON_EQUALS'   => ':=',
  51         'EQUALS_GREATER' => '=>',
  52         'LESS_EQUALS'    => '<=',
  53         'GREATER_EQUALS' => '>=',
  54         'NOT_EQUALS'     => '<>',);
  55
  56 # specific replace_types for specific non-terminals - never include the ':'
  57 # ECPG-only replace_types are defined in ecpg-replace_types
  58 my %replace_types = (
  59         'PrepareStmt'      => '<prep>',
  60         'opt_array_bounds' => '<index>',
  61
  62         # "ignore" means: do not create type and rules for this non-term-id
  63         'stmtblock'          => 'ignore',
  64         'stmtmulti'          => 'ignore',
  65         'CreateAsStmt'       => 'ignore',
  66         'DeallocateStmt'     => 'ignore',
  67         'ColId'              => 'ignore',
  68         'type_function_name' => 'ignore',
  69         'ColLabel'           => 'ignore',
  70         'Sconst'             => 'ignore',);
  71
  72 # these replace_line commands excise certain keywords from the core keyword
  73 # lists.  Be sure to account for these in ColLabel and related productions.
  74 my %replace_line = (
  75         'unreserved_keywordCONNECTION' => 'ignore',
  76         'unreserved_keywordCURRENT_P'  => 'ignore',
  77         'unreserved_keywordDAY_P'      => 'ignore',
  78         'unreserved_keywordHOUR_P'     => 'ignore',
  79         'unreserved_keywordINPUT_P'    => 'ignore',
  80         'unreserved_keywordMINUTE_P'   => 'ignore',
  81         'unreserved_keywordMONTH_P'    => 'ignore',
  82         'unreserved_keywordSECOND_P'   => 'ignore',
  83         'unreserved_keywordYEAR_P'     => 'ignore',
  84         'col_name_keywordCHAR_P'       => 'ignore',
  85         'col_name_keywordINT_P'        => 'ignore',
  86         'col_name_keywordVALUES'       => 'ignore',
  87         'reserved_keywordTO'           => 'ignore',
  88         'reserved_keywordUNION'        => 'ignore',
  89
  90         # some other production rules have to be ignored or replaced
  91         'fetch_argsFORWARDopt_from_incursor_name'      => 'ignore',
  92         'fetch_argsBACKWARDopt_from_incursor_name'     => 'ignore',
  93         "opt_array_boundsopt_array_bounds'['Iconst']'" => 'ignore',
  94         'VariableShowStmtSHOWvar_name' => 'SHOW var_name ecpg_into',
  95         'VariableShowStmtSHOWTIMEZONE' => 'SHOW TIME ZONE ecpg_into',
  96         'VariableShowStmtSHOWTRANSACTIONISOLATIONLEVEL' =>
  97           'SHOW TRANSACTION ISOLATION LEVEL ecpg_into',
  98         'VariableShowStmtSHOWSESSIONAUTHORIZATION' =>
  99           'SHOW SESSION AUTHORIZATION ecpg_into',
 100         'returning_clauseRETURNINGtarget_list' =>
 101           'RETURNING target_list opt_ecpg_into',
 102         'ExecuteStmtEXECUTEnameexecute_param_clause' =>
 103           'EXECUTE prepared_name execute_param_clause execute_rest',
 104         'ExecuteStmtCREATEOptTempTABLEcreate_as_targetASEXECUTEnameexecute_param_clause'
 105           => 'CREATE OptTemp TABLE create_as_target AS EXECUTE prepared_name execute_param_clause',
 106         'PrepareStmtPREPAREnameprep_type_clauseASPreparableStmt' =>
 107           'PREPARE prepared_name prep_type_clause AS PreparableStmt',
 108         'var_nameColId' => 'ECPGColId',);
 109
 110 preload_addons();
 111
 112 main();
 113
 114 dump_buffer('header');
 115 dump_buffer('tokens');
 116 dump_buffer('types');
 117 dump_buffer('ecpgtype');
 118 dump_buffer('orig_tokens');
 119 print '%%',                "\n";
 120 print 'prog: statements;', "\n";
 121 dump_buffer('rules');
 122 include_file('trailer', 'ecpg.trailer');
 123 dump_buffer('trailer');
 124
 125 sub main
 126 {
 127   line: while (<>)
 128         {
 129                 if (/ERRCODE_FEATURE_NOT_SUPPORTED/)
 130                 {
 131                         $feature_not_supported = 1;
 132                         next line;
 133                 }
 134
 135                 chomp;
 136
 137                 # comment out the line below to make the result file match (blank line wise)
 138                 # the prior version.
 139                 #next if ($_ eq '');
 140
 141                 # Dump the action for a rule -
 142                 # stmt_mode indicates if we are processing the 'stmt:'
 143                 # rule (mode==0 means normal,  mode==1 means stmt:)
 144                 # flds are the fields to use. These may start with a '$' - in
 145                 # which case they are the result of a previous non-terminal
 146                 #
 147                 # if they dont start with a '$' then they are token name
 148                 #
 149                 # len is the number of fields in flds...
 150                 # leadin is the padding to apply at the beginning (just use for formatting)
 151
 152                 if (/^%%/)
 153                 {
 154                         $tokenmode = 2;
 155                         $copymode  = 1;
 156                         $yaccmode++;
 157                         $infield = 0;
 158                 }
 159
 160                 my $prec = 0;
 161
 162                 # Make sure any braces are split
 163                 s/{/ { /g;
 164                 s/}/ } /g;
 165
 166                 # Any comments are split
 167                 s|\/\*| /* |g;
 168                 s|\*\/| */ |g;
 169
 170                 # Now split the line into individual fields
 171                 my @arr = split(' ');
 172
 173                 if ($arr[0] eq '%token' && $tokenmode == 0)
 174                 {
 175                         $tokenmode = 1;
 176                         include_file('tokens', 'ecpg.tokens');
 177                 }
 178                 elsif ($arr[0] eq '%type' && $header_included == 0)
 179                 {
 180                         include_file('header',   'ecpg.header');
 181                         include_file('ecpgtype', 'ecpg.type');
 182                         $header_included = 1;
 183                 }
 184
 185                 if ($tokenmode == 1)
 186                 {
 187                         my $str   = '';
 188                         my $prior = '';
 189                         for my $a (@arr)
 190                         {
 191                                 if ($a eq '/*')
 192                                 {
 193                                         $comment++;
 194                                         next;
 195                                 }
 196                                 if ($a eq '*/')
 197                                 {
 198                                         $comment--;
 199                                         next;
 200                                 }
 201                                 if ($comment)
 202                                 {
 203                                         next;
 204                                 }
 205                                 if (substr($a, 0, 1) eq '<')
 206                                 {
 207                                         next;
 208
 209                                         # its a type
 210                                 }
 211                                 $tokens{$a} = 1;
 212
 213                                 $str = $str . ' ' . $a;
 214                                 if ($a eq 'IDENT' && $prior eq '%nonassoc')
 215                                 {
 216
 217                                         # add two more tokens to the list
 218                                         $str = $str . "\n%nonassoc CSTRING\n%nonassoc UIDENT";
 219                                 }
 220                                 $prior = $a;
 221                         }
 222                         add_to_buffer('orig_tokens', $str);
 223                         next line;
 224                 }
 225
 226                 # Dont worry about anything if we're not in the right section of gram.y
 227                 if ($yaccmode != 1)
 228                 {
 229                         next line;
 230                 }
 231
 232
 233                 # Go through each field in turn
 234                 for (
 235                         my $fieldIndexer = 0;
 236                         $fieldIndexer < scalar(@arr);
 237                         $fieldIndexer++)
 238                 {
 239                         if ($arr[$fieldIndexer] eq '*/' && $comment)
 240                         {
 241                                 $comment = 0;
 242                                 next;
 243                         }
 244                         elsif ($comment)
 245                         {
 246                                 next;
 247                         }
 248                         elsif ($arr[$fieldIndexer] eq '/*')
 249                         {
 250
 251                                 # start of a multiline comment
 252                                 $comment = 1;
 253                                 next;
 254                         }
 255                         elsif ($arr[$fieldIndexer] eq '//')
 256                         {
 257                                 next line;
 258                         }
 259                         elsif ($arr[$fieldIndexer] eq '}')
 260                         {
 261                                 $brace_indent--;
 262                                 next;
 263                         }
 264                         elsif ($arr[$fieldIndexer] eq '{')
 265                         {
 266                                 $brace_indent++;
 267                                 next;
 268                         }
 269
 270                         if ($brace_indent > 0)
 271                         {
 272                                 next;
 273                         }
 274                         if ($arr[$fieldIndexer] eq ';')
 275                         {
 276                                 if ($copymode)
 277                                 {
 278                                         if ($infield)
 279                                         {
 280                                                 dump_line($stmt_mode, \@fields);
 281                                         }
 282                                         add_to_buffer('rules', ";\n\n");
 283                                 }
 284                                 else
 285                                 {
 286                                         $copymode = 1;
 287                                 }
 288                                 @fields  = ();
 289                                 $infield = 0;
 290                                 $line    = '';
 291                                 next;
 292                         }
 293
 294                         if ($arr[$fieldIndexer] eq '|')
 295                         {
 296                                 if ($copymode)
 297                                 {
 298                                         if ($infield)
 299                                         {
 300                                                 $infield = $infield + dump_line($stmt_mode, \@fields);
 301                                         }
 302                                         if ($infield > 1)
 303                                         {
 304                                                 $line = '| ';
 305                                         }
 306                                 }
 307                                 @fields = ();
 308                                 next;
 309                         }
 310
 311                         if (exists $replace_token{ $arr[$fieldIndexer] })
 312                         {
 313                                 $arr[$fieldIndexer] = $replace_token{ $arr[$fieldIndexer] };
 314                         }
 315
 316                         # Are we looking at a declaration of a non-terminal ?
 317                         if (($arr[$fieldIndexer] =~ /[A-Za-z0-9]+:/)
 318                                 || $arr[ $fieldIndexer + 1 ] eq ':')
 319                         {
 320                                 $non_term_id = $arr[$fieldIndexer];
 321                                 $non_term_id =~ tr/://d;
 322
 323                                 if (not defined $replace_types{$non_term_id})
 324                                 {
 325                                         $replace_types{$non_term_id} = '<str>';
 326                                         $copymode = 1;
 327                                 }
 328                                 elsif ($replace_types{$non_term_id} eq 'ignore')
 329                                 {
 330                                         $copymode = 0;
 331                                         $line     = '';
 332                                         next line;
 333                                 }
 334                                 $line = $line . ' ' . $arr[$fieldIndexer];
 335
 336                                 # Do we have the : attached already ?
 337                                 # If yes, we'll have already printed the ':'
 338                                 if (!($arr[$fieldIndexer] =~ '[A-Za-z0-9]+:'))
 339                                 {
 340
 341                                         # Consume the ':' which is next...
 342                                         $line = $line . ':';
 343                                         $fieldIndexer++;
 344                                 }
 345
 346                                 # Special mode?
 347                                 if ($non_term_id eq 'stmt')
 348                                 {
 349                                         $stmt_mode = 1;
 350                                 }
 351                                 else
 352                                 {
 353                                         $stmt_mode = 0;
 354                                 }
 355                                 my $tstr =
 356                                     '%type '
 357                                   . $replace_types{$non_term_id} . ' '
 358                                   . $non_term_id;
 359                                 add_to_buffer('types', $tstr);
 360
 361                                 if ($copymode)
 362                                 {
 363                                         add_to_buffer('rules', $line);
 364                                 }
 365                                 $line    = '';
 366                                 @fields  = ();
 367                                 $infield = 1;
 368                                 next;
 369                         }
 370                         elsif ($copymode)
 371                         {
 372                                 $line = $line . ' ' . $arr[$fieldIndexer];
 373                         }
 374                         if ($arr[$fieldIndexer] eq '%prec')
 375                         {
 376                                 $prec = 1;
 377                                 next;
 378                         }
 379
 380                         if (   $copymode
 381                                 && !$prec
 382                                 && !$comment
 383                                 && length($arr[$fieldIndexer])
 384                                 && $infield)
 385                         {
 386                                 if ($arr[$fieldIndexer] ne 'Op'
 387                                         && (   $tokens{ $arr[$fieldIndexer] } > 0
 388                                                 || $arr[$fieldIndexer] =~ /'.+'/)
 389                                         || $stmt_mode == 1)
 390                                 {
 391                                         my $S;
 392                                         if (exists $replace_string{ $arr[$fieldIndexer] })
 393                                         {
 394                                                 $S = $replace_string{ $arr[$fieldIndexer] };
 395                                         }
 396                                         else
 397                                         {
 398                                                 $S = $arr[$fieldIndexer];
 399                                         }
 400                                         $S =~ s/_P//g;
 401                                         $S =~ tr/'//d;
 402                                         if ($stmt_mode == 1)
 403                                         {
 404                                                 push(@fields, $S);
 405                                         }
 406                                         else
 407                                         {
 408                                                 push(@fields, lc($S));
 409                                         }
 410                                 }
 411                                 else
 412                                 {
 413                                         push(@fields, '$' . (scalar(@fields) + 1));
 414                                 }
 415                         }
 416                 }
 417         }
 418 }
 419
 420
 421 # append a file onto a buffer.
 422 # Arguments:  buffer_name, filename (without path)
 423 sub include_file
 424 {
 425         my ($buffer, $filename) = @_;
 426         my $full = "$path/$filename";
 427         open(my $fh, '<', $full) or die;
 428         while (<$fh>)
 429         {
 430                 chomp;
 431                 add_to_buffer($buffer, $_);
 432         }
 433         close($fh);
 434 }
 435
 436 sub include_addon
 437 {
 438         my ($buffer, $block, $fields, $stmt_mode) = @_;
 439         my $rec = $addons{$block};
 440         return 0 unless $rec;
 441
 442         if ($rec->{type} eq 'rule')
 443         {
 444                 dump_fields($stmt_mode, $fields, ' { ');
 445         }
 446         elsif ($rec->{type} eq 'addon')
 447         {
 448                 add_to_buffer('rules', ' { ');
 449         }
 450
 451         #add_to_buffer( $stream, $_ );
 452         #We have an array to add to the buffer, we'll add it ourself instead of
 453         #calling add_to_buffer, which does not know about arrays
 454
 455         push(@{ $buff{$buffer} }, @{ $rec->{lines} });
 456
 457         if ($rec->{type} eq 'addon')
 458         {
 459                 dump_fields($stmt_mode, $fields, '');
 460         }
 461
 462
 463         # if we added something (ie there are lines in our array), return 1
 464         return 1 if (scalar(@{ $rec->{lines} }) > 0);
 465         return 0;
 466 }
 467
 468
 469 # include_addon does this same thing, but does not call this
 470 # sub... so if you change this, you need to fix include_addon too
 471 #   Pass:  buffer_name, string_to_append
 472 sub add_to_buffer
 473 {
 474         push(@{ $buff{ $_[0] } }, "$_[1]\n");
 475 }
 476
 477 sub dump_buffer
 478 {
 479         my ($buffer) = @_;
 480         print '/* ', $buffer, ' */', "\n";
 481         my $ref = $buff{$buffer};
 482         print @$ref;
 483 }
 484
 485 sub dump_fields
 486 {
 487         my ($mode, $flds, $ln) = @_;
 488         my $len = scalar(@$flds);
 489
 490         if ($mode == 0)
 491         {
 492
 493                 #Normal
 494                 add_to_buffer('rules', $ln);
 495                 if ($feature_not_supported == 1)
 496                 {
 497
 498                         # we found an unsupported feature, but we have to
 499                         # filter out ExecuteStmt: CREATE OptTemp TABLE ...
 500                         # because the warning there is only valid in some situations
 501                         if ($flds->[0] ne 'create' || $flds->[2] ne 'table')
 502                         {
 503                                 add_to_buffer('rules',
 504                                         'mmerror(PARSE_ERROR, ET_WARNING, "unsupported feature will be passed to server");'
 505                                 );
 506                         }
 507                         $feature_not_supported = 0;
 508                 }
 509
 510                 if ($len == 0)
 511                 {
 512
 513                         # We have no fields ?
 514                         add_to_buffer('rules', ' $$=EMPTY; }');
 515                 }
 516                 else
 517                 {
 518
 519                         # Go through each field and try to 'aggregate' the tokens
 520                         # into a single 'mm_strdup' where possible
 521                         my @flds_new;
 522                         my $str;
 523                         for (my $z = 0; $z < $len; $z++)
 524                         {
 525                                 if (substr($flds->[$z], 0, 1) eq '$')
 526                                 {
 527                                         push(@flds_new, $flds->[$z]);
 528                                         next;
 529                                 }
 530
 531                                 $str = $flds->[$z];
 532
 533                                 while (1)
 534                                 {
 535                                         if ($z >= $len - 1
 536                                                 || substr($flds->[ $z + 1 ], 0, 1) eq '$')
 537                                         {
 538
 539                                                 # We're at the end...
 540                                                 push(@flds_new, "mm_strdup(\"$str\")");
 541                                                 last;
 542                                         }
 543                                         $z++;
 544                                         $str = $str . ' ' . $flds->[$z];
 545                                 }
 546                         }
 547
 548                         # So - how many fields did we end up with ?
 549                         $len = scalar(@flds_new);
 550                         if ($len == 1)
 551                         {
 552
 553                                 # Straight assignment
 554                                 $str = ' $$ = ' . $flds_new[0] . ';';
 555                                 add_to_buffer('rules', $str);
 556                         }
 557                         else
 558                         {
 559
 560                                 # Need to concatenate the results to form
 561                                 # our final string
 562                                 $str =
 563                                   ' $$ = cat_str(' . $len . ',' . join(',', @flds_new) . ');';
 564                                 add_to_buffer('rules', $str);
 565                         }
 566                         add_to_buffer('rules', '}');
 567                 }
 568         }
 569         else
 570         {
 571
 572                 # we're in the stmt: rule
 573                 if ($len)
 574                 {
 575
 576                         # or just the statement ...
 577                         add_to_buffer('rules',
 578                                 ' { output_statement($1, 0, ECPGst_normal); }');
 579                 }
 580                 else
 581                 {
 582                         add_to_buffer('rules', ' { $$ = NULL; }');
 583                 }
 584         }
 585 }
 586
 587
 588 sub dump_line
 589 {
 590         my ($stmt_mode, $fields) = @_;
 591         my $block = $non_term_id . $line;
 592         $block =~ tr/ |//d;
 593         my $rep = $replace_line{$block};
 594         if ($rep)
 595         {
 596                 if ($rep eq 'ignore')
 597                 {
 598                         return 0;
 599                 }
 600
 601                 if (index($line, '|') != -1)
 602                 {
 603                         $line = '| ' . $rep;
 604                 }
 605                 else
 606                 {
 607                         $line = $rep;
 608                 }
 609                 $block = $non_term_id . $line;
 610                 $block =~ tr/ |//d;
 611         }
 612         add_to_buffer('rules', $line);
 613         my $i = include_addon('rules', $block, $fields, $stmt_mode);
 614         if ($i == 0)
 615         {
 616                 dump_fields($stmt_mode, $fields, ' { ');
 617         }
 618         return 1;
 619 }
 620
 621 =top
 622         load addons into cache
 623         %addons = {
 624                 stmtClosePortalStmt => { 'type' => 'block', 'lines' => [ "{", "if (INFORMIX_MODE)" ..., "}" ] },
 625                 stmtViewStmt => { 'type' => 'rule', 'lines' => [ "| ECPGAllocateDescr", ... ] }
 626         }
 627
 628 =cut
 629
 630 sub preload_addons
 631 {
 632         my $filename = $path . "/ecpg.addons";
 633         open(my $fh, '<', $filename) or die;
 634
 635         # there may be multiple lines starting ECPG: and then multiple lines of code.
 636         # the code need to be add to all prior ECPG records.
 637         my (@needsRules, @code, $record);
 638
 639         # there may be comments before the first ECPG line, skip them
 640         my $skip = 1;
 641         while (<$fh>)
 642         {
 643                 if (/^ECPG:\s(\S+)\s?(\w+)?/)
 644                 {
 645                         $skip = 0;
 646                         if (@code)
 647                         {
 648                                 for my $x (@needsRules)
 649                                 {
 650                                         push(@{ $x->{lines} }, @code);
 651                                 }
 652                                 @code       = ();
 653                                 @needsRules = ();
 654                         }
 655                         $record          = {};
 656                         $record->{type}  = $2;
 657                         $record->{lines} = [];
 658                         if (exists $addons{$1}) { die "Ga! there are dups!\n"; }
 659                         $addons{$1} = $record;
 660                         push(@needsRules, $record);
 661                 }
 662                 else
 663                 {
 664                         next if $skip;
 665                         push(@code, $_);
 666                 }
 667         }
 668         close($fh);
 669         if (@code)
 670         {
 671                 for my $x (@needsRules)
 672                 {
 673                         push(@{ $x->{lines} }, @code);
 674                 }
 675         }
 676 }