1package SQL::Parser; 2 3###################################################################### 4# 5# This module is copyright (c), 2001,2005 by Jeff Zucker. 6# This module is copyright (c), 2007-2020 by Jens Rehsack. 7# All rights reserved. 8# 9# It may be freely distributed under the same terms as Perl itself. 10# See below for help and copyright information (search for SYNOPSIS). 11# 12###################################################################### 13 14use strict; 15use warnings FATAL => "all"; 16use vars qw($VERSION); 17use constant FUNCTION_NAMES => join( '|', qw(TRIM SUBSTRING) ); 18use constant BAREWORD_FUNCTIONS => 19 join( '|', qw(TRIM SUBSTRING CURRENT_DATE CURDATE CURRENT_TIME CURTIME CURRENT_TIMESTAMP NOW UNIX_TIMESTAMP PI DBNAME) ); 20use Carp qw(carp croak); 21use Params::Util qw(_ARRAY0 _ARRAY _HASH); 22use Scalar::Util qw(looks_like_number); 23use Text::Balanced qw(extract_bracketed extract_multiple); 24 25$VERSION = '1.414'; 26 27BEGIN 28{ 29 if ( $ENV{SQL_USER_DEFS} ) { require SQL::UserDefs; } 30} 31 32############################# 33# PUBLIC METHODS 34############################# 35 36sub new 37{ 38 my $class = shift; 39 my $dialect = shift || 'ANSI'; 40 $dialect = 'ANSI' if ( uc $dialect eq 'ANSI' ); 41 $dialect = 'AnyData' if ( ( uc $dialect eq 'ANYDATA' ) or ( uc $dialect eq 'CSV' ) ); 42 $dialect = 'AnyData' if ( $dialect eq 'SQL::Eval' ); 43 44 my $flags = shift || {}; 45 $flags->{dialect} = $dialect; 46 $flags->{PrintError} = 1 unless ( defined( $flags->{PrintError} ) ); 47 48 my $self = bless( $flags, $class ); 49 $self->dialect( $self->{dialect} ); 50 $self->set_feature_flags( $self->{select}, $self->{create} ); 51 52 $self->LOAD('LOAD SQL::Statement::Functions'); 53 54 return $self; 55} 56 57sub parse 58{ 59 my ( $self, $sql ) = @_; 60 $self->dialect( $self->{dialect} ) unless ( $self->{dialect_set} ); 61 $sql =~ s/^\s+//; 62 $sql =~ s/\s+$//; 63 $sql =~ s/\s*;$//; 64 $self->{struct} = { dialect => $self->{dialect} }; 65 $self->{tmp} = {}; 66 $self->{original_string} = $sql; 67 $self->{struct}->{original_string} = $sql; 68 69 ################################################################ 70 # 71 # COMMENTS 72 73 # C-STYLE 74 # 75 my $comment_re = $self->{comment_re} || '(\/\*.*?\*\/)'; 76 $self->{comment_re} = $comment_re; 77 my $starts_with_comment; 78 if ( $sql =~ /^\s*$comment_re(.*)$/s ) 79 { 80 $self->{comment} = $1; 81 $sql = $2; 82 $starts_with_comment = 1; 83 } 84 85 # SQL STYLE 86 # 87 # SQL-style comment can not begin inside quotes. 88 if ( $sql =~ s/^([^']*?(?:'[^']*'[^'])*?)(--.*)(\n|$)/$1$3/ ) 89 { 90 $self->{comment} = $2; 91 } 92 ################################################################ 93 94 $sql = $self->clean_sql($sql); 95 my ($com) = $sql =~ m/^\s*(\S+)\s+/s; 96 if ( !$com ) 97 { 98 return 1 if ($starts_with_comment); 99 return $self->do_err("Incomplete statement!"); 100 } 101 $com = uc $com; 102 $self->{opts}->{valid_commands}->{CALL} = 1; 103 $self->{opts}->{valid_commands}->{LOAD} = 1; 104 if ( $self->{opts}->{valid_commands}->{$com} ) 105 { 106 my $rv = $self->$com($sql); 107 delete $self->{struct}->{literals}; 108 109 return $self->do_err("No command found!") unless ( $self->{struct}->{command} ); 110 111 $self->replace_quoted_ids(); 112 113 my @tables = @{ $self->{struct}->{table_names} } 114 if ( defined( _ARRAY0( $self->{struct}->{table_names} ) ) ); 115 push( @{ $self->{struct}->{org_table_names} }, @tables ); 116 # REMOVE schema.table info if present 117 @tables = map { s/^.*\.([^\.]+)$/$1/; ( -1 == index( $_, '"' ) ) ? lc $_ : $_ } @tables; 118 119 if ( exists( $self->{struct}->{join} ) && !defined( _HASH( $self->{struct}->{join} ) ) ) 120 { 121 delete $self->{struct}->{join}; 122 } 123 else 124 { 125 $self->{struct}->{join}->{table_order} = $self->{struct}->{table_names} 126 if ( defined( $self->{struct}->{join}->{table_order} ) 127 && !defined( _ARRAY0( $self->{struct}->{join}->{table_order} ) ) ); 128 @{ $self->{struct}->{join}->{keycols} } = 129 map { lc $_ } @{ $self->{struct}->{join}->{keycols} } 130 if ( $self->{struct}->{join}->{keycols} ); 131 @{ $self->{struct}->{join}->{shared_cols} } = 132 map { lc $_ } @{ $self->{struct}->{join}->{shared_cols} } 133 if ( $self->{struct}->{join}->{shared_cols} ); 134 } 135 136 if ( defined( $self->{struct}->{column_defs} ) 137 && defined( _ARRAY( $self->{struct}->{column_defs} ) ) ) 138 { 139 my $colname; 140 # FIXME SUBSTR('*') 141 my @fine_defs = 142 grep { defined( $_->{fullorg} ) && ( -1 == index( $_->{fullorg}, '*' ) ) } @{ $self->{struct}->{column_defs} }; 143 foreach my $col (@fine_defs) 144 { 145 my $colname = $col->{fullorg}; 146 #$cn = lc $cn unless ( $cn =~ m/^(?:\w+\.)?"/ ); 147 push( @{ $self->{struct}->{org_col_names} }, $self->{struct}->{ORG_NAME}->{$colname} || $colname ); 148 } 149 150 unless ( $com eq 'CREATE' ) 151 { 152 $self->{struct}->{table_names} = \@tables; 153 # For RR aliases, added quoted id protection from upper casing 154 foreach my $col (@fine_defs) 155 { 156 # defined( $col->{fullorg} ) && ( -1 == index( $col->{fullorg}, '*' ) ) or next; 157 my $orgname = $colname = $col->{fullorg}; 158 $colname =~ m/^(?:\p{Word}+\.)?"/ or $colname = lc $colname; 159 defined( $self->{struct}->{ORG_NAME}->{$colname} ) and next; 160 $self->{struct}->{ORG_NAME}->{$colname} = 161 $self->{struct}->{ORG_NAME}->{$orgname}; 162 } 163 #my @uCols = map { ( $_ =~ /^(\w+\.)?"/ ) ? $_ : lc $_ } @{ $self->{struct}->{column_names} }; 164 #$self->{struct}->{column_names} = \@uCols; 165 } 166 } 167 168 return $rv; 169 } 170 else 171 { 172 $self->{struct} = {}; 173 if ( $ENV{SQL_USER_DEFS} ) 174 { 175 return SQL::UserDefs::user_parse( $self, $sql ); 176 } 177 return $self->do_err("Command '$com' not recognized or not supported!"); 178 } 179} 180 181sub replace_quoted_commas 182{ 183 my ( $self, $id ) = @_; 184 $id =~ s/\?COMMA\?/,/gs; 185 return $id; 186} 187 188sub replace_quoted_ids 189{ 190 my ( $self, $id ) = @_; 191 $self->{struct}->{quoted_ids} or $self->{struct}->{literals} or return; 192 if ($id) 193 { 194 if ( $id =~ /^\?QI(\d+)\?$/ ) 195 { 196 return '"' . $self->{struct}->{quoted_ids}->[$1] . '"'; 197 } 198 elsif ( $id =~ /^\?(\d+)\?$/ ) 199 { 200 return $self->{struct}->{literals}->[$1]; 201 } 202 else 203 { 204 return $id; 205 } 206 } 207 return unless defined $self->{struct}->{table_names}; 208 my @tables = @{ $self->{struct}->{table_names} }; 209 for my $t (@tables) 210 { 211 if ( $t =~ /^\?QI(.+)\?$/ ) 212 { 213 $t = '"' . $self->{struct}->{quoted_ids}->[$1] . '"'; 214 } 215 elsif( $t =~ /^\?(\d+)\?$/ ) 216 { 217 $t = $self->{struct}->{literals}->[$1]; 218 } 219 } 220 $self->{struct}->{table_names} = \@tables; 221 delete $self->{struct}->{quoted_ids}; 222} 223 224sub structure { $_[0]->{struct} } 225sub command { my $x = $_[0]->{struct}->{command} || '' } 226 227sub feature 228{ 229 my ( $self, $opt_class, $opt_name, $opt_value ) = @_; 230 if ( defined $opt_value ) 231 { 232 if ( $opt_class eq 'select' ) 233 { 234 $self->set_feature_flags( { "join" => $opt_value } ); 235 } 236 elsif ( $opt_class eq 'create' ) 237 { 238 $self->set_feature_flags( undef, { $opt_name => $opt_value } ); 239 } 240 else 241 { 242 243 # patch from chromatic 244 $self->{opts}->{$opt_class}->{$opt_name} = $opt_value; 245 246 # $self->{$opt_class}->{$opt_name} = $opt_value; 247 } 248 } 249 else 250 { 251 return $self->{opts}->{$opt_class}->{$opt_name}; 252 } 253} 254 255sub errstr { $_[0]->{struct}->{errstr} } 256 257sub list 258{ 259 my $self = shift; 260 my $com = uc shift; 261 return () if $com !~ /COMMANDS|RESERVED|TYPES|OPS|OPTIONS|DIALECTS/i; 262 $com = 'valid_commands' if $com eq 'COMMANDS'; 263 $com = 'valid_comparison_operators' if $com eq 'OPS'; 264 $com = 'valid_data_types' if $com eq 'TYPES'; 265 $com = 'valid_options' if $com eq 'OPTIONS'; 266 $com = 'reserved_words' if $com eq 'RESERVED'; 267 $self->dialect( $self->{dialect} ) unless $self->{dialect_set}; 268 269 return sort keys %{ $self->{opts}->{$com} } unless $com eq 'DIALECTS'; 270 my $dDir = "SQL/Dialects"; 271 my @dialects; 272 for my $dir (@INC) 273 { 274 local *D; 275 276 if ( opendir( D, "$dir/$dDir" ) ) 277 { 278 @dialects = grep /.*\.pm$/, readdir(D); 279 last; 280 } 281 } 282 @dialects = map { s/\.pm$//; $_ } @dialects; 283 return @dialects; 284} 285 286sub dialect 287{ 288 my ( $self, $dialect ) = @_; 289 return $self->{dialect} unless ($dialect); 290 return $self->{dialect} if ( $self->{dialect_set} ); 291 $self->{opts} = {}; 292 my $mod_class = "SQL::Dialects::$dialect"; 293 294 $self->_load_class($mod_class) unless $mod_class->can("get_config"); 295 296 # This is here for backwards compatibility with existing dialects 297 # before the had the role to add new methods. 298 $self->_inject_role( "SQL::Dialects::Role", $mod_class ) 299 unless ( $mod_class->can("get_config_as_hash") ); 300 301 $self->{opts} = $mod_class->get_config_as_hash(); 302 303 $self->create_op_regexen(); 304 $self->{dialect} = $dialect; 305 $self->{dialect_set}++; 306 307 return $self->{dialect}; 308} 309 310sub _load_class 311{ 312 my ( $self, $class ) = @_; 313 314 my $mod = $class; 315 $mod =~ s{::}{/}g; 316 $mod .= ".pm"; 317 318 local ( $!, $@ ); 319 eval { require "$mod"; } or return $self->do_err($@); 320 321 return 1; 322} 323 324sub _inject_role 325{ 326 my ( $self, $role, $dest ) = @_; 327 328 eval qq{ 329 package $dest; 330 use $role; 331 1; 332 } or croak "Can't inject $role into $dest: $@"; 333} 334 335sub create_op_regexen 336{ 337 my ($self) = @_; 338 339 # 340 # DAA precompute the predicate operator regex's 341 # 342 # JZ moved this into a sub so it can be called from both 343 # dialect() and from CREATE_OPERATOR and DROP_OPERATOR 344 # since those also modify the available operators 345 # 346 my @allops = keys %{ $self->{opts}->{valid_comparison_operators} }; 347 348 # 349 # complement operators 350 # 351 my @notops; 352 for (@allops) 353 { 354 push( @notops, $_ ) 355 if /NOT/i; 356 } 357 $self->{opts}->{valid_comparison_NOT_ops_regex} = '^\s*(.+)\s+(' . join( '|', @notops ) . ')\s+(.*)\s*$' 358 if scalar @notops; 359 360 # 361 # <>, <=, >= operators 362 # 363 my @compops; 364 for (@allops) 365 { 366 push( @compops, $_ ) 367 if /<=|>=|<>/; 368 } 369 $self->{opts}->{valid_comparison_twochar_ops_regex} = '^\s*(.+)\s+(' . join( '|', @compops ) . ')\s+(.*)\s*$' 370 if scalar @compops; 371 372 # 373 # everything 374 # 375 $self->{opts}->{valid_comparison_ops_regex} = '^\s*(.+)\s+(' . join( '|', @allops ) . ')\s+(.*)\s*$' 376 if scalar @allops; 377 378 # 379 # end DAA 380 # 381} 382 383################################################################## 384# SQL COMMANDS 385################################################################## 386 387#################################################### 388# DROP TABLE <table_name> 389#################################################### 390sub DROP 391{ 392 my ( $self, $stmt ) = @_; 393 my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE'; 394 if ( $stmt =~ /^\s*DROP\s+($features)\s+(.+)$/si ) 395 { 396 my ( $sub, $arg ) = ( $1, $2 ); 397 $sub = 'DROP_' . $sub; 398 return $self->$sub($arg); 399 } 400 my $table_name; 401 $self->{struct}->{command} = 'DROP'; 402 if ( $stmt =~ /^\s*DROP\s+TABLE\s+IF\s+EXISTS\s+(.*)$/si ) 403 { 404 $stmt = "DROP TABLE $1"; 405 $self->{struct}->{ignore_missing_table} = 1; 406 } 407 if ( $stmt =~ /^\s*DROP\s+(\S+)\s+(.+)$/si ) 408 { 409 my $com2 = $1 || ''; 410 $table_name = $2; 411 if ( $com2 !~ /^TABLE$/i ) 412 { 413 return $self->do_err("The command 'DROP $com2' is not recognized or not supported!"); 414 } 415 $table_name =~ s/^\s+//; 416 $table_name =~ s/\s+$//; 417 if ( $table_name =~ /(\S+) (RESTRICT|CASCADE)/i ) 418 { 419 $table_name = $1; 420 $self->{struct}->{drop_behavior} = uc $2; 421 } 422 } 423 else 424 { 425 return $self->do_err("Incomplete DROP statement!"); 426 427 } 428 return undef unless $self->TABLE_NAME($table_name); 429 $table_name = $self->replace_quoted_ids($table_name); 430 $self->{tmp}->{is_table_name} = { $table_name => 1 }; 431 $self->{struct}->{table_names} = [$table_name]; 432 return 1; 433} 434 435#################################################### 436# DELETE FROM <table_name> WHERE <search_condition> 437#################################################### 438sub DELETE 439{ 440 my ( $self, $str ) = @_; 441 $self->{struct}->{command} = 'DELETE'; 442 $str =~ s/^DELETE\s+FROM\s+/DELETE /i; # Make FROM optional 443 my ( $table_name, $where_clause ) = $str =~ /^DELETE (\S+)(.*)$/i; 444 return $self->do_err('Incomplete DELETE statement!') if !$table_name; 445 return undef unless $self->TABLE_NAME($table_name); 446 $self->{tmp}->{is_table_name} = { $table_name => 1 }; 447 $self->{struct}->{table_names} = [$table_name]; 448 $self->{struct}->{column_defs} = [ 449 { 450 type => 'column', 451 value => '*' 452 } 453 ]; 454 $where_clause =~ s/^\s+//; 455 $where_clause =~ s/\s+$//; 456 457 if ($where_clause) 458 { 459 $where_clause =~ s/^WHERE\s*(.*)$/$1/i; 460 return undef unless $self->SEARCH_CONDITION($where_clause); 461 } 462 return 1; 463} 464 465############################################################## 466# SELECT 467############################################################## 468# SELECT [<set_quantifier>] <select_list> 469# | <set_function_specification> 470# FROM <from_clause> 471# [WHERE <search_condition>] 472# [ORDER BY <order_by_clause>] 473# [LIMIT <limit_clause>] 474############################################################## 475 476sub SELECT 477{ 478 my ( $self, $str ) = @_; 479 $self->{struct}->{command} = 'SELECT'; 480 my ( $from_clause, $where_clause, $order_clause, $groupby_clause, $limit_clause ); 481 $str =~ s/^SELECT (.+)$/$1/i; 482 if ( $str =~ s/^(.+) LIMIT (.+)$/$1/i ) { $limit_clause = $2; } 483 if ( $str =~ s/^(.+) ORDER BY (.+)$/$1/i ) { $order_clause = $2; } 484 if ( $str =~ s/^(.+) GROUP BY (.+)$/$1/i ) { $groupby_clause = $2; } 485 if ( $str =~ s/^(.+?) WHERE (.+)$/$1/i ) { $where_clause = $2; } 486 if ( $str =~ s/^(.+?) FROM (.+)$/$1/i ) { $from_clause = $2; } 487 488 # else { 489 # return $self->do_err("Couldn't find FROM clause in SELECT!"); 490 # } 491 # return undef unless $self->FROM_CLAUSE($from_clause); 492 my $has_from_clause = $self->FROM_CLAUSE($from_clause) if ($from_clause); 493 494 return undef unless ( $self->SELECT_CLAUSE($str) ); 495 496 if ($where_clause) 497 { 498 return undef unless ( $self->SEARCH_CONDITION($where_clause) ); 499 } 500 if ($groupby_clause) 501 { 502 return undef unless ( $self->GROUPBY_LIST($groupby_clause) ); 503 } 504 if ($order_clause) 505 { 506 return undef unless ( $self->SORT_SPEC_LIST($order_clause) ); 507 } 508 if ($limit_clause) 509 { 510 return undef unless ( $self->LIMIT_CLAUSE($limit_clause) ); 511 } 512 if ( 513 ( $self->{struct}->{join}->{clause} and $self->{struct}->{join}->{clause} eq 'ON' ) 514 or ( $self->{struct}->{multiple_tables} 515 and !( scalar keys %{ $self->{struct}->{join} } ) ) 516 ) 517 { 518 return undef unless ( $self->IMPLICIT_JOIN() ); 519 } 520 521 if ( $self->{struct}->{set_quantifier} 522 && ( 'DISTINCT' eq $self->{struct}->{set_quantifier} ) 523 && $self->{struct}->{has_set_functions} 524 && !defined( _ARRAY( $self->{struct}->{group_by} ) ) ) 525 { 526 delete $self->{struct}->{set_quantifier}; 527 carp "Specifying DISTINCT when using aggregate functions isn't reasonable - ignored." 528 if ( $self->{PrintError} ); 529 } 530 531 return 1; 532} 533 534sub GROUPBY_LIST 535{ 536 my ( $self, $gclause ) = @_; 537 return 1 unless ($gclause); 538 my $cols = $self->ROW_VALUE_LIST($gclause); 539 return undef if ( $self->{struct}->{errstr} ); 540 @{ $self->{struct}->{group_by} } = map { $_->{fullorg} } @{$cols}; 541 return 1; 542} 543 544sub IMPLICIT_JOIN 545{ 546 my $self = $_[0]; 547 delete $self->{struct}->{multiple_tables}; 548 if ( !$self->{struct}->{join}->{clause} 549 or $self->{struct}->{join}->{clause} ne 'ON' ) 550 { 551 $self->{struct}->{join}->{type} = 'INNER'; 552 $self->{struct}->{join}->{clause} = 'IMPLICIT'; 553 } 554 if ( defined $self->{struct}->{keycols} ) 555 { 556 my @keys; 557 my @keys2 = @keys = @{ $self->{struct}->{keycols} }; 558 $self->{struct}->{join}->{table_order} = $self->order_joins( \@keys2 ); 559 @{ $self->{struct}->{join}->{keycols} } = @keys; 560 delete $self->{struct}->{keycols}; 561 } 562 else 563 { 564 return $self->do_err("No equijoin condition in WHERE or ON clause"); 565 } 566 return 1; 567} 568 569sub EXPLICIT_JOIN 570{ 571 my ( $self, $remainder ) = @_; 572 return undef unless ($remainder); 573 my ( $tableA, $tableB, $keycols, $jtype, $natural ); 574 if ( $remainder =~ m/^(.+?) (NATURAL|INNER|LEFT|RIGHT|FULL|CROSS|UNION|JOIN)(.+)$/is ) 575 { 576 $tableA = $1; 577 $remainder = $2 . $3; 578 } 579 else 580 { 581 ( $tableA, $remainder ) = $remainder =~ m/^(\S+) (.*)/i; 582 } 583 if ( $remainder =~ m/^NATURAL (.+)/ ) 584 { 585 $self->{struct}->{join}->{clause} = 'NATURAL'; 586 $natural++; 587 $remainder = $1; 588 } 589 if ( $remainder =~ m/^(INNER|LEFT|RIGHT|FULL|CROSS|UNION) JOIN (.+)/i ) 590 { 591 $jtype = $self->{struct}->{join}->{clause} = uc($1); 592 $remainder = $2; 593 $jtype = "$jtype OUTER" if $jtype !~ /INNER|UNION/i; 594 } 595 if ( $remainder =~ m/^(LEFT|RIGHT|FULL|CROSS) OUTER JOIN (.+)/i ) 596 { 597 $jtype = $self->{struct}->{join}->{clause} = uc($1) . " OUTER"; 598 $remainder = $2; 599 } 600 if ( $remainder =~ m/^JOIN (.+)/i ) 601 { 602 $jtype = 'INNER'; 603 $self->{struct}->{join}->{clause} = 'DEFAULT INNER'; 604 $remainder = $1; 605 } 606 if ( $self->{struct}->{join} ) 607 { 608 if ( $remainder && $remainder =~ m/^(.+?) USING \(([^\)]+)\)(.*)/i ) 609 { 610 $self->{struct}->{join}->{clause} = 'USING'; 611 $tableB = $1; 612 my $keycolstr = $2; 613 $remainder = $3; 614 @$keycols = split( /,/, $keycolstr ); 615 } 616 if ( $remainder && $remainder =~ m/^(.+?) ON (.+)/i ) 617 { 618 $self->{struct}->{join}->{clause} = 'ON'; 619 $tableB = $1; 620 my $keycolstr = $2; 621 $remainder = $3; 622 @$keycols = split(/ AND|OR /i, $keycolstr); 623 624 return undef 625 unless $self->TABLE_NAME_LIST( $tableA . ',' . $tableB ); 626 627 # $self->{tmp}->{is_table_name}->{"$tableA"} = 1; 628 # $self->{tmp}->{is_table_name}->{"$tableB"} = 1; 629 for my $keycol (@$keycols) 630 { 631 my %is_done; 632 $keycol =~ s/\)|\(//g; 633 my ( $arg1, $arg2 ) = split( m/ [>=<] /, $keycol ); 634 my ( $c1, $c2 ) = ( $arg1, $arg2 ); 635 $c1 =~ s/^.*\.([^\.]+)$/$1/; 636 $c2 =~ s/^.*\.([^\.]+)$/$1/; 637 if ( $c1 eq $c2 ) 638 { 639 return undef unless ( $arg1 = $self->ROW_VALUE($c1) ); 640 if ( $arg1->{type} eq 'column' and !$is_done{$c1} ) 641 { 642 push( @{ $self->{struct}->{keycols} }, $arg1->{value} ); 643 $is_done{$c1} = 1; 644 } 645 } 646 else 647 { 648 return undef unless ( $arg1 = $self->ROW_VALUE($arg1) ); 649 return undef unless ( $arg2 = $self->ROW_VALUE($arg2) ); 650 if ( $arg1->{type} eq 'column' 651 and $arg2->{type} eq 'column' ) 652 { 653 push( @{ $self->{struct}->{keycols} }, $arg1->{value} ); 654 push( @{ $self->{struct}->{keycols} }, $arg2->{value} ); 655 656 # delete $self->{struct}->{where_clause}; 657 } 658 } 659 } 660 } 661 elsif ( $remainder =~ /^(.+?)$/i ) 662 { 663 $tableB = $1; 664 $remainder = $2; 665 } 666 $remainder =~ s/^\s+// if ($remainder); 667 } 668 669 if ($jtype) 670 { 671 $jtype = "NATURAL $jtype" if ($natural); 672 if ( $natural and $keycols ) 673 { 674 return $self->do_err(qq{Can't use NATURAL with a USING or ON clause!}); 675 } 676 return undef unless ( $self->TABLE_NAME_LIST("$tableA,$tableB") ); 677 $self->{struct}->{join}->{type} = $jtype; 678 $self->{struct}->{join}->{keycols} = $keycols if ($keycols); 679 return 1; 680 } 681 return $self->do_err("Couldn't parse explicit JOIN!"); 682} 683 684sub SELECT_CLAUSE 685{ 686 my ( $self, $str ) = @_; 687 return undef unless ($str); 688 if ( $str =~ s/^(DISTINCT|ALL) (.+)$/$2/i ) 689 { 690 $self->{struct}->{set_quantifier} = uc($1); 691 } 692 return undef unless ( $self->SELECT_LIST($str) ); 693} 694 695sub FROM_CLAUSE 696{ 697 my ( $self, $str ) = @_; 698 return undef unless $str; 699 if ( $str =~ m/ JOIN /i ) 700 { 701 return undef unless $self->EXPLICIT_JOIN($str); 702 } 703 else 704 { 705 return undef unless $self->TABLE_NAME_LIST($str); 706 } 707} 708 709sub INSERT 710{ 711 my ( $self, $str ) = @_; 712 my $col_str; 713 $str =~ s/^INSERT\s+INTO\s+/INSERT /i; # allow INTO to be optional 714 my ( $table_name, $val_str ) = $str =~ m/^INSERT\s+(.+?)\s+VALUES\s+(\(.+\))$/i; 715 if ( $table_name and $table_name =~ m/[()]/ ) 716 { 717 ( $table_name, $col_str, $val_str ) = $str =~ m/^INSERT\s+(.+?)\s+\((.+?)\)\s+VALUES\s+(\(.+\))$/i; 718 } 719 return $self->do_err('No table name specified!') unless ($table_name); 720 return $self->do_err('Missing values list!') unless ( defined $val_str ); 721 return undef unless ( $self->TABLE_NAME($table_name) ); 722 $self->{struct}->{command} = 'INSERT'; 723 $self->{struct}->{table_names} = [$table_name]; 724 if ($col_str) 725 { 726 return undef unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST($col_str) ); 727 } 728 else 729 { 730 $self->{struct}->{column_defs} = [ 731 { 732 type => 'column', 733 value => '*' 734 } 735 ]; 736 } 737 $self->{struct}->{values} = []; 738 for (my ($v,$line_str) = $val_str; 739 (($line_str,$v)=extract_bracketed($v,"('",'')) && defined $line_str; 740 ) { 741 return undef unless ( $self->LITERAL_LIST(substr($line_str,1,-1)) ); 742 last unless $v =~ s/\A\s*,\s*//; 743 } 744 745 return 1; 746} 747 748################################################################### 749# UPDATE ::= 750# 751# UPDATE <table> SET <set_clause_list> [ WHERE <search_condition>] 752# 753################################################################### 754sub UPDATE 755{ 756 my ( $self, $str ) = @_; 757 $self->{struct}->{command} = 'UPDATE'; 758 my ( $table_name, $remainder ) = $str =~ m/^UPDATE (.+?) SET (.+)$/i; 759 return $self->do_err('Incomplete UPDATE clause') unless ( $table_name && $remainder ); 760 return undef unless ( $self->TABLE_NAME($table_name) ); 761 $self->{tmp}->{is_table_name} = { $table_name => 1 }; 762 $self->{struct}->{table_names} = [$table_name]; 763 my ( $set_clause, $where_clause ) = $remainder =~ m/(.*?) WHERE (.*)$/i; 764 $set_clause = $remainder if ( !$set_clause ); 765 return undef unless ( $self->SET_CLAUSE_LIST($set_clause) ); 766 767 if ($where_clause) 768 { 769 return undef unless ( $self->SEARCH_CONDITION($where_clause) ); 770 } 771 772 my @vals = @{ $self->{struct}->{values}->[0] }; 773 my $num_val_placeholders = 0; 774 for my $v (@vals) 775 { 776 ++$num_val_placeholders if ( $v->{type} eq 'placeholder' ); 777 } 778 $self->{struct}->{num_val_placeholders} = $num_val_placeholders; 779 780 return 1; 781} 782 783############ 784# FUNCTIONS 785############ 786sub LOAD 787{ 788 my ( $self, $str ) = @_; 789 $self->{struct}->{command} = 'LOAD'; 790 $self->{struct}->{no_execute} = 1; 791 my ($package) = $str =~ /^LOAD\s+(.+)$/; 792 $str = $package; 793 $package =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; 794 795 $self->_load_class($package); 796 797 my %subs = eval '%' . $package . '::'; 798 799 for my $sub ( keys %subs ) 800 { 801 next unless ( $sub =~ m/^SQL_FUNCTION_([A-Z_0-9]+)$/ ); 802 my $funcName = uc $1; 803 my $subname = $package . '::' . 'SQL_FUNCTION_' . $funcName; 804 $self->{opts}->{function_names}->{$funcName} = $subname; 805 delete $self->{opts}->{_udf_function_names}; 806 } 807 1; 808} 809 810sub CREATE_RAM_TABLE 811{ 812 my ( $self, $stmt ) = @_; 813 $self->{struct}->{is_ram_table} = 1; 814 $self->{struct}->{command} = 'CREATE_RAM_TABLE'; 815 my ( $table_name, $table_element_def, %is_col_name ); 816 if ( $stmt =~ /^(\S+)\s+LIKE\s*(.+)$/si ) 817 { 818 $table_name = $1; 819 $table_element_def = $2; 820 if ( $table_element_def =~ /^(.*)\s+KEEP CONNECTION\s*$/i ) 821 { 822 $table_element_def = $1; 823 $self->{struct}->{ram_table_keep_connection} = 1; 824 } 825 } 826 else 827 { 828 return $self->CREATE("CREATE TABLE $stmt"); 829 } 830 return undef unless $self->TABLE_NAME($table_name); 831 for my $col ( split ',', $table_element_def ) 832 { 833 push( @{ $self->{struct}->{column_defs} }, $self->ROW_VALUE($col) ); 834 } 835 $self->{struct}->{table_names} = [$table_name]; 836 return 1; 837} 838 839sub CREATE_FUNCTION 840{ 841 my ( $self, $stmt ) = @_; 842 $self->{struct}->{command} = 'CREATE_FUNCTION'; 843 $self->{struct}->{no_execute} = 1; 844 my ( $func, $subname ); 845 $stmt =~ s/\s*EXTERNAL//i; 846 if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi ) 847 { 848 $func = trim($1); 849 $subname = trim($2); 850 } 851 $func ||= $stmt; 852 $subname ||= $func; 853 if ( $func =~ /^\?QI(\d+)\?$/ ) 854 { 855 $func = $self->{struct}->{quoted_ids}->[$1]; 856 } 857 if ( $subname =~ /^\?QI(\d+)\?$/ ) 858 { 859 $subname = $self->{struct}->{quoted_ids}->[$1]; 860 } 861 $self->{opts}->{function_names}->{ uc $func } = $subname; 862 delete $self->{opts}->{_udf_function_names}; 863 864 return 1; 865} 866 867sub CALL 868{ 869 my ( $self, $stmt ) = @_; 870 $stmt =~ s/^CALL\s+(.*)/$1/i; 871 $self->{struct}->{command} = 'CALL'; 872 $self->{struct}->{procedure} = $self->ROW_VALUE($stmt); 873 return 1; 874} 875 876sub CREATE_TYPE 877{ 878 my ( $self, $type ) = @_; 879 $self->{struct}->{command} = 'CREATE_TYPE'; 880 $self->{struct}->{no_execute} = 1; 881 $self->feature( 'valid_data_types', uc $type, 1 ); 882} 883 884sub DROP_TYPE 885{ 886 my ( $self, $type ) = @_; 887 $self->{struct}->{command} = 'DROP_TYPE'; 888 $self->{struct}->{no_execute} = 1; 889 $self->feature( 'valid_data_types', uc $type, 0 ); 890} 891 892sub CREATE_KEYWORD 893{ 894 my ( $self, $type ) = @_; 895 $self->{struct}->{command} = 'CREATE_KEYWORD'; 896 $self->{struct}->{no_execute} = 1; 897 $self->feature( 'reserved_words', uc $type, 1 ); 898} 899 900sub DROP_KEYWORD 901{ 902 my ( $self, $type ) = @_; 903 $self->{struct}->{command} = 'DROP_KEYWORD'; 904 $self->{struct}->{no_execute} = 1; 905 $self->feature( 'reserved_words', uc $type, 0 ); 906} 907 908sub CREATE_OPERATOR 909{ 910 my ( $self, $stmt ) = @_; 911 $self->{struct}->{command} = 'CREATE_OPERATOR'; 912 $self->{struct}->{no_execute} = 1; 913 914 my ( $func, $subname ); 915 $stmt =~ s/\s*EXTERNAL//i; 916 if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi ) 917 { 918 $func = trim($1); 919 $subname = trim($2); 920 } 921 $func ||= $stmt; 922 $subname ||= $func; 923 if ( $func =~ /^\?QI(\d+)\?$/ ) 924 { 925 $func = $self->{struct}->{quoted_ids}->[$1]; 926 } 927 if ( $subname =~ /^\?QI(\d+)\?$/ ) 928 { 929 $subname = $self->{struct}->{quoted_ids}->[$1]; 930 } 931 $self->{opts}->{function_names}->{ uc $func } = $subname; 932 delete $self->{opts}->{_udf_function_names}; 933 934 $self->feature( 'valid_comparison_operators', uc $func, 1 ); 935 return $self->create_op_regexen(); 936} 937 938sub DROP_OPERATOR 939{ 940 my ( $self, $type ) = @_; 941 $self->{struct}->{command} = 'DROP_OPERATOR'; 942 $self->{struct}->{no_execute} = 1; 943 $self->feature( 'valid_comparison_operators', uc $type, 0 ); 944 return $self->create_op_regexen(); 945} 946 947sub replace_quoted($) 948{ 949 my ( $self, $str ) = @_; 950 my @l = map { $self->replace_quoted_ids($_) } split( ',', $self->replace_quoted_commas($str) ); 951 return @l; 952} 953 954######### 955# CREATE 956######### 957sub CREATE 958{ 959 my ( $self, $stmt ) = @_; 960 my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE'; 961 if ( $stmt =~ m/^\s*CREATE\s+($features)\s+(.+)$/si ) 962 { 963 my ( $sub, $arg ) = ( $1, $2 ); 964 $sub = 'CREATE_' . uc $sub; 965 return $self->$sub($arg); 966 } 967 968 $stmt =~ s/^CREATE (LOCAL|GLOBAL) /CREATE /si; 969 if ( $stmt =~ m/^\s*CREATE\s+(?:TEMP|TEMPORARY)\s+TABLE\s+(.+)$/si ) 970 { 971 $stmt = "CREATE TABLE $1"; 972 $self->{struct}->{is_ram_table} = 1; 973 } 974 $self->{struct}->{command} = 'CREATE'; 975 my ( $table_name, $table_element_def, %is_col_name ); 976 977 if ( $stmt =~ m/^(.*) ON COMMIT (DELETE|PRESERVE) ROWS\s*$/si ) 978 { 979 $stmt = $1; 980 $self->{struct}->{commit_behaviour} = $2; 981 982 # return $self->do_err( 983 # "Can't specify commit behaviour for permanent tables." 984 # ) 985 # if !defined $self->{struct}->{table_type} 986 # or $self->{struct}->{table_type} !~ /TEMPORARY/; 987 } 988 if ( $stmt =~ m/^CREATE TABLE (\S+) \((.*)\)$/si ) 989 { 990 $table_name = $1; 991 $table_element_def = $2; 992 } 993 elsif ( $stmt =~ m/^CREATE TABLE (\S+) AS (.*)$/si ) 994 { 995 $table_name = $1; 996 my $subquery = $2; 997 return undef unless $self->TABLE_NAME($table_name); 998 $self->{struct}->{table_names} = [$table_name]; 999 1000 # undo subquery replaces 1001 $subquery =~ s/\?(\d+)\?/'$self->{struct}{literals}[$1]'/g; 1002 $subquery =~ s/\?QI(\d+)\?/"$self->{struct}->{quoted_ids}->[$1]"/g; 1003 $subquery =~ s/\?COMMA\?/,/gs; 1004 $self->{struct}->{subquery} = $subquery; 1005 if ( -1 != index( $subquery, '?' ) ) 1006 { 1007 ++$self->{struct}->{num_placeholders}; 1008 } 1009 return 1; 1010 } 1011 else 1012 { 1013 return $self->do_err("Can't find column definitions!"); 1014 } 1015 return undef unless ( $self->TABLE_NAME($table_name) ); 1016 $table_element_def =~ s/\s+\(/(/g; 1017 my $primary_defined; 1018 while ( 1019 $table_element_def =~ s/( # start of grouping 1 1020 \( # match a bracket; vi compatible bracket -> \)( 1021 [^)]+ # everything up to but not including the comma, no nesting of brackets is required 1022 ) # end of grouping 1 1023 , # the comma to be removed to allow splitting on commas 1024 ( # start of grouping 2; vi compatible bracket -> \( 1025 .*?\) # everything up to and including the end bracket 1026 )/$1?COMMA?$2/sgx 1027 ) 1028 { 1029 } 1030 1031 for my $col ( split( ',', $table_element_def ) ) 1032 { 1033 if ( 1034 $col =~ m/^\s*(?:CONSTRAINT\s+(\S+)\s*)? # optional name of foreign key 1035 FOREIGN\s+KEY\s*\(\s* # start of list of; vi compatibile bracket -> ( 1036 (\s*[^)]+\s*) # field names in this table 1037 \s*\)\s* # end of field names in this table 1038 REFERENCES # key word 1039 \s*(\S+)\s* # table name being referenced in foreign key 1040 \(\s* # start of list of; vi compatible bracket -> ( 1041 (\s*[^)]+\s*) # field names in foreign table 1042 \s*\)\s* # end of field names in foreign table 1043 $/x 1044 ) 1045 { 1046 my ( $name, $local_cols, $referenced_table, $referenced_cols ) = ( $1, $2, $3, $4 ); 1047 my @local_cols = $self->replace_quoted($local_cols); 1048 $referenced_table = $self->replace_quoted_ids($referenced_table); 1049 my @referenced_cols = $self->replace_quoted($referenced_cols); 1050 1051 if ( defined $name ) 1052 { 1053 $name = $self->replace_quoted_ids($name); 1054 } 1055 else 1056 { 1057 $name = $self->replace_quoted_ids($table_name); 1058 my ($quote_char) = ''; 1059 if ( $name =~ s/(\W)$// ) 1060 { 1061 $quote_char = ($1); 1062 } 1063 foreach my $local_col (@local_cols) 1064 { 1065 my $col_name = $local_col; 1066 $col_name =~ s/^\W//; 1067 $col_name =~ s/\W$//; 1068 $name .= '_' . $col_name; 1069 } 1070 $name .= '_fkey' . $quote_char; 1071 } 1072 1073 $self->{struct}->{table_defs}->{$name}->{type} = 'FOREIGN'; 1074 $self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols; 1075 $self->{struct}->{table_defs}->{$name}->{referenced_table} = $referenced_table; 1076 $self->{struct}->{table_defs}->{$name}->{referenced_cols} = \@referenced_cols; 1077 next; 1078 } 1079 elsif ( 1080 $col =~ m/^\s*(?:CONSTRAINT\s+(\S+)\s*)? # optional name of foreign key 1081 PRIMARY\s+KEY\s*\(\s* # start of list of; vi compatibile bracket -> ( 1082 (\s*[^)]+\s*) # field names in this table 1083 \s*\)\s* # end of field names in this table 1084 $/x 1085 ) 1086 { 1087 my ( $name, $local_cols ) = ( $1, $2 ); 1088 my @local_cols = $self->replace_quoted($local_cols); 1089 if ( defined $name ) 1090 { 1091 $name = $self->replace_quoted_ids($name); 1092 } 1093 else 1094 { 1095 $name = $table_name; 1096 if ( $name =~ s/(\W)$// ) 1097 { 1098 $name .= '_pkey' . $1; 1099 } 1100 else 1101 { 1102 $name .= '_pkey'; 1103 } 1104 } 1105 $self->{struct}->{table_defs}->{$name}->{type} = 'PRIMARY'; 1106 $self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols; 1107 next; 1108 } 1109 1110 # it seems, perl 5.6 isn't greedy enough .. let's help a bit 1111 my ($data_types_regex) = join( '|', sort { length($b) <=> length($a) } keys %{ $self->{opts}->{valid_data_types} } ); 1112 $data_types_regex =~ s/ /\\ /g; # backslash spaces to allow the /x modifier below 1113 my ( $name, $type, $suffix ) = ( 1114 $col =~ m/\s*(\S+)\s+ # capture the column name 1115 ((?:$data_types_regex|\S+) # check for all allowed data types OR anything that looks like a bad data type to give a good error 1116 (?:\s*\(\d+(?:\?COMMA\?\d+)?\))?) # allow the data type to have a precision specifier such as NUMERIC(4,6) on it 1117 \s*(\W.*|$) # capture the suffix of the column definition, e.g. constraints 1118 /ix 1119 ); 1120 return $self->do_err("Column definition is missing a data type!") unless ($type); 1121 return undef unless ( $self->IDENTIFIER($name) ); 1122 1123 $name = $self->replace_quoted_ids($name); 1124 1125 my @possible_constraints = ('PRIMARY KEY', 'NOT NULL', 'UNIQUE'); 1126 1127 for my $constraint (@possible_constraints) 1128 { 1129 my $count = $suffix =~ s/$constraint//gi; 1130 next if $count == 0; 1131 1132 return $self->do_err(qq~Duplicate column constraint: '$constraint'!~) 1133 if $count > 1; 1134 1135 return $self->do_err(qq{Can't have two PRIMARY KEYs in a table!}) 1136 if $constraint eq 'PRIMARY KEY' and $primary_defined++; 1137 1138 push @{ $self->{struct}->{table_defs}->{columns}->{$name}->{constraints} }, $constraint; 1139 } 1140 1141 $suffix =~ s/^\s+//; 1142 $suffix =~ s/\s+$//; 1143 1144 return $self->do_err("Unknown column constraint: '$suffix'!") unless ($suffix eq ''); 1145 1146 $type = uc $type; 1147 my $length; 1148 if ( $type =~ m/(.+)\((.+)\)/ ) 1149 { 1150 $type = $1; 1151 $length = $2; 1152 } 1153 if ( !$self->{opts}->{valid_data_types}->{$type} ) 1154 { 1155 return $self->do_err("'$type' is not a recognized data type!"); 1156 } 1157 $self->{struct}->{table_defs}->{columns}->{$name}->{data_type} = $type; 1158 $self->{struct}->{table_defs}->{columns}->{$name}->{data_length} = $length; 1159 push( 1160 @{ $self->{struct}->{column_defs} }, 1161 { 1162 type => 'column', 1163 value => $name, 1164 fullorg => $name, 1165 } 1166 ); 1167 1168 my $tmpname = $name; 1169 $tmpname = lc $tmpname unless ( $tmpname =~ m/^(?:\p{Word}+\.)?"/ ); 1170 return $self->do_err("Duplicate column names!") if $is_col_name{$tmpname}++; 1171 1172 } 1173 $self->{struct}->{table_names} = [$table_name]; 1174 return 1; 1175} 1176 1177############### 1178# SQL SUBRULES 1179############### 1180 1181sub SET_CLAUSE_LIST 1182{ 1183 my ( $self, $set_string ) = @_; 1184 my @sets = extract_multiple($set_string, [ 1185 sub { my ($m, $r, $p) = extract_bracketed($_[0], "()", qr/[^,(]*/); (($p||'').($m||''), $r, ''); }, 1186 qr/([^,(]+)/, 1187 ], undef, 1); 1188 my ( @cols, @vals ); 1189 for my $set (@sets) 1190 { 1191 my ( $col, $val ) = split( m/ = /, $set ); 1192 return $self->do_err('Incomplete SET clause!') unless ( defined($col) && defined($val) ); 1193 push( @cols, $col ); 1194 push( @vals, $val ); 1195 } 1196 return undef 1197 unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST( join ',', @cols ) ); 1198 return undef unless ( $self->LITERAL_LIST( join ',', @vals ) ); 1199 return 1; 1200} 1201 1202sub SET_QUANTIFIER 1203{ 1204 my ( $self, $str ) = @_; 1205 if ( $str =~ /^(DISTINCT|ALL)\s+(.*)$/si ) 1206 { 1207 $self->{struct}->{set_quantifier} = uc $1; 1208 $str = $2; 1209 } 1210 return $str; 1211} 1212 1213# 1214# DAA v1.11 1215# modify to transform || strings into 1216# CONCAT(<expr>); note that we 1217# only xform the topmost expressions; 1218# if a concat is contained within a subfunction, 1219# it should get handled by ROW_VALUE() 1220# 1221sub transform_concat 1222{ 1223 my ( $obj, $colstr ) = @_; 1224 1225 pos($colstr) = 0; 1226 my $parens = 0; 1227 my $spos = 0; 1228 my @concats = (); 1229 my $alias = ( $colstr =~ s/^(.+)(\s+AS\s+\S+)$/$1/ ) ? $2 : ''; 1230 1231 while ( $colstr =~ /\G.*?([\(\)\|])/gcs ) 1232 { 1233 if ( $1 eq '(' ) 1234 { 1235 $parens++; 1236 } 1237 elsif ( $1 eq ')' ) 1238 { 1239 $parens--; 1240 } 1241 elsif (( !$parens ) 1242 && ( substr( $colstr, $-[1] + 1, 1 ) eq '|' ) ) 1243 { 1244 1245 # 1246 # its a concat outside of parens, push prior string on stack 1247 # 1248 push @concats, substr( $colstr, $spos, $-[1] - $spos ); 1249 $spos = $+[1] + 1; 1250 pos($colstr) = $spos; 1251 } 1252 } 1253 1254 # 1255 # no concats, return original 1256 # 1257 return $colstr unless scalar @concats; 1258 1259 # 1260 # don't forget the last one! 1261 # 1262 push @concats, substr( $colstr, $spos ); 1263 return 'CONCAT(' . join( ', ', @concats ) . ")$alias"; 1264} 1265 1266# 1267# DAA v1.10 1268# improved column list extraction 1269# original doesn't seem to handle 1270# commas within function argument lists 1271# 1272# DAA v1.11 1273# modify to transform || strings into 1274# CONCAT(<expr-list>) 1275# 1276sub extract_column_list 1277{ 1278 my ( $self, $colstr ) = @_; 1279 1280 my @collist = (); 1281 pos($colstr) = 0; 1282 my $parens = 0; 1283 my $spos = 0; 1284 while ( $colstr =~ m/\G.*?([\(\),])/gcs ) 1285 { 1286 if ( $1 eq '(' ) 1287 { 1288 $parens++; 1289 } 1290 elsif ( $1 eq ')' ) 1291 { 1292 $parens--; 1293 } 1294 elsif ( !$parens ) 1295 { # its a comma outside of parens 1296 push( @collist, substr( $colstr, $spos, $-[1] - $spos ) ); 1297 $collist[-1] =~ s/^\s+//; 1298 $collist[-1] =~ s/\s+$//; 1299 return $self->do_err('Bad column list!') if ( $collist[-1] eq '' ); 1300 $spos = $+[1]; 1301 } 1302 } 1303 return $self->do_err('Unbalanced parentheses!') if ($parens); 1304 1305 # don't forget the last one! 1306 push( @collist, substr( $colstr, $spos ) ); 1307 $collist[-1] =~ s/^\s+//; 1308 $collist[-1] =~ s/\s+$//; 1309 return $self->do_err('Bad column list!') if ( $collist[-1] eq '' ); 1310 1311 # scan for and convert string concats to CONCAT() 1312 foreach ( 0 .. $#collist ) 1313 { 1314 $collist[$_] = $self->transform_concat( $collist[$_] ) if ( $collist[$_] =~ m/\|\|/ ); 1315 } 1316 1317 return @collist; 1318} 1319 1320sub SELECT_LIST 1321{ 1322 my ( $self, $col_str ) = @_; 1323 if ( $col_str =~ m/^\s*\*\s*$/ ) 1324 { 1325 $self->{struct}->{column_defs} = [ 1326 { 1327 type => 'column', 1328 value => '*' 1329 } 1330 ]; 1331 $self->{struct}->{column_aliases} = {}; 1332 1333 return 1; 1334 } 1335 my @col_list = $self->extract_column_list($col_str); 1336 return undef unless ( scalar(@col_list) ); 1337 1338 my ( @newcols, %aliases ); 1339 for my $col (@col_list) 1340 { 1341 # DAA: 1342 # need better alias test here, since AS is a common 1343 # keyword that might be used in a function 1344 my ( $fld, $alias ) = 1345 ( $col =~ m/^(.+?)\s+(?:AS\s+)?([A-Z]\p{Word}*|\?QI\d+\?)$/i ) 1346 ? ( $1, $2 ) 1347 : ( $col, undef ); 1348 $col = $fld; 1349 if ( $col =~ m/^(\S+)\.\*$/ ) 1350 { 1351 my $table = $1; 1352 if ( defined($alias) ) 1353 { 1354 return $self->do_err("'$table.*' cannot be aliased"); 1355 } 1356 $table = $self->{tmp}->{is_table_alias}->{$table} 1357 if ( $self->{tmp}->{is_table_alias}->{$table} ); 1358 $table = $self->{tmp}->{is_table_alias}->{"\L$table"} 1359 if ( $self->{tmp}->{is_table_alias}->{"\L$table"} ); 1360 return undef unless ( $self->TABLE_NAME($table) ); 1361 $table = $self->replace_quoted_ids($table); 1362 push( 1363 @newcols, 1364 { 1365 type => 'column', 1366 value => "$table.*", 1367 } 1368 ); 1369 } 1370 else 1371 { 1372 my $newcol; 1373 $newcol = $self->SET_FUNCTION_SPEC($col); 1374 return if ( $self->{struct}->{errstr} ); 1375 $newcol ||= $self->ROW_VALUE($col); 1376 return if ( $self->{struct}->{errstr} ); 1377 return $self->do_err("Invalid SELECT entry '$col'") 1378 unless ( defined( _HASH($newcol) ) ); 1379 1380 # FIXME this might be better done later and only if not 2 functions with the same name are selected 1381 if ( !defined($alias) 1382 && ( ( 'function' eq $newcol->{type} ) || ( 'setfunc' eq $newcol->{type} ) ) ) 1383 { 1384 $alias = $newcol->{name}; 1385 } 1386 1387 if ( defined($alias) ) 1388 { 1389 $alias = $self->replace_quoted_ids($alias); 1390 $newcol->{alias} = $alias; 1391 $aliases{ $newcol->{fullorg} } = $alias; 1392 $self->{struct}->{ORG_NAME}->{ $newcol->{fullorg} } = $alias; 1393 $self->{struct}->{ALIASES}->{$alias} = $newcol->{fullorg}; 1394 } 1395 push( @newcols, $newcol ); 1396 } 1397 } 1398 $self->{struct}->{column_aliases} = \%aliases; 1399 $self->{struct}->{column_defs} = \@newcols; 1400 return 1; 1401} 1402 1403sub SET_FUNCTION_SPEC 1404{ 1405 my ( $self, $col_str ) = @_; 1406 1407 if ( $col_str =~ m/^(COUNT|AVG|SUM|MAX|MIN) \((.*)\)\s*$/i ) 1408 { 1409 my $set_function_name = uc $1; 1410 my $set_function_arg_str = $2; 1411 my $distinct = 'ALL'; 1412 if ( $set_function_arg_str =~ s/(DISTINCT|ALL) (.+)$/$2/i ) 1413 { 1414 $distinct = uc $1; 1415 } 1416 my $count_star = ( $set_function_name eq 'COUNT' ) && ( $set_function_arg_str eq '*' ); 1417 1418 my $set_function_arg; 1419 if ($count_star) 1420 { 1421 return $self->do_err("Keyword DISTINCT is not allowed for COUNT(*)") 1422 if ( 'DISTINCT' eq $distinct ); 1423 $set_function_arg = { 1424 type => 'column', 1425 value => '*' 1426 }; 1427 } 1428 else 1429 { 1430 $set_function_arg = $self->ROW_VALUE($set_function_arg_str); 1431 return if ( $self->{struct}->{errstr} ); 1432 return unless ( defined( _HASH($set_function_arg) ) ); 1433 } 1434 1435 $self->{struct}->{has_set_functions} = 1; 1436 1437 my $value = { 1438 name => $set_function_name, 1439 arg => $set_function_arg, 1440 argstr => lc($set_function_arg_str), 1441 distinct => $distinct, 1442 type => 'setfunc', 1443 fullorg => $col_str, 1444 }; 1445 return $value; 1446 } 1447 else 1448 { 1449 return undef; 1450 } 1451} 1452 1453sub LIMIT_CLAUSE 1454{ 1455 my ( $self, $limit_clause ) = @_; 1456 1457 # $limit_clause = trim($limit_clause); 1458 $limit_clause =~ s/^\s+//; 1459 $limit_clause =~ s/\s+$//; 1460 1461 return 1 if !$limit_clause; 1462 my $offset; 1463 my $limit; 1464 my $junk; 1465($offset, $limit, $junk ) = split /,|OFFSET/i, $limit_clause; 1466 if ($limit_clause =~ m/(\d+)\s+OFFSET\s+(\d+)/) { 1467 $limit = $1; 1468 $offset = $2; 1469 } else { 1470 ( $offset, $limit, $junk ) = split /,/i, $limit_clause; 1471 } 1472 return $self->do_err('Bad limit clause!:'.$limit_clause) 1473 if ( defined $limit and $limit =~ /[^\d]/ ) 1474 or ( defined $offset and $offset =~ /[^\d]/ ) 1475 or defined $junk; 1476 if ( defined $offset and !defined $limit ) 1477 { 1478 $limit = $offset; 1479 undef $offset; 1480 } 1481 $self->{struct}->{limit_clause} = { 1482 limit => $limit, 1483 offset => $offset, 1484 }; 1485 return 1; 1486} 1487 1488sub SORT_SPEC_LIST 1489{ 1490 my ( $self, $order_clause ) = @_; 1491 return 1 if !$order_clause; 1492 my @ocols; 1493 my @order_columns = split ',', $order_clause; 1494 for my $col (@order_columns) 1495 { 1496 my $newcol; 1497 my $newarg; 1498 if ( $col =~ /\s*(\S+)\s+(ASC|DESC)/si ) 1499 { 1500 $newcol = $1; 1501 $newarg = uc $2; 1502 } 1503 elsif ( $col =~ /^\s*(\S+)\s*$/si ) 1504 { 1505 $newcol = $1; 1506 $newarg = 'ASC'; 1507 } 1508 else 1509 { 1510 return $self->do_err('Junk after column name in ORDER BY clause!'); 1511 } 1512 $newcol = $self->COLUMN_NAME($newcol) or return; 1513 if ( $newcol =~ /^(.+)\..+$/s ) 1514 { 1515 my $table = $1; 1516 $self->_verify_tablename( $table, "ORDER BY" ); 1517 } 1518 push( @ocols, { $newcol => $newarg } ); 1519 } 1520 $self->{struct}->{sort_spec_list} = \@ocols; 1521 return 1; 1522} 1523 1524sub SEARCH_CONDITION 1525{ 1526 my ( $self, $str ) = @_; 1527 $str =~ s/^\s*WHERE (.+)/$1/; 1528 $str =~ s/^\s+//; 1529 $str =~ s/\s+$//; 1530 return $self->do_err("Couldn't find WHERE clause!") unless $str; 1531 1532 # 1533 # DAA 1534 # make these OO so subclasses can override them 1535 # 1536 $str = $self->repl_btwin($str); 1537 1538 # 1539 # DAA 1540 # add another abstract method so subclasses 1541 # can inject their own syntax transforms 1542 # 1543 $str = $self->transform_syntax($str); 1544 1545 my $open_parens = $str =~ tr/\(//; 1546 my $close_parens = $str =~ tr/\)//; 1547 if ( $open_parens != $close_parens ) 1548 { 1549 return $self->do_err("Mismatched parentheses in WHERE clause!"); 1550 } 1551 $str = nongroup_numeric( $self->nongroup_string($str) ); 1552 my $pred = 1553 $open_parens 1554 ? $self->parens_search( $str, [] ) 1555 : $self->non_parens_search( $str, [] ); 1556 return $self->do_err("Couldn't find predicate!") unless $pred; 1557 $self->{struct}->{where_clause} = $pred; 1558 return 1; 1559} 1560 1561############################################################ 1562# UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE 1563############################################################ 1564 1565sub repl_btwin 1566{ 1567 my ( $self, $str ) = @_; # DAA make OO for subclassing 1568 my @lids; 1569 1570 my $i = -1; 1571 while ( $str =~ m/\G.*(?:IN|BETWEEN)\s+\(/g ) 1572 { 1573 my $start = pos($str) - 1; 1574 my $lparens = 1; 1575 my $rparens = 0; 1576 while ( $str =~ m/\G.*?([\(\)])/gcs ) 1577 { 1578 ++$lparens if ( '(' eq $1 ); 1579 ++$rparens if ( ')' eq $1 ); 1580 last if ( $lparens == $rparens ); 1581 } 1582 my $now = pos($str); 1583 ++$i; 1584 my $subst = "?LI$i?"; 1585 my $term = substr( $str, $start, $now - $start, $subst ); 1586 $term = substr( $term, 1, length($term) - 2 ); 1587 push( @lids, $term ); 1588 pos($str) = $start + length($subst); 1589 } 1590 1591 $self->{struct}->{list_ids} = \@lids; 1592 return $str; 1593} 1594 1595# groups clauses by nested parens 1596# 1597# DAA 1598# rewrite to correct paren scan 1599# and optimize code, and remove 1600# recursion 1601# 1602sub parens_search 1603{ 1604 my ( $self, $str, $predicates ) = @_; 1605 my $index = scalar( @{$predicates} ); 1606 1607 # to handle WHERE (a=b) AND (c=d) 1608 # but needs escape space to not foul up AND/OR 1609 1610 # locate all open parens 1611 # locate all close parens 1612 # apply non_paren_search to contents of 1613 # inner parens 1614 1615 my $lparens = ( $str =~ tr/\(// ); 1616 my $rparens = ( $str =~ tr/\)// ); 1617 return $self->do_err( 'Unmatched ' . ( ( $lparens > $rparens ) ? 'left' : 'right' ) . " parentheses in '$str'!" ) 1618 unless ( $lparens == $rparens ); 1619 1620 return $self->non_parens_search( $str, $predicates ) 1621 unless $lparens; 1622 1623 my @lparens = (); 1624 while ( $str =~ m/\G.*?([\(\)])/gcs ) 1625 { 1626 push( @lparens, $-[1] ), next 1627 if ( $1 eq '(' ); 1628 1629 # 1630 # got a close paren, so pop the position of matching 1631 # left paren and extract the expression, removing the 1632 # parens 1633 # 1634 my $pos = pop @lparens; 1635 my $predlen = $+[1] - $pos; 1636 my $pred = substr( $str, $pos + 1, $predlen - 2 ); 1637 1638 # 1639 # note that this will pass thru any prior ^$index^ xlation, 1640 # so we don't need to recurse to recover the predicate 1641 # 1642 substr( $str, $pos, $predlen ) = $pred, pos($str) = $pos + length($pred), next 1643 unless ( $pred =~ / (AND|OR) /i ); 1644 1645 # 1646 # handle AND/OR 1647 # 1648 push( @$predicates, substr( $str, $pos + 1, $predlen - 2 ) ); 1649 my $replacement = "^$#$predicates^"; 1650 substr( $str, $pos, $predlen ) = $replacement; 1651 pos($str) = $pos + length($replacement); 1652 } 1653 1654 return $self->non_parens_search( $str, $predicates ); 1655} 1656 1657# creates predicates from clauses that either have no parens 1658# or ANDs or have been previously grouped by parens and ANDs 1659# 1660# DAA 1661# rewrite to fix paren scanning 1662# 1663sub non_parens_search 1664{ 1665 my ( $self, $str, $predicates ) = @_; 1666 my $neg = 0; 1667 my $nots = {}; 1668 1669 $neg = 1, $nots = { pred => 1 } 1670 if ( $str =~ s/^NOT (\^.+)$/$1/i ); 1671 1672 my ( $pred1, $pred2, $op ); 1673 my $and_preds = []; 1674 ( $str, $and_preds ) = group_ands($str); 1675 $str = $and_preds->[$1] 1676 if $str =~ /^\s*~(\d+)~\s*$/; 1677 1678 return $self->non_parens_search( $$predicates[$1], $predicates ) 1679 if ( $str =~ /^\s*\^(\d+)\^\s*$/ ); 1680 1681 if ( $str =~ /\G(.*?)\s+(AND|OR)\s+(.*)$/igcs ) 1682 { 1683 ( $pred1, $op, $pred2 ) = ( $1, $2, $3 ); 1684 1685 if ( $pred1 =~ /^\s*\^(\d+)\^\s*$/ ) 1686 { 1687 $pred1 = $self->non_parens_search( $$predicates[$1], $predicates ); 1688 } 1689 else 1690 { 1691 $pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g; 1692 $pred1 = $self->non_parens_search( $pred1, $predicates ); 1693 } 1694 1695 # 1696 # handle pred2 as a full predicate 1697 # 1698 $pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g; 1699 $pred2 = $self->non_parens_search( $pred2, $predicates ); 1700 1701 return { 1702 neg => $neg, 1703 nots => $nots, 1704 arg1 => $pred1, 1705 op => uc $op, 1706 arg2 => $pred2, 1707 }; 1708 } 1709 1710 # 1711 # terminal predicate 1712 # need to check for singleton functions here 1713 # 1714 my $xstr = $str; 1715 my ( $k, $v ); 1716 if ( $str =~ /^\s*([A-Z]\p{Word}*)\s*\[/gcs ) 1717 { 1718 1719 # 1720 # we've got a function, check if its a singleton 1721 # 1722 my $parens = 1; 1723 my $spos = $-[1]; 1724 my $epos = 0; 1725 $epos = $-[1], $parens += ( $1 eq '[' ) ? 1 : -1 while ( ( $parens > 0 ) && ( $str =~ /\G.*?([\[\]])/gcs ) ); 1726 $k = substr( $str, $spos, $epos - $spos + 1 ); 1727 $k =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g; 1728 1729 # 1730 # for now we assume our parens are balanced 1731 # now look for a predicate operator and a right operand 1732 # 1733 $v = $1, $v =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g 1734 if ( $str =~ /\G\s+\S+\s*(.+)\s*$/gcs ); 1735 } 1736 else 1737 { 1738 $xstr =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g; 1739 ( $k, $v ) = $xstr =~ /^(\S+?)\s+\S+\s*(.+)\s*$/; 1740 } 1741 push @{ $self->{struct}{where_cols}{$k} }, $v 1742 if defined $k; 1743 return $self->PREDICATE($str); 1744} 1745 1746# groups AND clauses that aren't already grouped by parens 1747# 1748sub group_ands 1749{ 1750 my $str = shift; 1751 my $and_preds = shift || []; 1752 return ( $str, $and_preds ) 1753 unless $str =~ / AND / and $str =~ / OR /; 1754 1755 return $str, $and_preds 1756 unless ( $str =~ /^(.*?) AND (.*)$/i ); 1757 1758 my ( $front, $back ) = ( $1, $2 ); 1759 my $index = scalar @$and_preds; 1760 $front = $1 1761 if ( $front =~ /^.* OR (.*)$/i ); 1762 1763 $back = $1 1764 if ( $back =~ /^(.*?) (OR|AND) .*$/i ); 1765 1766 my $newpred = "$front AND $back"; 1767 push @$and_preds, $newpred; 1768 $str =~ s/\Q$newpred/~$index~/i; 1769 return group_ands( $str, $and_preds ); 1770} 1771 1772# replaces string function parens with square brackets 1773# e.g TRIM (foo) -> TRIM[foo] 1774# 1775# DAA update to support UDFs 1776# and remove recursion 1777# 1778sub nongroup_string 1779{ 1780 my ( $self, $str ) = @_; 1781 1782 # 1783 # add in any user defined functions 1784 # 1785 my $f = join( '|', FUNCTION_NAMES, $self->_udf_function_names ); 1786 1787 # 1788 # we need a scan here to permit arbitrarily nested paren 1789 # arguments to functions 1790 # 1791 my $parens = 0; 1792 my $pos; 1793 my @lparens = (); 1794 while ( $str =~ /\G.*?((\b($f)\s*\()|[\(\)])/igcs ) 1795 { 1796 if ( $1 eq ')' ) 1797 { 1798 # 1799 # close paren, see if any pending function open 1800 # paren matches it 1801 # 1802 --$parens; 1803 $pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ']', pos($str) = $pos, pop(@lparens) 1804 if ( @lparens && ( $lparens[-1] == $parens ) ); 1805 } 1806 elsif ( $1 eq '(' ) 1807 { 1808 1809 # 1810 # just an open paren, count it and go on 1811 # 1812 ++$parens; 1813 } 1814 else 1815 { 1816 1817 # 1818 # new function definition, capture its open paren 1819 # also uppercase the function name 1820 # 1821 $pos = $+[0]; 1822 substr( $str, $-[3], length($3) ) = uc $3; 1823 substr( $str, $+[0] - 1, 1 ) = '['; 1824 pos($str) = $pos; 1825 push @lparens, $parens; 1826 ++$parens; 1827 } 1828 } 1829 1830 # return $self->do_err('Unmatched ' . 1831 # (($parens > 0) ? 'left' : 'right') . ' parentheses!') 1832 # if $parens; 1833 # 1834 # DAA 1835 # remove scoped recursion 1836 # 1837 # return ( $str =~ /($f)\s*\(/i ) ? 1838 # nongroup_string($str) : $str; 1839 return $str; 1840} 1841 1842# replaces math parens with square brackets 1843# e.g (4-(6+7)*9) -> MATH[4-MATH[6+7]*9] 1844# 1845sub nongroup_numeric 1846{ 1847 my $str = $_[0]; 1848 my $has_op; 1849 1850 # 1851 # DAA 1852 # optimize regex 1853 # 1854 if ( $str =~ m/\(([\p{Word} \*\/\+\-\[\]\?]+)\)/ ) 1855 { 1856 my $match = $1; 1857 if ( $match !~ m/(LIKE |IS|BETWEEN|IN)/i ) 1858 { 1859 my $re = quotemeta($match); 1860 $str =~ s/\($re\)/MATH\[$match\]/; 1861 } 1862 else 1863 { 1864 $has_op++; 1865 } 1866 } 1867 1868 # 1869 # DAA 1870 # remove scoped recursion 1871 # 1872 return ( !$has_op and $str =~ /\(([\p{Word} \*\/\+\-\[\]\?]+)\)/ ) 1873 ? nongroup_numeric($str) 1874 : $str; 1875} 1876############################################################ 1877 1878######################################################### 1879# LITERAL_LIST ::= <literal> [,<literal>] 1880######################################################### 1881sub LITERAL_LIST 1882{ 1883 my ( $self, $str ) = @_; 1884 my @tokens = extract_multiple($str, [ 1885 sub { my ($m, $r, $p) = extract_bracketed($_[0], "()", qr/[^,(]*/); (($p||'').($m||''), $r, ''); }, 1886 qr/([^,(]+)/, 1887 ], undef, 1); 1888 my @values; 1889 for my $tok (@tokens) 1890 { 1891 my $val = $self->ROW_VALUE($tok); 1892 return $self->do_err(qq('$tok' is not a valid value or is not quoted!)) 1893 unless $val; 1894 push @values, $val; 1895 } 1896 push( @{ $self->{struct}->{values} }, \@values ); 1897 return 1; 1898} 1899 1900############################################################################# 1901# LITERAL ::= <quoted_string> | <question mark> | <number> | NULL/TRUE/FALSE 1902############################################################################# 1903sub LITERAL 1904{ 1905 my ( $self, $str ) = @_; 1906 1907 # 1908 # DAA 1909 # strip parens (if any) 1910 # 1911 $str = $1 while ( $str =~ m/^\s*\(\s*(.+)\s*\)\s*$/ ); 1912 1913 return 'null' if $str =~ m/^NULL$/i; # NULL 1914 return 'boolean' if $str =~ m/^(?:TRUE|FALSE)$/i; # TRUE/FALSE 1915 1916 # return 'empty_string' if $str =~ /^~E~$/i; # NULL 1917 if ( $str eq '?' ) 1918 { 1919 $self->{struct}->{num_placeholders}++; 1920 return 'placeholder'; 1921 } 1922 1923 # return 'placeholder' if $str eq '?'; # placeholder question mark 1924 return 'string' if $str =~ m/^'.*'$/s; # quoted string 1925 # return 'number' if $str =~ m/^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; # number 1926 return 'number' if ( looks_like_number($str) ); # number 1927 1928 return undef; 1929} 1930################################################################### 1931# PREDICATE 1932################################################################### 1933sub PREDICATE 1934{ 1935 my ( $self, $str ) = @_; 1936 1937 my ( $arg1, $op, $arg2, $opexp ); 1938 1939 $opexp = $self->{opts}{valid_comparison_NOT_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i 1940 if $self->{opts}{valid_comparison_NOT_ops_regex}; 1941 1942 $opexp = $self->{opts}{valid_comparison_twochar_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i 1943 if ( !defined($op) 1944 && $self->{opts}{valid_comparison_twochar_ops_regex} ); 1945 1946 $opexp = $self->{opts}{valid_comparison_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i 1947 if ( !defined($op) && $self->{opts}{valid_comparison_ops_regex} ); 1948 1949 # 1950 ### USER-DEFINED PREDICATE 1951 # 1952 unless ( defined $arg1 && defined $op && defined $arg2 ) 1953 { 1954 $arg1 = $str; 1955 $op = 'USER_DEFINED'; 1956 $arg2 = ''; 1957 } 1958 1959 $op = uc $op; 1960 1961 # my $uname = $self->is_func($arg1); 1962 # if (!$uname) { 1963 # $arg1 =~ s/^(\S+).*$/$1/; 1964 # return $self->do_err("Bad predicate: '$arg1'!"); 1965 # } 1966 1967 my $negated = 0; # boolean value showing if predicate is negated 1968 my %not; # hash showing elements modified by NOT 1969 # 1970 # e.g. "NOT bar = foo" -> %not = (arg1=>1) 1971 # "bar NOT LIKE foo" -> %not = (op=>1) 1972 # "NOT bar NOT LIKE foo" -> %not = (arg1=>1,op=>1); 1973 # "NOT bar IS NOT NULL" -> %not = (arg1=>1,op=>1); 1974 # "bar = foo" -> %not = undef; 1975 # 1976 $not{arg1}++ 1977 if ( $arg1 =~ s/^NOT (.+)$/$1/i ); 1978 1979 $not{op}++ 1980 if ( $op =~ s/^(.+) NOT$/$1/i 1981 || $op =~ s/^NOT (.+)$/$1/i ); 1982 1983 $negated = 1 if %not and scalar keys %not == 1; 1984 1985 return undef unless $arg1 = $self->ROW_VALUE($arg1); 1986 1987 if ( $op ne 'USER_DEFINED' ) 1988 { # USER-PREDICATE; 1989 return undef unless $arg2 = $self->ROW_VALUE($arg2); 1990 } 1991 else 1992 { 1993 1994 # $arg2 = $self->ROW_VALUE($arg2); 1995 } 1996 1997 if ( defined( _HASH($arg1) ) 1998 and defined( _HASH($arg2) ) 1999 and ( ( $arg1->{type} || '' ) eq 'column' ) 2000 and ( ( $arg2->{type} || '' ) eq 'column' ) 2001 and ( $op eq '=' ) ) 2002 { 2003 push( @{ $self->{struct}->{keycols} }, $arg1->{value} ); 2004 push( @{ $self->{struct}->{keycols} }, $arg2->{value} ); 2005 } 2006 2007 return { 2008 neg => $negated, 2009 nots => \%not, 2010 arg1 => $arg1, 2011 op => $op, 2012 arg2 => $arg2, 2013 }; 2014} 2015 2016sub _udf_function_names 2017{ 2018 $_[0]->{opts}->{_udf_function_names} 2019 or return $_[0]->{opts}->{_udf_function_names} = join( "|", map { uc $_ } keys %{ $_[0]->{opts}->{function_names} } ); 2020 $_[0]->{opts}->{_udf_function_names}; 2021} 2022 2023sub undo_string_funcs 2024{ 2025 my ( $self, $str ) = @_; 2026 my $f = join( '|', FUNCTION_NAMES, $self->_udf_function_names ); 2027 2028 # eliminate recursion: 2029 # we have to scan for closing brackets, since we may 2030 # have intervening MATH elements with brackets 2031 my ( $brackets, $pos, @lbrackets ) = (0); 2032 while ( $str =~ /\G.*?((\b($f)\s*\[)|[\[\]])/igcs ) 2033 { 2034 if ( $1 eq ']' ) 2035 { 2036 # close paren, see if any pending function open 2037 # paren matches it 2038 $brackets--; 2039 $pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ')', pos($str) = $pos, pop @lbrackets 2040 if ( @lbrackets && ( $lbrackets[-1] == $brackets ) ); 2041 } 2042 elsif ( $1 eq '[' ) 2043 { 2044 # just an open paren, count it and go on 2045 $brackets++; 2046 } 2047 else 2048 { 2049 # new function definition, capture its open paren 2050 # also uppercase the function name 2051 $pos = $+[0]; 2052 substr( $str, $-[3], length($3) ) = uc $3; 2053 substr( $str, $+[0] - 1, 1 ) = '('; 2054 pos($str) = $pos; 2055 push @lbrackets, $brackets; 2056 $brackets++; 2057 } 2058 } 2059 2060 return $str; 2061} 2062 2063sub undo_math_funcs 2064{ 2065 my $str = $_[0]; 2066 2067 # eliminate recursion 2068 while ( $str =~ s/MATH\[([^\]\[]+?)\]/($1)/ ) 2069 { 2070 } 2071 2072 return $str; 2073} 2074 2075# 2076# DAA 2077# need better nested function/parens handling 2078# 2079sub extract_func_args 2080{ 2081 my ( $self, $value ) = @_; 2082 2083 my @final_args = (); 2084 my ( $spos, $parens, $epos, $delim ) = ( 0, 0, 0, 0 ); 2085 while ( $value =~ m/\G.*?([\(\),])/gcs ) 2086 { 2087 $epos = $+[0]; 2088 $delim = $1; 2089 unless ( $parens or ( $delim ne ',' ) ) 2090 { 2091 push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos - 1 ) ) ); 2092 $spos = $epos; 2093 next; 2094 } 2095 2096 unless ( $delim eq ',' ) 2097 { 2098 $parens += ( $delim eq '(' ) ? 1 : -1; 2099 } 2100 } 2101 2102 # don't forget the last argument 2103 if ( $spos != length($value) ) 2104 { 2105 $epos = length($value); 2106 push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos ) ) ); # XXX 2107 } 2108 2109 return @final_args; 2110} 2111 2112################################################################### 2113# ROW_VALUE ::= <literal> | <column_name> 2114################################################################### 2115sub ROW_VALUE 2116{ 2117 my ( $self, $str ) = @_; 2118 2119 $str =~ s/^\s+//; 2120 $str =~ s/\s+$//; 2121 $str = $self->undo_string_funcs($str); 2122 $str = undo_math_funcs($str); 2123 my ( $orgstr, $f, $bf ) = ( $str, FUNCTION_NAMES, BAREWORD_FUNCTIONS ); 2124 2125 # USER-DEFINED FUNCTION 2126 my ( $user_func_name, $user_func_args, $is_func ); 2127 2128 # DAA 2129 # need better paren check here 2130 if ( $str =~ m/^([^\s\(]+)\s*(.*)\s*$/ ) 2131 { 2132 $user_func_name = $1; 2133 $user_func_args = $2; 2134 2135 # convert operator-like function to parenthetical format 2136 if ( ( $is_func = $self->is_func($user_func_name) ) 2137 && ( $user_func_args !~ m/^\(.*\)$/ ) 2138 && ( $is_func =~ /^(?:$bf)$/i ) ) 2139 { 2140 $orgstr = $str = "$user_func_name ($user_func_args)"; 2141 } 2142 } 2143 else 2144 { 2145 $user_func_name = $str; 2146 $user_func_name =~ s/^(\S+).*$/$1/; 2147 $user_func_args = ''; 2148 $is_func = $self->is_func($user_func_name); 2149 } 2150 2151 # BLKB 2152 # Limiting the parens convert shortcut, so that "SELECT LOG(1), PI" works as a 2153 # two functions, and "SELECT x FROM log" works as a table 2154 undef $is_func if ( $is_func && $is_func !~ /^(?:$bf)$/i && $str !~ m/^\S+\s*\(.*\)\s*$/ ); 2155 2156 if ( $is_func && ( uc($is_func) !~ m/^($f)$/ ) ) 2157 { 2158 my ( $name, $value ) = ( $user_func_name, '' ); 2159 if ( $str =~ m/^(\S+)\s*\((.*)\)\s*$/ ) 2160 { 2161 $name = $1; 2162 $value = $2; 2163 $is_func = $self->is_func($name); 2164 } 2165 2166 if ($is_func) 2167 { 2168 # 2169 # DAA 2170 # need a better argument extractor, since it can 2171 # contain arbitrary (possibly parenthesized) 2172 # expressions/functions 2173 # 2174 # if ($value =~ /\(/ ) { 2175 # $value = $self->ROW_VALUE($value); 2176 # } 2177 # my @args = split ',',$value; 2178 2179 my @final_args = $self->extract_func_args($value); 2180 my $usr_sub = $self->{opts}->{function_names}->{$is_func}; 2181 $self->{struct}->{procedure} = {}; 2182 if ($usr_sub) 2183 { 2184 $value = { 2185 type => 'function', 2186 name => lc $name, 2187 subname => $usr_sub, 2188 value => \@final_args, 2189 fullorg => $orgstr, 2190 }; 2191 2192 return $value; 2193 } 2194 } 2195 } 2196 2197 my $type; 2198 # MATH 2199 # 2200 if ( $str =~ m/[\*\+\-\/\%]/ ) 2201 { 2202 my @vals; 2203 my $i = -1; 2204 my $open_parens = $str =~ tr/\(//; 2205 my $close_parens = $str =~ tr/\)//; 2206 if ( $open_parens != $close_parens ) 2207 { 2208 return $self->do_err("Mismatched parentheses in term '$str'!"); 2209 } 2210 2211 # $str =~ s/([^\s\*\+\-\/\%\)\(]+)/push @vals,$1;++$i;"?$i?"/ge; 2212 while ( $str =~ m/\G.*?([^\s\*\+\-\/\%\)\(]+)/g ) 2213 { 2214 my $term = $1; 2215 my $start = pos($str) - length($term); 2216 if ( $self->is_func($term) ) 2217 { 2218 my $lparens = 0; 2219 my $rparens = 0; 2220 while ( $str =~ m/\G.*?([\(\)])/gcs ) 2221 { 2222 ++$lparens if ( '(' eq $1 ); 2223 ++$rparens if ( ')' eq $1 ); 2224 last if ( $lparens == $rparens ); 2225 } 2226 my $now = pos($str); 2227 ++$i; 2228 $term = substr( $str, $start, $now - $start, "?$i?" ); 2229 push( @vals, $term ); 2230 pos($str) = $start + length("?$i?"); 2231 } 2232 else 2233 { 2234 push( @vals, $term ); 2235 ++$i; 2236 substr( $str, $start, length($term), "?$i?" ); 2237 pos($str) = $start + length("?$i?"); 2238 } 2239 } 2240 2241 my @newvalues; 2242 foreach my $val (@vals) 2243 { 2244 my $newval = $self->ROW_VALUE($val); 2245 if ( $newval && $newval->{type} !~ m/number|column|placeholder|function/ ) 2246 { 2247 return $self->do_err(qq[String '$val' not allowed in Numeric expression!]); 2248 } 2249 push( @newvalues, $newval ); 2250 } 2251 2252 return { 2253 type => 'function', 2254 name => 'numeric_exp', 2255 str => $str, 2256 value => \@newvalues, 2257 fullorg => $orgstr, 2258 }; 2259 } 2260 2261 # SUBSTRING (value FROM start [FOR length]) 2262 # 2263 if ( $str =~ m/^SUBSTRING \((.+?) FROM (.+)\)\s*$/i ) 2264 { 2265 my $name = 'SUBSTRING'; 2266 my $start = $2; 2267 my $value = $self->ROW_VALUE($1); 2268 my $length; 2269 if ( $start =~ /^(.+?) FOR (.+)$/i ) 2270 { 2271 $start = $1; 2272 $length = $2; 2273 $length = $self->ROW_VALUE($length); 2274 } 2275 $start = $self->ROW_VALUE($start); 2276 $str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; 2277 if ( ( $start->{type} eq 'string' ) 2278 or ( $start->{length} && ( $start->{length}->{type} eq 'string' ) ) ) 2279 { 2280 return $self->do_err("Can't use a string as a SUBSTRING position: '$str'!"); 2281 } 2282 return undef unless ($value); 2283 return $self->do_err("Can't use a number in SUBSTRING: '$str'!") 2284 if $value->{type} eq 'number'; 2285 return { 2286 type => 'function', 2287 name => $name, 2288 value => [$value], 2289 start => $start, 2290 length => $length, 2291 fullorg => $orgstr, 2292 }; 2293 } 2294 2295 # TRIM ( [ [TRAILING|LEADING|BOTH] ['char'] FROM ] value ) 2296 # 2297 if ( $str =~ m/^(TRIM) \((.+)\)\s*$/i ) 2298 { 2299 my $name = uc $1; 2300 my $value = $2; 2301 my ( $trim_spec, $trim_char ); 2302 if ( $value =~ m/^(.+) FROM ([^\(\)]+)$/i ) 2303 { 2304 my $front = $1; 2305 $value = $2; 2306 if ( $front =~ m/^\s*(TRAILING|LEADING|BOTH)(.*)$/i ) 2307 { 2308 $trim_spec = uc $1; 2309 $trim_char = $2; 2310 $trim_char =~ s/^\s+//; 2311 $trim_char =~ s/\s+$//; 2312 undef $trim_char if ( length($trim_char) == 0 ); 2313 } 2314 else 2315 { 2316 $trim_char = $front; 2317 $trim_char =~ s/^\s+//; 2318 $trim_char =~ s/\s+$//; 2319 } 2320 } 2321 2322 $trim_char ||= ''; 2323 $trim_char =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; 2324 $value = $self->ROW_VALUE($value); 2325 return undef unless ($value); 2326 $str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; 2327 my $value_type = $value->{type} if ref $value eq 'HASH'; 2328 $value_type = $value->[0] if ( defined( _ARRAY($value) ) ); 2329 return $self->do_err("Can't use a number in TRIM: '$str'!") 2330 if ( $value_type and $value_type eq 'number' ); 2331 2332 return { 2333 type => 'function', 2334 name => $name, 2335 value => [$value], 2336 trim_spec => $trim_spec, 2337 trim_char => $trim_char, 2338 fullorg => $orgstr, 2339 }; 2340 } 2341 2342 # UNKNOWN FUNCTION 2343 if ( $str =~ m/^(\S+) \(/ ) 2344 { 2345 return $self->do_err("Unknown function '$1'"); 2346 } 2347 2348 # STRING CONCATENATION 2349 # 2350 if ( $str =~ m/\|\|/ ) 2351 { 2352 my @vals = split( m/ \|\| /, $str ); 2353 my @newvals; 2354 for my $val (@vals) 2355 { 2356 my $newval = $self->ROW_VALUE($val); 2357 return undef unless ($newval); 2358 return $self->do_err("Can't use a number in string concatenation: '$str'!") 2359 if ( $newval->{type} eq 'number' ); 2360 push @newvals, $newval; 2361 } 2362 return { 2363 type => 'function', 2364 name => 'str_concat', 2365 value => \@newvals, 2366 fullorg => $orgstr, 2367 }; 2368 } 2369 2370 # NULL, BOOLEAN, PLACEHOLDER, NUMBER 2371 # 2372 if ( $type = $self->LITERAL($str) ) 2373 { 2374 undef $str if ( $type eq 'null' ); 2375 $str = 1 if ( $type eq 'boolean' and $str =~ /^TRUE$/i ); 2376 $str = 0 if ( $type eq 'boolean' and $str =~ /^FALSE$/i ); 2377 2378 # if ($type eq 'empty_string') { 2379 # $str = ''; 2380 # $type = 'string'; 2381 # } 2382 $str = '' if ( $str and $str eq q('') ); 2383 return { 2384 type => $type, 2385 value => $str, 2386 fullorg => $orgstr, 2387 }; 2388 } 2389 2390 # QUOTED STRING LITERAL 2391 # 2392 if ( $str =~ m/\?(\d+)\?/ ) 2393 { 2394 return { 2395 type => 'string', 2396 value => $self->{struct}->{literals}->[$1], 2397 fullorg => $self->{struct}->{literals}->[$1], 2398 }; 2399 } 2400 elsif ( $str =~ /^\?LI(\d+)\?$/ ) 2401 { 2402 return $self->ROW_VALUE_LIST( $self->{struct}->{list_ids}->[$1] ); 2403 } 2404 2405 # COLUMN NAME 2406 # 2407 return undef unless ( $str = $self->COLUMN_NAME($str) ); 2408 2409 if ( $str =~ m/^(.*)\./ ) 2410 { 2411 my $table_name = $1; 2412 $self->_verify_tablename( $table_name, "WHERE" ); 2413 } 2414 2415 # push @{ $self->{struct}->{where_cols}},$str 2416 # unless $self->{tmp}->{where_cols}->{"$str"}; 2417 ++$self->{tmp}->{where_cols}->{$str}; 2418 return { 2419 type => 'column', 2420 value => $str, 2421 fullorg => $orgstr, 2422 }; 2423} 2424 2425######################################################### 2426# ROW_VALUE_LIST ::= <row_value> [,<row_value>...] 2427######################################################### 2428sub ROW_VALUE_LIST 2429{ 2430 my ( $self, $row_str ) = @_; 2431 my @row_list = split ',', $row_str; 2432 if ( !( scalar @row_list ) ) 2433 { 2434 return $self->do_err('Missing row value list!'); 2435 } 2436 my @newvals; 2437 my $newval; 2438 for my $row_val (@row_list) 2439 { 2440 $row_val =~ s/^\s+//; 2441 $row_val =~ s/\s+$//; 2442 2443 return undef if !( $newval = $self->ROW_VALUE($row_val) ); 2444 push @newvals, $newval; 2445 } 2446 return \@newvals; 2447} 2448 2449############################################### 2450# COLUMN NAME ::= [<table_name>.] <identifier> 2451############################################### 2452 2453sub COLUMN_NAME 2454{ 2455 my ( $self, $str ) = @_; 2456 my ( $table_name, $col_name ); 2457 if ( $str =~ m/^\s*(\S+)\.(\S+)$/s ) 2458 { 2459 ( $table_name, $col_name ) = ( $1, $2 ); 2460 if ( !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} ) 2461 { 2462 return $self->do_err('Dialect does not support multiple tables!'); 2463 } 2464 return undef unless ( $table_name = $self->TABLE_NAME($table_name) ); 2465 $table_name = $self->replace_quoted_ids($table_name); 2466 $self->_verify_tablename($table_name); 2467 } 2468 else 2469 { 2470 $col_name = $str; 2471 } 2472 2473 $col_name =~ s/^\s+//; 2474 $col_name =~ s/\s+$//; 2475 2476 my $user_func = $col_name; 2477 $user_func =~ s/^(\S+).*$/$1/; 2478 if ( $col_name !~ m/^(TRIM|SUBSTRING)$/i ) 2479 { 2480 undef $user_func unless ( $self->{opts}->{function_names}->{ uc $user_func } ); 2481 } 2482 if ( !$user_func ) 2483 { 2484 return undef unless ( ( $col_name eq '*' ) || $self->IDENTIFIER($col_name) ); 2485 } 2486 2487 # 2488 # MAKE COL NAMES ALL UPPER CASE UNLESS IS DELIMITED IDENTIFIER 2489 my $orgcol = $col_name; 2490 2491 if ( $col_name =~ m/^\?QI(\d+)\?$/ ) 2492 { 2493 $col_name = '"' . $self->{struct}->{quoted_ids}->[$1] . '"'; 2494 } 2495 else 2496 { 2497 $col_name = lc $col_name 2498 unless ( 2499 ( $self->{struct}->{command} eq 'CREATE' ) 2500 ############################################## 2501 # 2502 # JZ addition to RR's alias patch 2503 # 2504 or ( $col_name =~ m/^(?:\p{Word}+\.)?"/ ) 2505 ); 2506 2507 } 2508 2509 # 2510 $col_name = $self->{struct}->{column_aliases}->{$col_name} 2511 if ( $self->{struct}->{column_aliases}->{$col_name} ); 2512 2513 # $orgcol = $self->replace_quoted_ids($orgcol); 2514 ############################################## 2515 2516 if ($table_name) 2517 { 2518 my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"}; 2519 $table_name = $alias if ( defined($alias) ); 2520 $table_name = lc $table_name unless ( $table_name =~ m/^"/ ); 2521 $col_name = "$table_name.$col_name" if ( -1 == index( $col_name, '.' ) ); 2522 } 2523 return $col_name; 2524} 2525 2526######################################################### 2527# COLUMN NAME_LIST ::= <column_name> [,<column_name>...] 2528######################################################### 2529sub COLUMN_NAME_LIST 2530{ 2531 my ( $self, $col_str ) = @_; 2532 2533 my @col_list = split( ',', $col_str ); 2534 return $self->do_err('Missing column name list!') unless ( scalar(@col_list) ); 2535 2536 my @newcols; 2537 for my $col (@col_list) 2538 { 2539 $col =~ s/^\s+//; 2540 $col =~ s/\s+$//; 2541 2542 my $newcol; 2543 return undef unless ( $newcol = $self->COLUMN_NAME($col) ); 2544 push( @newcols, $newcol ); 2545 } 2546 2547 return \@newcols; 2548} 2549 2550##################################################### 2551# TABLE_NAME_LIST := <table_name> [,<table_name>...] 2552##################################################### 2553sub TABLE_NAME_LIST 2554{ 2555 my ( $self, $table_name_str ) = @_; 2556 my %aliases = (); 2557 my @tables; 2558 $table_name_str =~ s/(\?\d+\?),/$1:/g; # fudge commas in functions 2559 my @table_names = split ',', $table_name_str; 2560 if ( scalar @table_names > 1 2561 and !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} ) 2562 { 2563 return $self->do_err('Dialect does not support multiple tables!'); 2564 } 2565 2566 my $bf = BAREWORD_FUNCTIONS; 2567 my %is_table_alias; 2568 for my $table_str (@table_names) 2569 { 2570 $table_str =~ s/(\?\d+\?):/$1,/g; # unfudge commas in functions 2571 $table_str =~ s/\s+\(/\(/g; # fudge spaces in functions 2572 my ( $table, $alias ); 2573 my (@tstr) = split( m/\s+/, $table_str ); 2574 if ( @tstr == 1 ) 2575 { 2576 $table = $tstr[0]; 2577 } 2578 elsif ( @tstr == 2 ) 2579 { 2580 $table = $tstr[0]; 2581 $alias = $tstr[1]; 2582 } 2583 elsif ( @tstr == 3 ) 2584 { 2585 return $self->do_err("Can't find alias in FROM clause!") 2586 unless ( uc( $tstr[1] ) eq 'AS' ); 2587 $table = $tstr[0]; 2588 $alias = $tstr[2]; 2589 } 2590 else 2591 { 2592 return $self->do_err("Can't find table names in FROM clause!"); 2593 } 2594 2595 $table =~ s/\(/ \(/g; # unfudge spaces in functions 2596 my $u_name = $table; 2597 $u_name =~ s/^(\S+)\s*(.*$)/$1/; 2598 my $u_args = $2; 2599 2600 if ( ( $u_name = $self->is_func($u_name) ) 2601 && ( $u_name =~ /^(?:$bf)$/i || $table =~ /^$u_name\s*\(/i ) ) 2602 { 2603 $u_args = " $u_args" if ($u_args); 2604 my $u_func = $self->ROW_VALUE( $u_name . $u_args ); 2605 $self->{struct}->{table_func}->{$u_name} = $u_func; 2606 $self->{struct}->{temp_table} = 1; 2607 $table = $u_name; 2608 } 2609 else 2610 { 2611 return undef unless ( $self->TABLE_NAME($table) ); 2612 } 2613 2614 $table = $self->replace_quoted_ids($table); 2615 push( @tables, $table =~ m/^"/ ? $table : $table ); 2616 2617 if ($alias) 2618 { 2619 return unless ( $self->TABLE_NAME($alias) ); 2620 $alias = $self->replace_quoted_ids($alias); 2621 if ( $alias =~ m/^"/ ) 2622 { 2623 push( @{ $aliases{$table} }, $alias ); 2624 $is_table_alias{$alias} = $table; 2625 } 2626 else 2627 { 2628 push( @{ $aliases{$table} }, "\L$alias" ); 2629 $is_table_alias{"\L$alias"} = $table; 2630 } 2631 } 2632 } 2633 my %is_table_name = map { $_ => 1 } @tables; 2634 $self->{tmp}->{is_table_alias} = \%is_table_alias; 2635 $self->{tmp}->{is_table_name} = \%is_table_name; 2636 $self->{struct}->{table_names} = \@tables; 2637 $self->{struct}->{table_alias} = \%aliases; 2638 $self->{struct}->{multiple_tables} = 1 if ( @tables > 1 ); 2639 return 1; 2640} 2641 2642sub is_func($) 2643{ 2644 my ( $self, $name ) = @_; 2645 $name =~ s/^(\S+).*$/$1/; 2646 return $name if ( $self->{opts}->{function_names}->{$name} ); 2647 return uc $name if ( $self->{opts}->{function_names}->{ uc $name } ); 2648 undef; 2649} 2650 2651############################# 2652# TABLE_NAME := <identifier> 2653############################# 2654sub TABLE_NAME 2655{ 2656 my ( $self, $table_name ) = @_; 2657 if ( $table_name =~ m/^(.+?)\.([^\.]+)$/ ) 2658 { 2659 my $schema = $1; # ignored 2660 $table_name = $2; 2661 } 2662 if ( $table_name =~ m/\s*(\S+)\s+\S+/s ) 2663 { 2664 return $self->do_err("Junk after table name '$1'!"); 2665 } 2666 $table_name =~ s/\s+//s; 2667 if ( !$table_name ) 2668 { 2669 return $self->do_err('No table name specified!'); 2670 } 2671 return $table_name if ( $self->IDENTIFIER($table_name) ); 2672 2673 # return undef if !($self->IDENTIFIER($table_name)); 2674 # return 1; 2675} 2676 2677sub _verify_tablename 2678{ 2679 my ( $self, $table_name, $location ) = @_; 2680 if ( defined($location) ) 2681 { 2682 $location = " in $location"; 2683 } 2684 else 2685 { 2686 $location = ""; 2687 } 2688 2689 if ( $table_name =~ m/^"/ ) 2690 { 2691 if ( !$self->{tmp}->{is_table_name}->{$table_name} 2692 and !$self->{tmp}->{is_table_alias}->{$table_name} ) 2693 { 2694 return $self->do_err("Table '$table_name' referenced$location but not found in FROM list!"); 2695 } 2696 } 2697 else 2698 { 2699 my @tblnamelist = ( keys( %{ $self->{tmp}->{is_table_name} } ), keys( %{ $self->{tmp}->{is_table_alias} } ) ); 2700 my $tblnames = join( "|", @tblnamelist ); 2701 unless ( $table_name =~ m/^(?:$tblnames)$/i ) 2702 { 2703 return $self->do_err( 2704 "Table '$table_name' referenced$location but not found in FROM list (" . join( ",", @tblnamelist ) . ")!" ); 2705 } 2706 } 2707 2708 return 1; 2709} 2710 2711################################################################### 2712# IDENTIFIER ::= <alphabetic_char> { <alphanumeric_char> | _ }... 2713# 2714# and must not be a reserved word or over 128 chars in length 2715################################################################### 2716sub IDENTIFIER 2717{ 2718 my ( $self, $id ) = @_; 2719 if ( $id =~ m/^\?QI(.+)\?$/ or $id =~ m/^\?(.+)\?$/ ) 2720 { 2721 return 1; 2722 } 2723 if ( $id =~ m/^[`](.+)[`]$/ ) 2724 { 2725 $id = $1 and return 1; 2726 } 2727 if ( $id =~ m/^(.+)\.([^\.]+)$/ ) 2728 { 2729 my $schema = $1; # ignored 2730 $id = $2; 2731 } 2732 $id =~ s/\(|\)//g; 2733 return 1 if $id =~ m/^".+?"$/s; # QUOTED IDENTIFIER 2734 my $err = "Bad table or column name: '$id' "; # BAD CHARS 2735 if ( $id =~ /\W/ ) 2736 { 2737 $err .= "has chars not alphanumeric or underscore!"; 2738 return $self->do_err($err); 2739 } 2740 # CSV requires optional start with _ 2741 my $badStartRx = uc( $self->{dialect} ) eq 'ANYDATA' ? qr/^\d/ : qr/^[_\d]/; 2742 if ( $id =~ $badStartRx ) 2743 { # BAD START 2744 $err .= "starts with non-alphabetic character!"; 2745 return $self->do_err($err); 2746 } 2747 if ( length $id > 128 ) 2748 { # BAD LENGTH 2749 $err .= "contains more than 128 characters!"; 2750 return $self->do_err($err); 2751 } 2752 $id = uc $id; 2753 if ( $self->{opts}->{reserved_words}->{$id} ) 2754 { # BAD RESERVED WORDS 2755 $err .= "is a SQL reserved word!"; 2756 return $self->do_err($err); 2757 } 2758 return 1; 2759} 2760 2761######################################## 2762# PRIVATE METHODS AND UTILITY FUNCTIONS 2763######################################## 2764sub order_joins 2765{ 2766 my ( $self, $links ) = @_; 2767 for my $link (@$links) 2768 { 2769 if ( $link !~ /\./ ) 2770 { 2771 return []; 2772 } 2773 } 2774 @$links = map { s/^(.+)\..*$/$1/; $1; } @$links; 2775 my @all_tables; 2776 my %relations; 2777 my %is_table; 2778 while (@$links) 2779 { 2780 my $t1 = shift @$links; 2781 my $t2 = shift @$links; 2782 return undef unless defined $t1 and defined $t2; 2783 push @all_tables, $t1 unless $is_table{$t1}++; 2784 push @all_tables, $t2 unless $is_table{$t2}++; 2785 $relations{$t1}{$t2}++; 2786 $relations{$t2}{$t1}++; 2787 } 2788 my @tables = @all_tables; 2789 my @order = shift @tables; 2790 my %is_ordered = ( $order[0] => 1 ); 2791 my %visited; 2792 while (@tables) 2793 { 2794 my $t = shift @tables; 2795 my @rels = keys %{ $relations{$t} }; 2796 for my $t2 (@rels) 2797 { 2798 next unless $is_ordered{$t2}; 2799 push @order, $t; 2800 $is_ordered{$t}++; 2801 last; 2802 } 2803 if ( !$is_ordered{$t} ) 2804 { 2805 push @tables, $t if $visited{$t}++ < @all_tables; 2806 } 2807 } 2808 return $self->do_err("Unconnected tables in equijoin statement!") 2809 if @order < @all_tables; 2810 return \@order; 2811} 2812 2813# PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW 2814# 2815# 2816sub set_feature_flags 2817{ 2818 my ( $self, $select, $create ) = @_; 2819 if ( defined $select ) 2820 { 2821 delete $self->{select}; 2822 $self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} = 2823 $self->{opts}->{select}->{join} = $select->{join}; 2824 } 2825 if ( defined $create ) 2826 { 2827 delete $self->{create}; 2828 for my $key ( keys %$create ) 2829 { 2830 my $type = $key; 2831 $type =~ s/type_(.*)/\U$1/; 2832 $self->{opts}->{valid_data_types}->{$type} = $self->{opts}->{create}->{$key} = 2833 $create->{$key}; 2834 } 2835 } 2836} 2837 2838sub clean_sql 2839{ 2840 my ( $self, $sql ) = @_; 2841 my $fields; 2842 my $i = -1; 2843 my $e = '\\'; 2844 $e = quotemeta($e); 2845 2846 # 2847 # patch from cpan@goess.org, adds support for col2='' 2848 # 2849 # $sql =~ s~'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge; 2850 $sql =~ s~(?<!')'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge; 2851 2852 # 2853 foreach (@$fields) { $_ =~ s/''/\\'/g; } 2854 my @a = $sql =~ m/((?<!\\)(?:(?:\\\\)*)')/g; 2855 if ( ( scalar(@a) % 2 ) == 1 ) 2856 { 2857 $sql =~ s/^.*\?(.+)$/$1/; 2858 $self->do_err("Mismatched single quote before: <$sql>"); 2859 } 2860 if ( $sql =~ m/\?\?(\d)\?/ ) 2861 { 2862 $sql = $fields->[$1]; 2863 $self->do_err("Mismatched single quote: <$sql>"); 2864 } 2865 foreach (@$fields) { $_ =~ s/$e'/'/g; s/^'(.*)'$/$1/; } 2866 2867 # 2868 # From Steffen G. to correctly return newlines from $dbh->quote; 2869 # 2870 foreach (@$fields) { $_ =~ s/([^\\])\\r/$1\r/g; } 2871 foreach (@$fields) { $_ =~ s/([^\\])\\n/$1\n/g; } 2872 2873 $self->{struct}->{literals} = $fields; 2874 2875 my $qids; 2876 $i = -1; 2877 $e = q/""/; 2878 2879 # $sql =~ s~"(([^"$e]|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge; 2880 $sql =~ s/"(([^"]|"")+)"/push(@$qids,$1);$i++;"?QI$i?"/ge; 2881 2882 #@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids; 2883 $self->{struct}->{quoted_ids} = $qids if ($qids); 2884 2885 # $sql =~ s~'(([^'\\]|\\.)+)'~push(@$fields,$1);$i++;"?$i?"~ge; 2886 # @$fields = map { s/\\'/'/g; s/^'(.*)'$/$1/; $_} @$fields; 2887 #print "$sql [@$fields]\n";# if $sql =~ /SELECT/; 2888 2889## before line 1511 2890 my $comment_re = $self->{comment_re}; 2891 2892 # if ( $sql =~ s/($comment_re)//gs) { 2893 # $self->{comment} = $1; 2894 # } 2895 if ( $sql =~ m/(.*)$comment_re$/s ) 2896 { 2897 $sql = $1; 2898 $self->{comment} = $2; 2899 } 2900 if ( $sql =~ m/^(.*)--(.*)(\n|$)/ ) 2901 { 2902 $sql = $1; 2903 $self->{comment} = $2; 2904 } 2905 2906 $sql =~ s/\n/ /g; 2907 $sql =~ s/\s+/ /g; 2908 $sql =~ s/(\S)\(/$1 (/g; # ensure whitespace before ( 2909 $sql =~ s/\)(\S)/) $1/g; # ensure whitespace after ) 2910 $sql =~ s/\(\s*/(/g; # trim whitespace after ( 2911 $sql =~ s/\s*\)/)/g; # trim whitespace before ) 2912 # 2913 # $sql =~ s/\s*\(/(/g; # trim whitespace before ( 2914 # $sql =~ s/\)\s*/)/g; # trim whitespace after ) 2915 # for my $op (qw(= <> < > <= >= \|\|)) 2916 # { 2917 # $sql =~ s/(\S)$op/$1 $op/g; 2918 # $sql =~ s/$op(\S)/$op $1/g; 2919 # } 2920 $sql =~ s/(\S)([<>]?=|<>|<|>|\|\|)/$1 $2/g; 2921 $sql =~ s/([<>]?=|<>|<|>|\|\|)(\S)/$1 $2/g; 2922 $sql =~ s/< >/<>/g; 2923 $sql =~ s/< =/<=/g; 2924 $sql =~ s/> =/>=/g; 2925 $sql =~ s/\s*,/,/g; 2926 $sql =~ s/,\s*/,/g; 2927 $sql =~ s/^\s+//; 2928 $sql =~ s/\s+$//; 2929 2930 return $sql; 2931} 2932 2933sub trim 2934{ 2935 my $str = $_[0] or return (''); 2936 $str =~ s/^\s+//; 2937 $str =~ s/\s+$//; 2938 return $str; 2939} 2940 2941sub do_err 2942{ 2943 my ( $self, $err, $errstr ) = @_; 2944 2945 # $err = $errtype ? "DIALECT ERROR: $err" : "SQL ERROR: $err"; 2946 $self->{struct}->{errstr} = $err; 2947 2948 carp $err if ( $self->{PrintError} ); 2949 croak $err if ( $self->{RaiseError} ); 2950 return; 2951} 2952 2953# 2954# DAA 2955# abstract method so subclasses can provide 2956# their own syntax transformations 2957# 2958sub transform_syntax 2959{ 2960 my ( $self, $str ) = @_; 2961 return $str; 2962} 2963 2964sub DESTROY 2965{ 2966 my $self = $_[0]; 2967 2968 undef $self->{opts}; 2969 undef $self->{struct}; 2970 undef $self->{tmp}; 2971 undef $self->{dialect}; 2972 undef $self->{dialect_set}; 2973} 2974 29751; 2976 2977__END__ 2978 2979=pod 2980 2981=head1 NAME 2982 2983 SQL::Parser -- validate and parse SQL strings 2984 2985=head1 SYNOPSIS 2986 2987 use SQL::Parser; # CREATE A PARSER OBJECT 2988 my $parser = SQL::Parser->new(); 2989 2990 $parser->feature( $class, $name, $value ); # SET OR FIND STATUS OF 2991 my $has_feature = $parser->feature( $class, $name ); # A PARSER FEATURE 2992 2993 $parser->dialect( $dialect_name ); # SET OR FIND STATUS OF 2994 my $current_dialect = $parser->dialect; # A PARSER DIALECT 2995 2996 2997=head1 DESCRIPTION 2998 2999SQL::Parser is part of the SQL::Statement distribution and, most 3000interaction with the parser should be done through SQL::Statement. 3001The methods shown above create and modify a parser object. To use the 3002parser object to parse SQL and to examine the resulting structure, you 3003should use SQL::Statement. 3004 3005B<Important Note>: Previously SQL::Parser had its own hash-based 3006interface for parsing, but that is now deprecated and will eventually 3007be phased out in favor of the object-oriented parsing interface of 3008SQL::Statement. If you are unable to transition some features to the 3009new interface or have concerns about the phase out, please contact me. 3010See L<The Parse Structure> for details of the now-deprecated hash 3011method if you still need them. 3012 3013=head1 METHODS 3014 3015=head2 new() 3016 3017Create a new parser object 3018 3019 use SQL::Parser; 3020 my $parser = SQL::Parser->new(); 3021 3022The new() method creates a SQL::Parser object which can then be 3023used to parse and validate the syntax of SQL strings. It takes two 3024optional parameters - 1) the name of the SQL dialect that will define 3025the syntax rules for the parser and 2) a reference to a hash which can 3026contain additional attributes of the parser. If no dialect is specified, 3027'AnyData' is the default. 3028 3029 use SQL::Parser; 3030 my $parser = SQL::Parser->new( $dialect_name, \%attrs ); 3031 3032The dialect_name parameter is a string containing any valid 3033dialect such as 'ANSI', 'AnyData', or 'CSV'. See the section on 3034the dialect() method below for details. 3035 3036The C<attrs> parameter is a reference to a hash that can 3037contain error settings for the PrintError and RaiseError 3038attributes. 3039 3040An example: 3041 3042 use SQL::Parser; 3043 my $parser = SQL::Parser->new('AnyData', {RaiseError=>1} ); 3044 3045 This creates a new parser that uses the grammar rules 3046 contained in the .../SQL/Dialects/AnyData.pm file and which 3047 sets the RaiseError attribute to true. 3048 3049=head2 dialect() 3050 3051 $parser->dialect( $dialect_name ); # load a dialect configuration file 3052 my $dialect = $parser->dialect; # get the name of the current dialect 3053 3054 For example: 3055 3056 $parser->dialect('AnyData'); # loads the AnyData config file 3057 print $parser->dialect; # prints 'AnyData' 3058 3059The C<$dialect_name> parameter may be the name of any dialect 3060configuration file on your system. Use the 3061$parser->list('dialects') method to see a list of available 3062dialects. At a minimum it will include "ANSI", "CSV", and 3063"AnyData". For backwards compatibility 'Ansi' is accepted as a 3064synonym for 'ANSI', otherwise the names are case sensitive. 3065 3066Loading a new dialect configuration file erases all current 3067parser features and resets them to those defined in the 3068configuration file. 3069 3070=head2 feature() 3071 3072Features define the rules to be used by a specific parser 3073instance. They are divided into the following classes: 3074 3075 * valid_commands 3076 * valid_options 3077 * valid_comparison_operators 3078 * valid_data_types 3079 * reserved_words 3080 3081Within each class a feature name is either enabled or 3082disabled. For example, under "valid_data_types" the name "BLOB" 3083may be either disabled or enabled. If it is not enabled 3084(either by being specifically disabled, or simply by not being 3085specified at all) then any SQL string using "BLOB" as a data 3086type will throw a syntax error "Invalid data type: 'BLOB'". 3087 3088The feature() method allows you to enable, disable, or check the 3089status of any feature. 3090 3091 $parser->feature( $class, $name, 1 ); # enable a feature 3092 3093 $parser->feature( $class, $name, 0 ); # disable a feature 3094 3095 my $feature = $parser->feature( $class, $name ); # return status of a feature 3096 3097 For example: 3098 3099 $parser->feature('reserved_words','FOO',1); # make 'FOO' a reserved word 3100 3101 $parser->feature('valid_data_types','BLOB',0); # disallow 'BLOB' as a 3102 # data type 3103 3104 # determine if the LIKE 3105 # operator is supported 3106 my $LIKE = $parser->feature('valid_comparison_operators','LIKE'); 3107 3108See the section below on "Backwards Compatibility" for use of 3109the feature() method with SQL::Statement 0.1x style parameters. 3110 3111=begin undocumented 3112 3113=head2 clean_sql 3114 3115=head2 command 3116 3117=head2 create_op_regexen 3118 3119=head2 do_err 3120 3121=head2 errstr 3122 3123=head2 extract_column_list 3124 3125=head2 extract_func_args 3126 3127=head2 group_ands 3128 3129=head2 is_func 3130 3131=head2 list 3132 3133=head2 non_parens_search 3134 3135=head2 nongroup_numeric 3136 3137=head2 nongroup_string 3138 3139=head2 order_joins 3140 3141=head2 parens_search 3142 3143=head2 parse 3144 3145=head2 repl_btwin 3146 3147=head2 replace_quoted 3148 3149=head2 replace_quoted_commas 3150 3151=head2 replace_quoted_ids 3152 3153=head2 set_feature_flags 3154 3155=head2 structure 3156 3157=head2 transform_concat 3158 3159=head2 trim 3160 3161=head2 transform_syntax 3162 3163=head2 undo_math_funcs 3164 3165=head2 undo_string_funcs 3166 3167=end undocumented 3168 3169=head1 Supported SQL syntax 3170 3171The SQL::Statement distribution can be used to either just parse SQL 3172statements or to execute them against actual data. A broader set of 3173syntax is supported in the parser than in the executor. For example 3174the parser allows you to specify column constraints like PRIMARY KEY. 3175Currently, these are ignored by the execution engine. Likewise syntax 3176such as RESTRICT and CASCADE on DROP statements or LOCAL GLOBAL TEMPORARY 3177tables in CREATE are supported by the parser but ignored by the executor. 3178 3179To see the list of Supported SQL syntax formerly kept in this pod, see 3180L<SQL::Statement>. 3181 3182=head1 Subclassing SQL::Parser 3183 3184In the event you need to either extend or modify SQL::Parser's 3185default behavior, the following methods may be overridden: 3186 3187=over 3188 3189=item C<$self->E<gt>C<get_btwn($string)> 3190 3191Processes the BETWEEN...AND... predicates; default converts to 31922 range predicates. 3193 3194=item C<$self->E<gt>C<get_in($string)> 3195 3196Process the IN (...list...) predicates; default converts to 3197a series of OR'd '=' predicate, or AND'd '<>' predicates for 3198NOT IN. 3199 3200=item C<$self->E<gt>C<transform_syntax($string)> 3201 3202Abstract method; default simply returns the original string. 3203Called after repl_btwn() and repl_in(), but before any further 3204predicate processing is applied. Possible uses include converting 3205other predicate syntax not recognized by SQL::Parser into user-defined 3206functions. 3207 3208=back 3209 3210=head1 The parse structure 3211 3212This section outlines the B<now-deprecated> hash interface to the 3213parsed structure. It is included B<for backwards compatibility only>. 3214You should use the SQL::Statement object interface to the structure 3215instead. See L<SQL::Statement>. 3216 3217B<Parse Structures> 3218 3219Here are some further examples of the data structures returned 3220by the structure() method after a call to parse(). Only 3221specific details are shown for each SQL instance, not the entire 3222structure. 3223 3224B<parse()> 3225 3226Once a SQL::Parser object has been created with the new() 3227method, the parse() method can be used to parse any number of 3228SQL strings. It takes a single required parameter -- a string 3229containing a SQL command. The SQL string may optionally be 3230terminated by a semicolon. The parse() method returns a true 3231value if the parse is successful and a false value if the parse 3232finds SQL syntax errors. 3233 3234Examples: 3235 3236 1) my $success = $parser->parse('SELECT * FROM foo'); 3237 3238 2) my $sql = 'SELECT * FROM foo'; 3239 my $success = $parser->parse( $sql ); 3240 3241 3) my $success = $parser->parse(qq! 3242 SELECT id,phrase 3243 FROM foo 3244 WHERE id < 7 3245 AND phrase <> 'bar' 3246 ORDER BY phrase; 3247 !); 3248 3249 4) my $success = $parser->parse('SELECT * FRoOM foo '); 3250 3251In examples #1,#2, and #3, the value of $success will be true 3252because the strings passed to the parse() method are valid SQL 3253strings. 3254 3255In example #4, however, the value of $success will be false 3256because the string contains a SQL syntax error ('FRoOM' instead 3257of 'FROM'). 3258 3259In addition to checking the return value of parse() with a 3260variable like $success, you may use the PrintError and 3261RaiseError attributes as you would in a DBI script: 3262 3263 * If PrintError is true, then SQL syntax errors will be sent as 3264 warnings to STDERR (i.e. to the screen or to a file if STDERR 3265 has been redirected). This is set to true by default which 3266 means that unless you specifically turn it off, all errors 3267 will be reported. 3268 3269 * If RaiseError is true, then SQL syntax errors will cause the 3270 script to die, (i.e. the script will terminate unless wrapped 3271 in an eval). This is set to false by default which means 3272 that unless you specifically turn it on, scripts will 3273 continue to operate even if there are SQL syntax errors. 3274 3275Basically, you should leave PrintError on or else you will not 3276be warned when an error occurs. If you are simply validating a 3277series of strings, you will want to leave RaiseError off so that 3278the script can check all strings regardless of whether some of 3279them contain SQL errors. However, if you are going to try to 3280execute the SQL or need to depend that it is correct, you should 3281set RaiseError on so that the program will only continue to 3282operate if all SQL strings use correct syntax. 3283 3284IMPORTANT NOTE #1: The parse() method only checks syntax, it 3285does NOT verify if the objects listed actually exist. For 3286example, given the string "SELECT model FROM cars", the parse() 3287method will report that the string contains valid SQL but that 3288will not tell you whether there actually is a table called 3289"cars" or whether that table contains a column called 'model'. 3290Those kinds of verifications are performed by the 3291SQL::Statement module, not by SQL::Parser by itself. 3292 3293IMPORTANT NOTE #2: The parse() method uses rules as defined by 3294the selected dialect configuration file and the feature() 3295method. This means that a statement that is valid in one 3296dialect may not be valid in another. For example the 'CSV' and 3297'AnyData' dialects define 'BLOB' as a valid data type but the 3298'ANSI' dialect does not. Therefore the statement 'CREATE TABLE 3299foo (picture BLOB)' would be valid in the first two dialects but 3300would produce a syntax error in the 'ANSI' dialect. 3301 3302B<structure()> 3303 3304After a SQL::Parser object has been created and the parse() 3305method used to parse a SQL string, the structure() method 3306returns the data structure of that string. This data structure 3307may be passed on to other modules (e.g. SQL::Statement) or it 3308may be printed out using, for example, the Data::Dumper module. 3309 3310The data structure contains all of the information in the SQL 3311string as parsed into its various components. To take a simple 3312example: 3313 3314 $parser->parse('SELECT make,model FROM cars'); 3315 use Data::Dumper; 3316 print Dumper $parser->structure; 3317 3318Would produce: 3319 3320 $VAR1 = { 3321 'column_defs' => [ 3322 { 'type' => 'column', 3323 'value' => 'make', }, 3324 { 'type' => 'column', 3325 'value' => 'model', }, 3326 ], 3327 'command' => 'SELECT', 3328 'table_names' => [ 3329 'cars' 3330 ] 3331 }; 3332 3333 3334 'SELECT make,model, FROM cars' 3335 3336 command => 'SELECT', 3337 table_names => [ 'cars' ], 3338 column_names => [ 'make', 'model' ], 3339 3340 'CREATE TABLE cars ( id INTEGER, model VARCHAR(40) )' 3341 3342 column_defs => { 3343 id => { data_type => INTEGER }, 3344 model => { data_type => VARCHAR(40) }, 3345 }, 3346 3347 'SELECT DISTINCT make FROM cars' 3348 3349 set_quantifier => 'DISTINCT', 3350 3351 'SELECT MAX (model) FROM cars' 3352 3353 set_function => { 3354 name => 'MAX', 3355 arg => 'models', 3356 }, 3357 3358 'SELECT * FROM cars LIMIT 5,10' 3359 3360 limit_clause => { 3361 offset => 5, 3362 limit => 10, 3363 }, 3364 3365 'SELECT * FROM vars ORDER BY make, model DESC' 3366 3367 sort_spec_list => [ 3368 { make => 'ASC' }, 3369 { model => 'DESC' }, 3370 ], 3371 3372 "INSERT INTO cars VALUES ( 7, 'Chevy', 'Impala' )" 3373 3374 values => [ 7, 'Chevy', 'Impala' ], 3375 3376=head1 SUPPORT 3377 3378You can find documentation for this module with the perldoc command. 3379 3380 perldoc SQL::Parser 3381 perldoc SQL::Statement 3382 3383You can also look for information at: 3384 3385=over 4 3386 3387=item * RT: CPAN's request tracker 3388 3389L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Statement> 3390 3391=item * AnnoCPAN: Annotated CPAN documentation 3392 3393L<http://annocpan.org/dist/SQL-Statement> 3394 3395=item * CPAN Ratings 3396 3397L<http://cpanratings.perl.org/s/SQL-Statement> 3398 3399=item * Search CPAN 3400 3401L<http://search.cpan.org/dist/SQL-Statement/> 3402 3403=back 3404 3405=head2 Where can I go for help? 3406 3407For questions about installation or usage, please ask on the 3408dbi-users@perl.org mailing list or post a question on PerlMonks 3409(L<http://www.perlmonks.org/>, where Jeff is known as jZed). 3410Jens does not visit PerlMonks on a regular basis. 3411 3412If you have a bug report, a patch or a suggestion, please open a new 3413report ticket at CPAN (but please check previous reports first in case 3414your issue has already been addressed). You can mail any of the module 3415maintainers, but you are more assured of an answer by posting to the 3416dbi-users list or reporting the issue in RT. 3417 3418Report tickets should contain a detailed description of the bug or 3419enhancement request and at least an easily verifiable way of 3420reproducing the issue or fix. Patches are always welcome, too. 3421 3422=head2 Where can I go for help with a concrete version? 3423 3424Bugs and feature requests are accepted against the latest version 3425only. To get patches for earlier versions, you need to get an 3426agreement with a developer of your choice - who may or not report the 3427the issue and a suggested fix upstream (depends on the license you 3428have chosen). 3429 3430=head2 Business support and maintenance 3431 3432For business support you can contact Jens via his CPAN email 3433address rehsackATcpan.org. Please keep in mind that business 3434support is neither available for free nor are you eligible to 3435receive any support based on the license distributed with this 3436package. 3437 3438 3439=head1 AUTHOR & COPYRIGHT 3440 3441 This module is 3442 3443 copyright (c) 2001,2005 by Jeff Zucker and 3444 copyright (c) 2007-2020 by Jens Rehsack. 3445 3446 All rights reserved. 3447 3448The module may be freely distributed under the same terms as 3449Perl itself using either the "GPL License" or the "Artistic 3450License" as specified in the Perl README file. 3451 3452Jeff can be reached at: jzuckerATcpan.org 3453Jens can be reached at: rehsackATcpan.org or via dbi-devATperl.org 3454 3455=cut 3456