File Coverage

752							#
753							###################################################################
754							sub UPDATE
755							{
756	12			12	0	38	my ( $self, $str ) = @_;
757	12					36	$self->{struct}->{command} = 'UPDATE';
758	12					81	my ( $table_name, $remainder ) = $str =~ m/^UPDATE (.+?) SET (.+)$/i;
759	12	50	33			83	return $self->do_err('Incomplete UPDATE clause') unless ( $table_name && $remainder );
760	12	50				43	return undef unless ( $self->TABLE_NAME($table_name) );
761	12					64	$self->{tmp}->{is_table_name} = { $table_name => 1 };
762	12					37	$self->{struct}->{table_names} = [$table_name];
763	12					80	my ( $set_clause, $where_clause ) = $remainder =~ m/(.?) WHERE (.)$/i;
764	12	100				42	$set_clause = $remainder if ( !$set_clause );
765	12	50				55	return undef unless ( $self->SET_CLAUSE_LIST($set_clause) );
766
767	12	100				47	if ($where_clause)
768							{
769	6	50				25	return undef unless ( $self->SEARCH_CONDITION($where_clause) );
770							}
771
772	12					29	my @vals = @{ $self->{struct}->{values}->[0] };
	12					42
773	12					32	my $num_val_placeholders = 0;
774	12					35	for my $v (@vals)
775							{
776	22	100				61	++$num_val_placeholders if ( $v->{type} eq 'placeholder' );
777							}
778	12					29	$self->{struct}->{num_val_placeholders} = $num_val_placeholders;
779
780	12					39	return 1;
781							}
782
783							############
784							# FUNCTIONS
785							############
786							sub LOAD
787							{
788	18			18	0	91	my ( $self, $str ) = @_;
789	18					73	$self->{struct}->{command} = 'LOAD';
790	18					63	$self->{struct}->{no_execute} = 1;
791	18					123	my ($package) = $str =~ /^LOAD\s+(.+)$/;
792	18					63	$str = $package;
793	18					69	$package =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
794
795	18					80	$self->_load_class($package);
796
797	18					1397	my %subs = eval '%' . $package . '::';
798
799	18					510	for my $sub ( keys %subs )
800							{
801	2992	100				6998	next unless ( $sub =~ m/^SQL_FUNCTION_([A-Z_0-9]+)$/ );
802	1854					3312	my $funcName = uc $1;
803	1854					3721	my $subname = $package . '::' . 'SQL_FUNCTION_' . $funcName;
804	1854					4349	$self->{opts}->{function_names}->{$funcName} = $subname;
805	1854					2910	delete $self->{opts}->{_udf_function_names};
806							}
807	18					894	1;
808							}
809
810							sub CREATE_RAM_TABLE
811							{
812	0			0	0	0	my ( $self, $stmt ) = @_;
813	0					0	$self->{struct}->{is_ram_table} = 1;
814	0					0	$self->{struct}->{command} = 'CREATE_RAM_TABLE';
815	0					0	my ( $table_name, $table_element_def, %is_col_name );
816	0	0				0	if ( $stmt =~ /^(\S+)\s+LIKE\s*(.+)$/si )
817							{
818	0					0	$table_name = $1;
819	0					0	$table_element_def = $2;
820	0	0				0	if ( $table_element_def =~ /^(.)\s+KEEP CONNECTION\s$/i )
821							{
822	0					0	$table_element_def = $1;
823	0					0	$self->{struct}->{ram_table_keep_connection} = 1;
824							}
825							}
826							else
827							{
828	0					0	return $self->CREATE("CREATE TABLE $stmt");
829							}
830	0	0				0	return undef unless $self->TABLE_NAME($table_name);
831	0					0	for my $col ( split ',', $table_element_def )
832							{
833	0					0	push( @{ $self->{struct}->{column_defs} }, $self->ROW_VALUE($col) );
	0					0
834							}
835	0					0	$self->{struct}->{table_names} = [$table_name];
836	0					0	return 1;
837							}
838
839							sub CREATE_FUNCTION
840							{
841	3			3	0	8	my ( $self, $stmt ) = @_;
842	3					9	$self->{struct}->{command} = 'CREATE_FUNCTION';
843	3					6	$self->{struct}->{no_execute} = 1;
844	3					6	my ( $func, $subname );
845	3					9	$stmt =~ s/\s*EXTERNAL//i;
846	3	100				16	if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi )
847							{
848	2					7	$func = trim($1);
849	2					6	$subname = trim($2);
850							}
851	3		66			13	$func \|\|= $stmt;
852	3		66			11	$subname \|\|= $func;
853	3	50				9	if ( $func =~ /^\?QI(\d+)\?$/ )
854							{
855	0					0	$func = $self->{struct}->{quoted_ids}->[$1];
856							}
857	3	100				12	if ( $subname =~ /^\?QI(\d+)\?$/ )
858							{
859	2					7	$subname = $self->{struct}->{quoted_ids}->[$1];
860							}
861	3					11	$self->{opts}->{function_names}->{ uc $func } = $subname;
862	3					8	delete $self->{opts}->{_udf_function_names};
863
864	3					9	return 1;
865							}
866
867							sub CALL
868							{
869	0			0	0	0	my ( $self, $stmt ) = @_;
870	0					0	$stmt =~ s/^CALL\s+(.*)/$1/i;
871	0					0	$self->{struct}->{command} = 'CALL';
872	0					0	$self->{struct}->{procedure} = $self->ROW_VALUE($stmt);
873	0					0	return 1;
874							}
875
876							sub CREATE_TYPE
877							{
878	3			3	0	9	my ( $self, $type ) = @_;
879	3					8	$self->{struct}->{command} = 'CREATE_TYPE';
880	3					8	$self->{struct}->{no_execute} = 1;
881	3					16	$self->feature( 'valid_data_types', uc $type, 1 );
882							}
883
884							sub DROP_TYPE
885							{
886	1			1	0	4	my ( $self, $type ) = @_;
887	1					4	$self->{struct}->{command} = 'DROP_TYPE';
888	1					3	$self->{struct}->{no_execute} = 1;
889	1					5	$self->feature( 'valid_data_types', uc $type, 0 );
890							}
891
892							sub CREATE_KEYWORD
893							{
894	1			1	0	4	my ( $self, $type ) = @_;
895	1					4	$self->{struct}->{command} = 'CREATE_KEYWORD';
896	1					3	$self->{struct}->{no_execute} = 1;
897	1					5	$self->feature( 'reserved_words', uc $type, 1 );
898							}
899
900							sub DROP_KEYWORD
901							{
902	1			1	0	4	my ( $self, $type ) = @_;
903	1					4	$self->{struct}->{command} = 'DROP_KEYWORD';
904	1					3	$self->{struct}->{no_execute} = 1;
905	1					5	$self->feature( 'reserved_words', uc $type, 0 );
906							}
907
908							sub CREATE_OPERATOR
909							{
910	2			2	0	5	my ( $self, $stmt ) = @_;
911	2					5	$self->{struct}->{command} = 'CREATE_OPERATOR';
912	2					5	$self->{struct}->{no_execute} = 1;
913
914	2					3	my ( $func, $subname );
915	2					5	$stmt =~ s/\s*EXTERNAL//i;
916	2	50				6	if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi )
917							{
918	0					0	$func = trim($1);
919	0					0	$subname = trim($2);
920							}
921	2		33			9	$func \|\|= $stmt;
922	2		33			9	$subname \|\|= $func;
923	2	50				6	if ( $func =~ /^\?QI(\d+)\?$/ )
924							{
925	0					0	$func = $self->{struct}->{quoted_ids}->[$1];
926							}
927	2	50				6	if ( $subname =~ /^\?QI(\d+)\?$/ )
928							{
929	0					0	$subname = $self->{struct}->{quoted_ids}->[$1];
930							}
931	2					5	$self->{opts}->{function_names}->{ uc $func } = $subname;
932	2					6	delete $self->{opts}->{_udf_function_names};
933
934	2					8	$self->feature( 'valid_comparison_operators', uc $func, 1 );
935	2					7	return $self->create_op_regexen();
936							}
937
938							sub DROP_OPERATOR
939							{
940	1			1	0	5	my ( $self, $type ) = @_;
941	1					3	$self->{struct}->{command} = 'DROP_OPERATOR';
942	1					3	$self->{struct}->{no_execute} = 1;
943	1					34	$self->feature( 'valid_comparison_operators', uc $type, 0 );
944	1					4	return $self->create_op_regexen();
945							}
946
947							sub replace_quoted($)
948							{
949	9			9	1	19	my ( $self, $str ) = @_;
950	9					21	my @l = map { $self->replace_quoted_ids($_) } split( ',', $self->replace_quoted_commas($str) );
	18					32
951	9					30	return @l;
952							}
953
954							#########
955							# CREATE
956							#########
957							sub CREATE
958							{
959	70			70	0	161	my ( $self, $stmt ) = @_;
960	70					143	my $features = 'TYPE\|KEYWORD\|FUNCTION\|OPERATOR\|PREDICATE';
961	70	100				1099	if ( $stmt =~ m/^\s*CREATE\s+($features)\s+(.+)$/si )
962							{
963	9					38	my ( $sub, $arg ) = ( $1, $2 );
964	9					23	$sub = 'CREATE_' . uc $sub;
965	9					36	return $self->$sub($arg);
966							}
967
968	61					208	$stmt =~ s/^CREATE (LOCAL\|GLOBAL) /CREATE /si;
969	61	100				305	if ( $stmt =~ m/^\s*CREATE\s+(?:TEMP\|TEMPORARY)\s+TABLE\s+(.+)$/si )
970							{
971	43					153	$stmt = "CREATE TABLE $1";
972	43					130	$self->{struct}->{is_ram_table} = 1;
973							}
974	61					186	$self->{struct}->{command} = 'CREATE';
975	61					128	my ( $table_name, $table_element_def, %is_col_name );
976
977	61	100				279	if ( $stmt =~ m/^(.) ON COMMIT (DELETE\|PRESERVE) ROWS\s$/si )
978							{
979	4					10	$stmt = $1;
980	4					13	$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	61	50				291	if ( $stmt =~ m/^CREATE TABLE (\S+) $(.*)$$/si )
		0
989							{
990	61					146	$table_name = $1;
991	61					135	$table_element_def = $2;
992							}
993							elsif ( $stmt =~ m/^CREATE TABLE (\S+) AS (.*)$/si )
994							{
995	0					0	$table_name = $1;
996	0					0	my $subquery = $2;
997	0	0				0	return undef unless $self->TABLE_NAME($table_name);
998	0					0	$self->{struct}->{table_names} = [$table_name];
999
1000							# undo subquery replaces
1001	0					0	$subquery =~ s/\?(\d+)\?/'$self->{struct}{literals}[$1]'/g;
1002	0					0	$subquery =~ s/\?QI(\d+)\?/"$self->{struct}->{quoted_ids}->[$1]"/g;
1003	0					0	$subquery =~ s/\?COMMA\?/,/gs;
1004	0					0	$self->{struct}->{subquery} = $subquery;
1005	0	0				0	if ( -1 != index( $subquery, '?' ) )
1006							{
1007	0					0	++$self->{struct}->{num_placeholders};
1008							}
1009	0					0	return 1;
1010							}
1011							else
1012							{
1013	0					0	return $self->do_err("Can't find column definitions!");
1014							}
1015	61	50				202	return undef unless ( $self->TABLE_NAME($table_name) );
1016	61					246	$table_element_def =~ s/\s+\(/(/g;
1017	61					105	my $primary_defined;
1018	61					265	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	61					256	for my $col ( split( ',', $table_element_def ) )
1032							{
1033	139	100				495	if (
		100
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	3					16	my ( $name, $local_cols, $referenced_table, $referenced_cols ) = ( $1, $2, $3, $4 );
1047	3					8	my @local_cols = $self->replace_quoted($local_cols);
1048	3					10	$referenced_table = $self->replace_quoted_ids($referenced_table);
1049	3					8	my @referenced_cols = $self->replace_quoted($referenced_cols);
1050
1051	3	100				10	if ( defined $name )
1052							{
1053	2					6	$name = $self->replace_quoted_ids($name);
1054							}
1055							else
1056							{
1057	1					5	$name = $self->replace_quoted_ids($table_name);
1058	1					4	my ($quote_char) = '';
1059	1	50				6	if ( $name =~ s/(\W)$// )
1060							{
1061	0					0	$quote_char = ($1);
1062							}
1063	1					3	foreach my $local_col (@local_cols)
1064							{
1065	2					5	my $col_name = $local_col;
1066	2					8	$col_name =~ s/^\W//;
1067	2					6	$col_name =~ s/\W$//;
1068	2					5	$name .= '_' . $col_name;
1069							}
1070	1					3	$name .= '_fkey' . $quote_char;
1071							}
1072
1073	3					12	$self->{struct}->{table_defs}->{$name}->{type} = 'FOREIGN';
1074	3					7	$self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols;
1075	3					8	$self->{struct}->{table_defs}->{$name}->{referenced_table} = $referenced_table;
1076	3					10	$self->{struct}->{table_defs}->{$name}->{referenced_cols} = \@referenced_cols;
1077	3					9	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	3					14	my ( $name, $local_cols ) = ( $1, $2 );
1088	3					9	my @local_cols = $self->replace_quoted($local_cols);
1089	3	100				9	if ( defined $name )
1090							{
1091	2					4	$name = $self->replace_quoted_ids($name);
1092							}
1093							else
1094							{
1095	1					6	$name = $table_name;
1096	1	50				6	if ( $name =~ s/(\W)$// )
1097							{
1098	0					0	$name .= '_pkey' . $1;
1099							}
1100							else
1101							{
1102	1					3	$name .= '_pkey';
1103							}
1104							}
1105	3					13	$self->{struct}->{table_defs}->{$name}->{type} = 'PRIMARY';
1106	3					10	$self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols;
1107	3					8	next;
1108							}
1109
1110							# it seems, perl 5.6 isn't greedy enough .. let's help a bit
1111	133					200	my ($data_types_regex) = join( '\|', sort { length($b) <=> length($a) } keys %{ $self->{opts}->{valid_data_types} } );
	12874					17208
	133					1081
1112	133					1150	$data_types_regex =~ s/ /\\ /g; # backslash spaces to allow the /x modifier below
1113	133					3504	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	133	50				423	return $self->do_err("Column definition is missing a data type!") unless ($type);
1121	133	50				352	return undef unless ( $self->IDENTIFIER($name) );
1122
1123	133					393	$name = $self->replace_quoted_ids($name);
1124
1125	133					356	my @possible_constraints = ('PRIMARY KEY', 'NOT NULL', 'UNIQUE');
1126
1127	133					291	for my $constraint (@possible_constraints)
1128							{
1129	399					2370	my $count = $suffix =~ s/$constraint//gi;
1130	399	100				987	next if $count == 0;
1131
1132	10	50				29	return $self->do_err(qq~Duplicate column constraint: '$constraint'!~)
1133							if $count > 1;
1134
1135	10	50	66			29	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	10					16	push @{ $self->{struct}->{table_defs}->{columns}->{$name}->{constraints} }, $constraint;
	10					44
1139							}
1140
1141	133					228	$suffix =~ s/^\s+//;
1142	133					220	$suffix =~ s/\s+$//;
1143
1144	133	50				282	return $self->do_err("Unknown column constraint: '$suffix'!") unless ($suffix eq '');
1145
1146	133					220	$type = uc $type;
1147	133					214	my $length;
1148	133	100				365	if ( $type =~ m/(.+)$(.+)$/ )
1149							{
1150	20					56	$type = $1;
1151	20					45	$length = $2;
1152							}
1153	133	100				334	if ( !$self->{opts}->{valid_data_types}->{$type} )
1154							{
1155	2					11	return $self->do_err("'$type' is not a recognized data type!");
1156							}
1157	131					466	$self->{struct}->{table_defs}->{columns}->{$name}->{data_type} = $type;
1158	131					274	$self->{struct}->{table_defs}->{columns}->{$name}->{data_length} = $length;
1159							push(
1160	131					195	@{ $self->{struct}->{column_defs} },
	131					588
1161							{
1162							type => 'column',
1163							value => $name,
1164							fullorg => $name,
1165							}
1166							);
1167
1168	131					263	my $tmpname = $name;
1169	131	100				414	$tmpname = lc $tmpname unless ( $tmpname =~ m/^(?:\p{Word}+\.)?"/ );
1170	131	50				631	return $self->do_err("Duplicate column names!") if $is_col_name{$tmpname}++;
1171
1172							}
1173	59					247	$self->{struct}->{table_names} = [$table_name];
1174	59					195	return 1;
1175							}
1176
1177							###############
1178							# SQL SUBRULES
1179							###############
1180
1181							sub SET_CLAUSE_LIST
1182							{
1183	12			12	0	34	my ( $self, $set_string ) = @_;
1184							my @sets = extract_multiple($set_string, [
1185	28		100	28		1304	sub { my ($m, $r, $p) = extract_bracketed($_[0], "()", qr/[^,(]*/); (($p\|\|'').($m\|\|''), $r, ''); },
	28		100			3265
1186	12					153	qr/([^,(]+)/,
1187							], undef, 1);
1188	12					496	my ( @cols, @vals );
1189	12					36	for my $set (@sets)
1190							{
1191	20					75	my ( $col, $val ) = split( m/ = /, $set );
1192	20	50	33			120	return $self->do_err('Incomplete SET clause!') unless ( defined($col) && defined($val) );
1193	20					60	push( @cols, $col );
1194	20					50	push( @vals, $val );
1195							}
1196							return undef
1197	12	50				78	unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST( join ',', @cols ) );
1198	12	50				85	return undef unless ( $self->LITERAL_LIST( join ',', @vals ) );
1199	12					54	return 1;
1200							}
1201
1202							sub SET_QUANTIFIER
1203							{
1204	0			0	0	0	my ( $self, $str ) = @_;
1205	0	0				0	if ( $str =~ /^(DISTINCT\|ALL)\s+(.*)$/si )
1206							{
1207	0					0	$self->{struct}->{set_quantifier} = uc $1;
1208	0					0	$str = $2;
1209							}
1210	0					0	return $str;
1211							}
1212
1213							#
1214							# DAA v1.11
1215							# modify to transform \|\| strings into
1216							# CONCAT(); 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							#
1221							sub transform_concat
1222							{
1223	1			1	1	4	my ( $obj, $colstr ) = @_;
1224
1225	1					4	pos($colstr) = 0;
1226	1					3	my $parens = 0;
1227	1					3	my $spos = 0;
1228	1					3	my @concats = ();
1229	1	50				6	my $alias = ( $colstr =~ s/^(.+)(\s+AS\s+\S+)$/$1/ ) ? $2 : '';
1230
1231	1					6	while ( $colstr =~ /\G.*?([\\|])/gcs )
1232							{
1233	10	100	33			38	if ( $1 eq '(' )
		100
		50
1234							{
1235	3					10	$parens++;
1236							}
1237							elsif ( $1 eq ')' )
1238							{
1239	3					8	$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	0					0	push @concats, substr( $colstr, $spos, $-[1] - $spos );
1249	0					0	$spos = $+[1] + 1;
1250	0					0	pos($colstr) = $spos;
1251							}
1252							}
1253
1254							#
1255							# no concats, return original
1256							#
1257	1	50				7	return $colstr unless scalar @concats;
1258
1259							#
1260							# don't forget the last one!
1261							#
1262	0					0	push @concats, substr( $colstr, $spos );
1263	0					0	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()
1275							#
1276							sub extract_column_list
1277							{
1278	315			315	1	673	my ( $self, $colstr ) = @_;
1279
1280	315					526	my @collist = ();
1281	315					907	pos($colstr) = 0;
1282	315					637	my $parens = 0;
1283	315					469	my $spos = 0;
1284	315					1428	while ( $colstr =~ m/\G.*?([,])/gcs )
1285							{
1286	711	100				2243	if ( $1 eq '(' )
		100
		100
1287							{
1288	242					761	$parens++;
1289							}
1290							elsif ( $1 eq ')' )
1291							{
1292	239					590	$parens--;
1293							}
1294							elsif ( !$parens )
1295							{ # its a comma outside of parens
1296	137					516	push( @collist, substr( $colstr, $spos, $-[1] - $spos ) );
1297	137					345	$collist[-1] =~ s/^\s+//;
1298	137					309	$collist[-1] =~ s/\s+$//;
1299	137	50				293	return $self->do_err('Bad column list!') if ( $collist[-1] eq '' );
1300	137					642	$spos = $+[1];
1301							}
1302							}
1303	315	100				716	return $self->do_err('Unbalanced parentheses!') if ($parens);
1304
1305							# don't forget the last one!
1306	312					816	push( @collist, substr( $colstr, $spos ) );
1307	312					840	$collist[-1] =~ s/^\s+//;
1308	312					745	$collist[-1] =~ s/\s+$//;
1309	312	50				684	return $self->do_err('Bad column list!') if ( $collist[-1] eq '' );
1310
1311							# scan for and convert string concats to CONCAT()
1312	312					938	foreach ( 0 .. $#collist )
1313							{
1314	449	100				1335	$collist[$_] = $self->transform_concat( $collist[$_] ) if ( $collist[$_] =~ m/\\|\\|/ );
1315							}
1316
1317	312					1076	return @collist;
1318							}
1319
1320							sub SELECT_LIST
1321							{
1322	547			547	0	1026	my ( $self, $col_str ) = @_;
1323	547	100				1867	if ( $col_str =~ m/^\s\\s*$/ )
1324							{
1325							$self->{struct}->{column_defs} = [
1326							{
1327	232					892	type => 'column',
1328							value => '*'
1329							}
1330							];
1331	232					674	$self->{struct}->{column_aliases} = {};
1332
1333	232					762	return 1;
1334							}
1335	315					800	my @col_list = $self->extract_column_list($col_str);
1336	315	100				789	return undef unless ( scalar(@col_list) );
1337
1338	312					562	my ( @newcols, %aliases );
1339	312					602	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	445	100				2445	my ( $fld, $alias ) =
1345							( $col =~ m/^(.+?)\s+(?:AS\s+)?([A-Z]\p{Word}*\|\?QI\d+\?)$/i )
1346							? ( $1, $2 )
1347							: ( $col, undef );
1348	445					862	$col = $fld;
1349	445	100				987	if ( $col =~ m/^(\S+)\.\*$/ )
1350							{
1351	2					11	my $table = $1;
1352	2	50				8	if ( defined($alias) )
1353							{
1354	0					0	return $self->do_err("'$table.*' cannot be aliased");
1355							}
1356							$table = $self->{tmp}->{is_table_alias}->{$table}
1357	2	50				7	if ( $self->{tmp}->{is_table_alias}->{$table} );
1358							$table = $self->{tmp}->{is_table_alias}->{"\L$table"}
1359	2	50				8	if ( $self->{tmp}->{is_table_alias}->{"\L$table"} );
1360	2	50				6	return undef unless ( $self->TABLE_NAME($table) );
1361	2					5	$table = $self->replace_quoted_ids($table);
1362	2					13	push(
1363							@newcols,
1364							{
1365							type => 'column',
1366							value => "$table.*",
1367							}
1368							);
1369							}
1370							else
1371							{
1372	443					651	my $newcol;
1373	443					1011	$newcol = $self->SET_FUNCTION_SPEC($col);
1374	443	100				1157	return if ( $self->{struct}->{errstr} );
1375	440		66			1623	$newcol \|\|= $self->ROW_VALUE($col);
1376	440	100				1110	return if ( $self->{struct}->{errstr} );
1377	439	50				1272	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	439	100	100			1961	if ( !defined($alias)
			100
1382							&& ( ( 'function' eq $newcol->{type} ) \|\| ( 'setfunc' eq $newcol->{type} ) ) )
1383							{
1384	220					465	$alias = $newcol->{name};
1385							}
1386
1387	439	100				865	if ( defined($alias) )
1388							{
1389	236					596	$alias = $self->replace_quoted_ids($alias);
1390	236					559	$newcol->{alias} = $alias;
1391	236					779	$aliases{ $newcol->{fullorg} } = $alias;
1392	236					584	$self->{struct}->{ORG_NAME}->{ $newcol->{fullorg} } = $alias;
1393	236					741	$self->{struct}->{ALIASES}->{$alias} = $newcol->{fullorg};
1394							}
1395	439					1205	push( @newcols, $newcol );
1396							}
1397							}
1398	308					866	$self->{struct}->{column_aliases} = \%aliases;
1399	308					682	$self->{struct}->{column_defs} = \@newcols;
1400	308					1274	return 1;
1401							}
1402
1403							sub SET_FUNCTION_SPEC
1404							{
1405	443			443	0	802	my ( $self, $col_str ) = @_;
1406
1407	443	100				1160	if ( $col_str =~ m/^(COUNT\|AVG\|SUM\|MAX\|MIN) $(.)$\s$/i )
1408							{
1409	34					96	my $set_function_name = uc $1;
1410	34					70	my $set_function_arg_str = $2;
1411	34					109	my $distinct = 'ALL';
1412	34	100				145	if ( $set_function_arg_str =~ s/(DISTINCT\|ALL) (.+)$/$2/i )
1413							{
1414	5					18	$distinct = uc $1;
1415							}
1416	34		100			121	my $count_star = ( $set_function_name eq 'COUNT' ) && ( $set_function_arg_str eq '*' );
1417
1418	34					51	my $set_function_arg;
1419	34	100				79	if ($count_star)
1420							{
1421	8	100				42	return $self->do_err("Keyword DISTINCT is not allowed for COUNT(*)")
1422							if ( 'DISTINCT' eq $distinct );
1423	7					33	$set_function_arg = {
1424							type => 'column',
1425							value => '*'
1426							};
1427							}
1428							else
1429							{
1430	26					71	$set_function_arg = $self->ROW_VALUE($set_function_arg_str);
1431	26	50				87	return if ( $self->{struct}->{errstr} );
1432	26	50				94	return unless ( defined( _HASH($set_function_arg) ) );
1433							}
1434
1435	33					96	$self->{struct}->{has_set_functions} = 1;
1436
1437	33					292	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	33					98	return $value;
1446							}
1447							else
1448							{
1449	409					972	return undef;
1450							}
1451							}
1452
1453							sub LIMIT_CLAUSE
1454							{
1455	9			9	0	23	my ( $self, $limit_clause ) = @_;
1456
1457							# $limit_clause = trim($limit_clause);
1458	9					25	$limit_clause =~ s/^\s+//;
1459	9					26	$limit_clause =~ s/\s+$//;
1460
1461	9	50				27	return 1 if !$limit_clause;
1462	9					42	my $offset;
1463							my $limit;
1464	9					0	my $junk;
1465	9					54	($offset, $limit, $junk ) = split /,\|OFFSET/i, $limit_clause;
1466	9	100				38	if ($limit_clause =~ m/(\d+)\s+OFFSET\s+(\d+)/) {
1467	1					3	$limit = $1;
1468	1					2	$offset = $2;
1469							} else {
1470	8					29	( $offset, $limit, $junk ) = split /,/i, $limit_clause;
1471							}
1472	9	50	66			106	return $self->do_err('Bad limit clause!:'.$limit_clause)
			33
			33
			33
1473							if ( defined $limit and $limit =~ /[^\d]/ )
1474							or ( defined $offset and $offset =~ /[^\d]/ )
1475							or defined $junk;
1476	9	100	66			46	if ( defined $offset and !defined $limit )
1477							{
1478	2					6	$limit = $offset;
1479	2					5	undef $offset;
1480							}
1481							$self->{struct}->{limit_clause} = {
1482	9					50	limit => $limit,
1483							offset => $offset,
1484							};
1485	9					28	return 1;
1486							}
1487
1488							sub SORT_SPEC_LIST
1489							{
1490	20			20	0	57	my ( $self, $order_clause ) = @_;
1491	20	50				61	return 1 if !$order_clause;
1492	20					39	my @ocols;
1493	20					71	my @order_columns = split ',', $order_clause;
1494	20					59	for my $col (@order_columns)
1495							{
1496	26					66	my $newcol;
1497							my $newarg;
1498	26	100				177	if ( $col =~ /\s*(\S+)\s+(ASC\|DESC)/si )
		50
1499							{
1500	9					35	$newcol = $1;
1501	9					30	$newarg = uc $2;
1502							}
1503							elsif ( $col =~ /^\s(\S+)\s$/si )
1504							{
1505	17					46	$newcol = $1;
1506	17					38	$newarg = 'ASC';
1507							}
1508							else
1509							{
1510	0					0	return $self->do_err('Junk after column name in ORDER BY clause!');
1511							}
1512	26	50				101	$newcol = $self->COLUMN_NAME($newcol) or return;
1513	26	100				95	if ( $newcol =~ /^(.+)\..+$/s )
1514							{
1515	3					26	my $table = $1;
1516	3					8	$self->_verify_tablename( $table, "ORDER BY" );
1517							}
1518	26					108	push( @ocols, { $newcol => $newarg } );
1519							}
1520	20					66	$self->{struct}->{sort_spec_list} = \@ocols;
1521	20					83	return 1;
1522							}
1523
1524							sub SEARCH_CONDITION
1525							{
1526	231			231	0	503	my ( $self, $str ) = @_;
1527	231					493	$str =~ s/^\s*WHERE (.+)/$1/;
1528	231					503	$str =~ s/^\s+//;
1529	231					636	$str =~ s/\s+$//;
1530	231	50				479	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	231					591	$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	231					623	$str = $self->transform_syntax($str);
1544
1545	231					523	my $open_parens = $str =~ tr/\(//;
1546	231					377	my $close_parens = $str =~ tr/\)//;
1547	231	50				487	if ( $open_parens != $close_parens )
1548							{
1549	0					0	return $self->do_err("Mismatched parentheses in WHERE clause!");
1550							}
1551	231					622	$str = nongroup_numeric( $self->nongroup_string($str) );
1552	231	100				853	my $pred =
1553							$open_parens
1554							? $self->parens_search( $str, [] )
1555							: $self->non_parens_search( $str, [] );
1556	229	50				631	return $self->do_err("Couldn't find predicate!") unless $pred;
1557	229					498	$self->{struct}->{where_clause} = $pred;
1558	229					603	return 1;
1559							}
1560
1561							############################################################
1562							# UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE
1563							############################################################
1564
1565							sub repl_btwin
1566							{
1567	231			231	1	453	my ( $self, $str ) = @_; # DAA make OO for subclassing
1568	231					329	my @lids;
1569
1570	231					344	my $i = -1;
1571	231					1025	while ( $str =~ m/\G.*(?:IN\|BETWEEN)\s+\(/g )
1572							{
1573	32					78	my $start = pos($str) - 1;
1574	32					47	my $lparens = 1;
1575	32					58	my $rparens = 0;
1576	32					135	while ( $str =~ m/\G.*?([])/gcs )
1577							{
1578	36	100				118	++$lparens if ( '(' eq $1 );
1579	36	100				92	++$rparens if ( ')' eq $1 );
1580	36	100				94	last if ( $lparens == $rparens );
1581							}
1582	32					53	my $now = pos($str);
1583	32					62	++$i;
1584	32					76	my $subst = "?LI$i?";
1585	32					110	my $term = substr( $str, $start, $now - $start, $subst );
1586	32					72	$term = substr( $term, 1, length($term) - 2 );
1587	32					68	push( @lids, $term );
1588	32					140	pos($str) = $start + length($subst);
1589							}
1590
1591	231					521	$self->{struct}->{list_ids} = \@lids;
1592	231					557	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							#
1602							sub parens_search
1603							{
1604	135			135	1	321	my ( $self, $str, $predicates ) = @_;
1605	135					209	my $index = scalar( @{$predicates} );
	135					231
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	135					250	my $lparens = ( $str =~ tr/\(// );
1616	135					218	my $rparens = ( $str =~ tr/\)// );
1617	135	0				335	return $self->do_err( 'Unmatched ' . ( ( $lparens > $rparens ) ? 'left' : 'right' ) . " parentheses in '$str'!" )
		50
1618							unless ( $lparens == $rparens );
1619
1620	135	100				413	return $self->non_parens_search( $str, $predicates )
1621							unless $lparens;
1622
1623	8					17	my @lparens = ();
1624	8					40	while ( $str =~ m/\G.*?([])/gcs )
1625							{
1626	20	100				107	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	10					23	my $pos = pop @lparens;
1635	10					29	my $predlen = $+[1] - $pos;
1636	10					36	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	10	100				72	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	3					13	push( @$predicates, substr( $str, $pos + 1, $predlen - 2 ) );
1649	3					13	my $replacement = "^$#$predicates^";
1650	3					10	substr( $str, $pos, $predlen ) = $replacement;
1651	3					16	pos($str) = $pos + length($replacement);
1652							}
1653
1654	8					30	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							#
1663							sub non_parens_search
1664							{
1665	311			311	1	627	my ( $self, $str, $predicates ) = @_;
1666	311					477	my $neg = 0;
1667	311					485	my $nots = {};
1668
1669	311	50				803	$neg = 1, $nots = { pred => 1 }
1670							if ( $str =~ s/^NOT (\^.+)$/$1/i );
1671
1672	311					489	my ( $pred1, $pred2, $op );
1673	311					518	my $and_preds = [];
1674	311					721	( $str, $and_preds ) = group_ands($str);
1675	311	50				785	$str = $and_preds->[$1]
1676							if $str =~ /^\s~(\d+)~\s$/;
1677
1678	311	100				814	return $self->non_parens_search( $$predicates[$1], $predicates )
1679							if ( $str =~ /^\s\^(\d+)\^\s$/ );
1680
1681	309	100				1646	if ( $str =~ /\G(.?)\s+(AND\|OR)\s+(.)$/igcs )
1682							{
1683	39					156	( $pred1, $op, $pred2 ) = ( $1, $2, $3 );
1684
1685	39	100				106	if ( $pred1 =~ /^\s\^(\d+)\^\s$/ )
1686							{
1687	1					5	$pred1 = $self->non_parens_search( $$predicates[$1], $predicates );
1688							}
1689							else
1690							{
1691	38					88	$pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
1692	38					141	$pred1 = $self->non_parens_search( $pred1, $predicates );
1693							}
1694
1695							#
1696							# handle pred2 as a full predicate
1697							#
1698	39					96	$pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
1699	39					106	$pred2 = $self->non_parens_search( $pred2, $predicates );
1700
1701							return {
1702	39					206	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	270					537	my $xstr = $str;
1715	270					474	my ( $k, $v );
1716	270	100				903	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	120					191	my $parens = 1;
1723	120					243	my $spos = $-[1];
1724	120					232	my $epos = 0;
1725	120	100	66			1024	$epos = $-[1], $parens += ( $1 eq '[' ) ? 1 : -1 while ( ( $parens > 0 ) && ( $str =~ /\G.*?([\[\]])/gcs ) );
1726	120					322	$k = substr( $str, $spos, $epos - $spos + 1 );
1727	120					225	$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	120	100				531	$v = $1, $v =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g
1734							if ( $str =~ /\G\s+\S+\s(.+)\s$/gcs );
1735							}
1736							else
1737							{
1738	150					436	$xstr =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
1739	150					818	( $k, $v ) = $xstr =~ /^(\S+?)\s+\S+\s(.+)\s$/;
1740							}
1741	270	50				728	push @{ $self->{struct}{where_cols}{$k} }, $v
	270					1133
1742							if defined $k;
1743	270					771	return $self->PREDICATE($str);
1744							}
1745
1746							# groups AND clauses that aren't already grouped by parens
1747							#
1748							sub group_ands
1749							{
1750	315			315	1	530	my $str = shift;
1751	315		100			968	my $and_preds = shift \|\| [];
1752	315	100	100			1520	return ( $str, $and_preds )
1753							unless $str =~ / AND / and $str =~ / OR /;
1754
1755	4	50				29	return $str, $and_preds
1756							unless ( $str =~ /^(.?) AND (.)$/i );
1757
1758	4					19	my ( $front, $back ) = ( $1, $2 );
1759	4					10	my $index = scalar @$and_preds;
1760	4	50				21	$front = $1
1761							if ( $front =~ /^.* OR (.*)$/i );
1762
1763	4	50				26	$back = $1
1764							if ( $back =~ /^(.?) (OR\|AND) .$/i );
1765
1766	4					14	my $newpred = "$front AND $back";
1767	4					11	push @$and_preds, $newpred;
1768	4					56	$str =~ s/\Q$newpred/~$index~/i;
1769	4					21	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							#
1778							sub nongroup_string
1779							{
1780	231			231	1	508	my ( $self, $str ) = @_;
1781
1782							#
1783							# add in any user defined functions
1784							#
1785	231					553	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	231					409	my $parens = 0;
1792	231					312	my $pos;
1793	231					384	my @lparens = ();
1794	231					10048	while ( $str =~ /\G.?((\b($f)\s$)\|[\($])/igcs )
1795							{
1796	298	100				926	if ( $1 eq ')' )
		100
1797							{
1798							#
1799							# close paren, see if any pending function open
1800							# paren matches it
1801							#
1802	149					239	--$parens;
1803	149	100	66			1561	$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	15					119	++$parens;
1813							}
1814							else
1815							{
1816
1817							#
1818							# new function definition, capture its open paren
1819							# also uppercase the function name
1820							#
1821	134					336	$pos = $+[0];
1822	134					591	substr( $str, $-[3], length($3) ) = uc $3;
1823	134					414	substr( $str, $+[0] - 1, 1 ) = '[';
1824	134					327	pos($str) = $pos;
1825	134					279	push @lparens, $parens;
1826	134					1095	++$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	231					942	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							#
1845							sub nongroup_numeric
1846							{
1847	233			233	1	393	my $str = $_[0];
1848	233					367	my $has_op;
1849
1850							#
1851							# DAA
1852							# optimize regex
1853							#
1854	233	100				737	if ( $str =~ m/$([\p{Word} \*\/\+\-\[\]\?]+)$/ )
1855							{
1856	7					20	my $match = $1;
1857	7	100				41	if ( $match !~ m/(LIKE \|IS\|BETWEEN\|IN)/i )
1858							{
1859	5					16	my $re = quotemeta($match);
1860	5					84	$str =~ s/$$re$/MATH\[$match\]/;
1861							}
1862							else
1863							{
1864	2					5	$has_op++;
1865							}
1866							}
1867
1868							#
1869							# DAA
1870							# remove scoped recursion
1871							#
1872	233	100	100			1132	return ( !$has_op and $str =~ /$([\p{Word} \*\/\+\-\[\]\?]+)$/ )
1873							? nongroup_numeric($str)
1874							: $str;
1875							}
1876							############################################################
1877
1878							#########################################################
1879							# LITERAL_LIST ::= [,]
1880							#########################################################
1881							sub LITERAL_LIST
1882							{
1883	192			192	0	644	my ( $self, $str ) = @_;
1884							my @tokens = extract_multiple($str, [
1885	1036		100	1036		38805	sub { my ($m, $r, $p) = extract_bracketed($_[0], "()", qr/[^,(]*/); (($p\|\|'').($m\|\|''), $r, ''); },
	1036		100			71013
1886	192					1687	qr/([^,(]+)/,
1887							], undef, 1);
1888	192					7391	my @values;
1889	192					420	for my $tok (@tokens)
1890							{
1891	614					1347	my $val = $self->ROW_VALUE($tok);
1892	614	50				1392	return $self->do_err(qq('$tok' is not a valid value or is not quoted!))
1893							unless $val;
1894	614					1371	push @values, $val;
1895							}
1896	192					286	push( @{ $self->{struct}->{values} }, \@values );
	192					550
1897	192					702	return 1;
1898							}
1899
1900							#############################################################################
1901							# LITERAL ::= \| \| \| NULL/TRUE/FALSE
1902							#############################################################################
1903							sub LITERAL
1904							{
1905	1899			1899	0	3356	my ( $self, $str ) = @_;
1906
1907							#
1908							# DAA
1909							# strip parens (if any)
1910							#
1911	1899					3849	$str = $1 while ( $str =~ m/^\s$\s(.+)\s$\s$/ );
1912
1913	1899	100				3747	return 'null' if $str =~ m/^NULL$/i; # NULL
1914	1872	100				3658	return 'boolean' if $str =~ m/^(?:TRUE\|FALSE)$/i; # TRUE/FALSE
1915
1916							# return 'empty_string' if $str =~ /^~E~$/i; # NULL
1917	1859	100				3421	if ( $str eq '?' )
1918							{
1919	36					85	$self->{struct}->{num_placeholders}++;
1920	36					110	return 'placeholder';
1921							}
1922
1923							# return 'placeholder' if $str eq '?'; # placeholder question mark
1924	1823	100				3295	return 'string' if $str =~ m/^'.*'$/s; # quoted string
1925							# return 'number' if $str =~ m/^[+-]?(?=\d\|\.\d)\d(\.\d)?([Ee]([+-]?\d+))?$/; # number
1926	1822	100				6439	return 'number' if ( looks_like_number($str) ); # number
1927
1928	1126					2598	return undef;
1929							}
1930							###################################################################
1931							# PREDICATE
1932							###################################################################
1933							sub PREDICATE
1934							{
1935	270			270	0	515	my ( $self, $str ) = @_;
1936
1937	270					466	my ( $arg1, $op, $arg2, $opexp );
1938
1939							$opexp = $self->{opts}{valid_comparison_NOT_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1940	270	50				2285	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	270	50	66			2338	&& $self->{opts}{valid_comparison_twochar_ops_regex} );
1945
1946							$opexp = $self->{opts}{valid_comparison_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1947	270	50	66			2812	if ( !defined($op) && $self->{opts}{valid_comparison_ops_regex} );
1948
1949							#
1950							### USER-DEFINED PREDICATE
1951							#
1952	269	50	66			1314	unless ( defined $arg1 && defined $op && defined $arg2 )
			66
1953							{
1954	57					77	$arg1 = $str;
1955	57					98	$op = 'USER_DEFINED';
1956	57					68	$arg2 = '';
1957							}
1958
1959	269					517	$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	269					436	my $negated = 0; # boolean value showing if predicate is negated
1968	269					386	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	269	100				759	$not{arg1}++
1977							if ( $arg1 =~ s/^NOT (.+)$/$1/i );
1978
1979	269	100	100			1076	$not{op}++
1980							if ( $op =~ s/^(.+) NOT$/$1/i
1981							\|\| $op =~ s/^NOT (.+)$/$1/i );
1982
1983	269	100	66			682	$negated = 1 if %not and scalar keys %not == 1;
1984
1985	269	50				659	return undef unless $arg1 = $self->ROW_VALUE($arg1);
1986
1987	268	100				651	if ( $op ne 'USER_DEFINED' )
1988							{ # USER-PREDICATE;
1989	212	50				438	return undef unless $arg2 = $self->ROW_VALUE($arg2);
1990							}
1991							else
1992							{
1993
1994							# $arg2 = $self->ROW_VALUE($arg2);
1995							}
1996
1997	268	100	66			2349	if ( defined( _HASH($arg1) )
			50
			100
			50
			100
			100
1998							and defined( _HASH($arg2) )
1999							and ( ( $arg1->{type} \|\| '' ) eq 'column' )
2000							and ( ( $arg2->{type} \|\| '' ) eq 'column' )
2001							and ( $op eq '=' ) )
2002							{
2003	27					62	push( @{ $self->{struct}->{keycols} }, $arg1->{value} );
	27					98
2004	27					53	push( @{ $self->{struct}->{keycols} }, $arg2->{value} );
	27					81
2005							}
2006
2007							return {
2008	268					1897	neg => $negated,
2009							nots => \%not,
2010							arg1 => $arg1,
2011							op => $op,
2012							arg2 => $arg2,
2013							};
2014							}
2015
2016							sub _udf_function_names
2017							{
2018							$_[0]->{opts}->{_udf_function_names}
2019	2540	100		2540		6241	or return $_[0]->{opts}->{_udf_function_names} = join( "\|", map { uc $_ } keys %{ $_[0]->{opts}->{function_names} } );
	1971					3553
	18					423
2020	2522					7389	$_[0]->{opts}->{_udf_function_names};
2021							}
2022
2023							sub undo_string_funcs
2024							{
2025	2309			2309	1	4115	my ( $self, $str ) = @_;
2026	2309					4634	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	2309					4618	my ( $brackets, $pos, @lbrackets ) = (0);
2032	2309					28530	while ( $str =~ /\G.?((\b($f)\s\[)\|[\[\]])/igcs )
2033							{
2034	278	100				789	if ( $1 eq ']' )
		100
2035							{
2036							# close paren, see if any pending function open
2037							# paren matches it
2038	139					194	$brackets--;
2039	139	100	66			1271	$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	5					35	$brackets++;
2046							}
2047							else
2048							{
2049							# new function definition, capture its open paren
2050							# also uppercase the function name
2051	134					295	$pos = $+[0];
2052	134					501	substr( $str, $-[3], length($3) ) = uc $3;
2053	134					376	substr( $str, $+[0] - 1, 1 ) = '(';
2054	134					298	pos($str) = $pos;
2055	134					281	push @lbrackets, $brackets;
2056	134					893	$brackets++;
2057							}
2058							}
2059
2060	2309					6095	return $str;
2061							}
2062
2063							sub undo_math_funcs
2064							{
2065	2309			2309	1	3708	my $str = $_[0];
2066
2067							# eliminate recursion
2068	2309					4800	while ( $str =~ s/MATH\[([^\]\[]+?)\]/($1)/ )
2069							{
2070							}
2071
2072	2309					4162	return $str;
2073							}
2074
2075							#
2076							# DAA
2077							# need better nested function/parens handling
2078							#
2079							sub extract_func_args
2080							{
2081	346			346	1	653	my ( $self, $value ) = @_;
2082
2083	346					574	my @final_args = ();
2084	346					704	my ( $spos, $parens, $epos, $delim ) = ( 0, 0, 0, 0 );
2085	346					1297	while ( $value =~ m/\G.*?([,])/gcs )
2086							{
2087	201					535	$epos = $+[0];
2088	201					430	$delim = $1;
2089	201	100	100			741	unless ( $parens or ( $delim ne ',' ) )
2090							{
2091	149					555	push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos - 1 ) ) );
2092	149					430	$spos = $epos;
2093	149					583	next;
2094							}
2095
2096	52	100				153	unless ( $delim eq ',' )
2097							{
2098	38	100				153	$parens += ( $delim eq '(' ) ? 1 : -1;
2099							}
2100							}
2101
2102							# don't forget the last argument
2103	346	100				779	if ( $spos != length($value) )
2104							{
2105	312					412	$epos = length($value);
2106	312					1063	push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos ) ) ); # XXX
2107							}
2108
2109	346					1249	return @final_args;
2110							}
2111
2112							###################################################################
2113							# ROW_VALUE ::= \|
2114							###################################################################
2115							sub ROW_VALUE
2116							{
2117	2309			2309	0	4832	my ( $self, $str ) = @_;
2118
2119	2309					5063	$str =~ s/^\s+//;
2120	2309					4461	$str =~ s/\s+$//;
2121	2309					4852	$str = $self->undo_string_funcs($str);
2122	2309					4605	$str = undo_math_funcs($str);
2123	2309					4844	my ( $orgstr, $f, $bf ) = ( $str, FUNCTION_NAMES, BAREWORD_FUNCTIONS );
2124
2125							# USER-DEFINED FUNCTION
2126	2309					3444	my ( $user_func_name, $user_func_args, $is_func );
2127
2128							# DAA
2129							# need better paren check here
2130	2309	100				8747	if ( $str =~ m/^([^\s\(]+)\s(.)\s*$/ )
2131							{
2132	2303					4852	$user_func_name = $1;
2133	2303					3534	$user_func_args = $2;
2134
2135							# convert operator-like function to parenthetical format
2136	2303	100	100			4663	if ( ( $is_func = $self->is_func($user_func_name) )
			100
2137							&& ( $user_func_args !~ m/^$.*$$/ )
2138							&& ( $is_func =~ /^(?:$bf)$/i ) )
2139							{
2140	8					33	$orgstr = $str = "$user_func_name ($user_func_args)";
2141							}
2142							}
2143							else
2144							{
2145	6					15	$user_func_name = $str;
2146	6					32	$user_func_name =~ s/^(\S+).*$/$1/;
2147	6					14	$user_func_args = '';
2148	6					20	$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	2309	100	100			8119	undef $is_func if ( $is_func && $is_func !~ /^(?:$bf)$/i && $str !~ m/^\S+\s$.$\s*$/ );
			100
2155
2156	2309	100	66			5881	if ( $is_func && ( uc($is_func) !~ m/^($f)$/ ) )
2157							{
2158	346					776	my ( $name, $value ) = ( $user_func_name, '' );
2159	346	50				1283	if ( $str =~ m/^(\S+)\s$(.)$\s*$/ )
2160							{
2161	346					708	$name = $1;
2162	346					607	$value = $2;
2163	346					712	$is_func = $self->is_func($name);
2164							}
2165
2166	346	50				877	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	346					838	my @final_args = $self->extract_func_args($value);
2180	346					862	my $usr_sub = $self->{opts}->{function_names}->{$is_func};
2181	346					733	$self->{struct}->{procedure} = {};
2182	346	50				716	if ($usr_sub)
2183							{
2184	346					1539	$value = {
2185							type => 'function',
2186							name => lc $name,
2187							subname => $usr_sub,
2188							value => \@final_args,
2189							fullorg => $orgstr,
2190							};
2191
2192	346					1542	return $value;
2193							}
2194							}
2195							}
2196
2197	1963					2583	my $type;
2198							# MATH
2199							#
2200	1963	100				4662	if ( $str =~ m/[\*\+\-\/\%]/ )
2201							{
2202	45					81	my @vals;
2203	45					81	my $i = -1;
2204	45					103	my $open_parens = $str =~ tr/\(//;
2205	45					89	my $close_parens = $str =~ tr/\)//;
2206	45	50				117	if ( $open_parens != $close_parens )
2207							{
2208	0					0	return $self->do_err("Mismatched parentheses in term '$str'!");
2209							}
2210
2211							# $str =~ s/([^\s\*\+\-\/\%\)\(]+)/push @vals,$1;++$i;"?$i?"/ge;
2212	45					188	while ( $str =~ m/\G.?([^\s\\+\-\/\%\)\(]+)/g )
2213							{
2214	74					190	my $term = $1;
2215	74					134	my $start = pos($str) - length($term);
2216	74	100				135	if ( $self->is_func($term) )
2217							{
2218	5					11	my $lparens = 0;
2219	5					7	my $rparens = 0;
2220	5					22	while ( $str =~ m/\G.*?([])/gcs )
2221							{
2222	4	100				12	++$lparens if ( '(' eq $1 );
2223	4	100				12	++$rparens if ( ')' eq $1 );
2224	4	100				14	last if ( $lparens == $rparens );
2225							}
2226	5					14	my $now = pos($str);
2227	5					9	++$i;
2228	5					24	$term = substr( $str, $start, $now - $start, "?$i?" );
2229	5					11	push( @vals, $term );
2230	5					33	pos($str) = $start + length("?$i?");
2231							}
2232							else
2233							{
2234	69					143	push( @vals, $term );
2235	69					106	++$i;
2236	69					201	substr( $str, $start, length($term), "?$i?" );
2237	69					341	pos($str) = $start + length("?$i?");
2238							}
2239							}
2240
2241	45					89	my @newvalues;
2242	45					95	foreach my $val (@vals)
2243							{
2244	74					154	my $newval = $self->ROW_VALUE($val);
2245	74	50	66			543	if ( $newval && $newval->{type} !~ m/number\|column\|placeholder\|function/ )
2246							{
2247	0					0	return $self->do_err(qq[String '$val' not allowed in Numeric expression!]);
2248							}
2249	74					223	push( @newvalues, $newval );
2250							}
2251
2252							return {
2253	45					314	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	1918	100				3788	if ( $str =~ m/^SUBSTRING $(.+?) FROM (.+)$\s*$/i )
2264							{
2265	5					11	my $name = 'SUBSTRING';
2266	5					15	my $start = $2;
2267	5					18	my $value = $self->ROW_VALUE($1);
2268	5					12	my $length;
2269	5	100				30	if ( $start =~ /^(.+?) FOR (.+)$/i )
2270							{
2271	4					12	$start = $1;
2272	4					9	$length = $2;
2273	4					15	$length = $self->ROW_VALUE($length);
2274							}
2275	5					17	$start = $self->ROW_VALUE($start);
2276	5					15	$str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2277	5	50	33			35	if ( ( $start->{type} eq 'string' )
			33
2278							or ( $start->{length} && ( $start->{length}->{type} eq 'string' ) ) )
2279							{
2280	0					0	return $self->do_err("Can't use a string as a SUBSTRING position: '$str'!");
2281							}
2282	5	50				19	return undef unless ($value);
2283							return $self->do_err("Can't use a number in SUBSTRING: '$str'!")
2284	5	50				25	if $value->{type} eq 'number';
2285							return {
2286	5					46	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	1913	100				3471	if ( $str =~ m/^(TRIM) $(.+)$\s*$/i )
2298							{
2299	11					30	my $name = uc $1;
2300	11					26	my $value = $2;
2301	11					20	my ( $trim_spec, $trim_char );
2302	11	100				57	if ( $value =~ m/^(.+) FROM ([^]+)$/i )
2303							{
2304	5					13	my $front = $1;
2305	5					11	$value = $2;
2306	5	50				25	if ( $front =~ m/^\s(TRAILING\|LEADING\|BOTH)(.)$/i )
2307							{
2308	5					13	$trim_spec = uc $1;
2309	5					11	$trim_char = $2;
2310	5					12	$trim_char =~ s/^\s+//;
2311	5					12	$trim_char =~ s/\s+$//;
2312	5	100				13	undef $trim_char if ( length($trim_char) == 0 );
2313							}
2314							else
2315							{
2316	0					0	$trim_char = $front;
2317	0					0	$trim_char =~ s/^\s+//;
2318	0					0	$trim_char =~ s/\s+$//;
2319							}
2320							}
2321
2322	11		100			53	$trim_char \|\|= '';
2323	11					28	$trim_char =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2324	11					47	$value = $self->ROW_VALUE($value);
2325	11	50				36	return undef unless ($value);
2326	11					45	$str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2327	11	50				43	my $value_type = $value->{type} if ref $value eq 'HASH';
2328	11	50				39	$value_type = $value->[0] if ( defined( _ARRAY($value) ) );
2329	11	50	33			49	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	11					85	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	1902	100				4137	if ( $str =~ m/^(\S+) \(/ )
2344							{
2345	2					16	return $self->do_err("Unknown function '$1'");
2346							}
2347
2348							# STRING CONCATENATION
2349							#
2350	1900	100				3619	if ( $str =~ m/\\|\\|/ )
2351							{
2352	1					7	my @vals = split( m/ \\|\\| /, $str );
2353	1					3	my @newvals;
2354	1					3	for my $val (@vals)
2355							{
2356	3					10	my $newval = $self->ROW_VALUE($val);
2357	3	50				9	return undef unless ($newval);
2358							return $self->do_err("Can't use a number in string concatenation: '$str'!")
2359	3	50				8	if ( $newval->{type} eq 'number' );
2360	3					9	push @newvals, $newval;
2361							}
2362							return {
2363	1					7	type => 'function',
2364							name => 'str_concat',
2365							value => \@newvals,
2366							fullorg => $orgstr,
2367							};
2368							}
2369
2370							# NULL, BOOLEAN, PLACEHOLDER, NUMBER
2371							#
2372	1899	100				4090	if ( $type = $self->LITERAL($str) )
2373							{
2374	773	100				1618	undef $str if ( $type eq 'null' );
2375	773	100	66			1734	$str = 1 if ( $type eq 'boolean' and $str =~ /^TRUE$/i );
2376	773	50	66			1588	$str = 0 if ( $type eq 'boolean' and $str =~ /^FALSE$/i );
2377
2378							# if ($type eq 'empty_string') {
2379							# $str = '';
2380							# $type = 'string';
2381							# }
2382	773	100	100			2520	$str = '' if ( $str and $str eq q('') );
2383							return {
2384	773					3526	type => $type,
2385							value => $str,
2386							fullorg => $orgstr,
2387							};
2388							}
2389
2390							# QUOTED STRING LITERAL
2391							#
2392	1126	100				3694	if ( $str =~ m/\?(\d+)\?/ )
		100
2393							{
2394							return {
2395							type => 'string',
2396							value => $self->{struct}->{literals}->[$1],
2397	429					2617	fullorg => $self->{struct}->{literals}->[$1],
2398							};
2399							}
2400							elsif ( $str =~ /^\?LI(\d+)\?$/ )
2401							{
2402	30					117	return $self->ROW_VALUE_LIST( $self->{struct}->{list_ids}->[$1] );
2403							}
2404
2405							# COLUMN NAME
2406							#
2407	667	100				1586	return undef unless ( $str = $self->COLUMN_NAME($str) );
2408
2409	665	100				1835	if ( $str =~ m/^(.*)\./ )
2410							{
2411	119					260	my $table_name = $1;
2412	119					266	$self->_verify_tablename( $table_name, "WHERE" );
2413							}
2414
2415							# push @{ $self->{struct}->{where_cols}},$str
2416							# unless $self->{tmp}->{where_cols}->{"$str"};
2417	665					1931	++$self->{tmp}->{where_cols}->{$str};
2418							return {
2419	665					3513	type => 'column',
2420							value => $str,
2421							fullorg => $orgstr,
2422							};
2423							}
2424
2425							#########################################################
2426							# ROW_VALUE_LIST ::= [,...]
2427							#########################################################
2428							sub ROW_VALUE_LIST
2429							{
2430	56			56	0	136	my ( $self, $row_str ) = @_;
2431	56					188	my @row_list = split ',', $row_str;
2432	56	50				155	if ( !( scalar @row_list ) )
2433							{
2434	0					0	return $self->do_err('Missing row value list!');
2435							}
2436	56					107	my @newvals;
2437							my $newval;
2438	56					122	for my $row_val (@row_list)
2439							{
2440	129					299	$row_val =~ s/^\s+//;
2441	129					250	$row_val =~ s/\s+$//;
2442
2443	129	50				297	return undef if !( $newval = $self->ROW_VALUE($row_val) );
2444	129					332	push @newvals, $newval;
2445							}
2446	56					250	return \@newvals;
2447							}
2448
2449							###############################################
2450							# COLUMN NAME ::= [.]
2451							###############################################
2452
2453							sub COLUMN_NAME
2454							{
2455	693			693	0	1238	my ( $self, $str ) = @_;
2456	693					1079	my ( $table_name, $col_name );
2457	693	100				1565	if ( $str =~ m/^\s*(\S+)\.(\S+)$/s )
2458							{
2459	122					358	( $table_name, $col_name ) = ( $1, $2 );
2460	122	50				317	if ( !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} )
2461							{
2462	0					0	return $self->do_err('Dialect does not support multiple tables!');
2463							}
2464	122	50				277	return undef unless ( $table_name = $self->TABLE_NAME($table_name) );
2465	122					336	$table_name = $self->replace_quoted_ids($table_name);
2466	122					300	$self->_verify_tablename($table_name);
2467							}
2468							else
2469							{
2470	571					862	$col_name = $str;
2471							}
2472
2473	693					1464	$col_name =~ s/^\s+//;
2474	693					1253	$col_name =~ s/\s+$//;
2475
2476	693					1151	my $user_func = $col_name;
2477	693					2419	$user_func =~ s/^(\S+).*$/$1/;
2478	693	50				1984	if ( $col_name !~ m/^(TRIM\|SUBSTRING)$/i )
2479							{
2480	693	100				1977	undef $user_func unless ( $self->{opts}->{function_names}->{ uc $user_func } );
2481							}
2482	693	100				1381	if ( !$user_func )
2483							{
2484	690	100	66			2125	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	691					1316	my $orgcol = $col_name;
2490
2491	691	100				1369	if ( $col_name =~ m/^\?QI(\d+)\?$/ )
2492							{
2493	10					46	$col_name = '"' . $self->{struct}->{quoted_ids}->[$1] . '"';
2494							}
2495							else
2496							{
2497							$col_name = lc $col_name
2498							unless (
2499	681	50	33			3188	( $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	691	50				1762	if ( $self->{struct}->{column_aliases}->{$col_name} );
2512
2513							# $orgcol = $self->replace_quoted_ids($orgcol);
2514							##############################################
2515
2516	691	100				1300	if ($table_name)
2517							{
2518	122					269	my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"};
2519	122	100				236	$table_name = $alias if ( defined($alias) );
2520	122	100				304	$table_name = lc $table_name unless ( $table_name =~ m/^"/ );
2521	122	50				403	$col_name = "$table_name.$col_name" if ( -1 == index( $col_name, '.' ) );
2522							}
2523	691					1958	return $col_name;
2524							}
2525
2526							#########################################################
2527							# COLUMN NAME_LIST ::= [,...]
2528							#########################################################
2529							sub COLUMN_NAME_LIST
2530							{
2531	0			0	0	0	my ( $self, $col_str ) = @_;
2532
2533	0					0	my @col_list = split( ',', $col_str );
2534	0	0				0	return $self->do_err('Missing column name list!') unless ( scalar(@col_list) );
2535
2536	0					0	my @newcols;
2537	0					0	for my $col (@col_list)
2538							{
2539	0					0	$col =~ s/^\s+//;
2540	0					0	$col =~ s/\s+$//;
2541
2542	0					0	my $newcol;
2543	0	0				0	return undef unless ( $newcol = $self->COLUMN_NAME($col) );
2544	0					0	push( @newcols, $newcol );
2545							}
2546
2547	0					0	return \@newcols;
2548							}
2549
2550							#####################################################
2551							# TABLE_NAME_LIST := [,...]
2552							#####################################################
2553							sub TABLE_NAME_LIST
2554							{
2555	386			386	0	782	my ( $self, $table_name_str ) = @_;
2556	386					637	my %aliases = ();
2557	386					616	my @tables;
2558	386					665	$table_name_str =~ s/(\?\d+\?),/$1:/g; # fudge commas in functions
2559	386					1233	my @table_names = split ',', $table_name_str;
2560	386	50	66			1304	if ( scalar @table_names > 1
2561							and !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} )
2562							{
2563	0					0	return $self->do_err('Dialect does not support multiple tables!');
2564							}
2565
2566	386					770	my $bf = BAREWORD_FUNCTIONS;
2567	386					577	my %is_table_alias;
2568	386					710	for my $table_str (@table_names)
2569							{
2570	501					832	$table_str =~ s/(\?\d+\?):/$1,/g; # unfudge commas in functions
2571	501					808	$table_str =~ s/\s+\(/\(/g; # fudge spaces in functions
2572	501					827	my ( $table, $alias );
2573	501					1309	my (@tstr) = split( m/\s+/, $table_str );
2574	501	100				1111	if ( @tstr == 1 )
		100
		100
2575							{
2576	475					789	$table = $tstr[0];
2577							}
2578							elsif ( @tstr == 2 )
2579							{
2580	11					19	$table = $tstr[0];
2581	11					20	$alias = $tstr[1];
2582							}
2583							elsif ( @tstr == 3 )
2584							{
2585	13	50				39	return $self->do_err("Can't find alias in FROM clause!")
2586							unless ( uc( $tstr[1] ) eq 'AS' );
2587	13					23	$table = $tstr[0];
2588	13					24	$alias = $tstr[2];
2589							}
2590							else
2591							{
2592	2					8	return $self->do_err("Can't find table names in FROM clause!");
2593							}
2594
2595	499					847	$table =~ s/\(/ \(/g; # unfudge spaces in functions
2596	499					787	my $u_name = $table;
2597	499					2050	$u_name =~ s/^(\S+)\s(.$)/$1/;
2598	499					1035	my $u_args = $2;
2599
2600	499	100	66			1117	if ( ( $u_name = $self->is_func($u_name) )
			100
2601							&& ( $u_name =~ /^(?:$bf)$/i \|\| $table =~ /^$u_name\s*\(/i ) )
2602							{
2603	2	50				8	$u_args = " $u_args" if ($u_args);
2604	2					11	my $u_func = $self->ROW_VALUE( $u_name . $u_args );
2605	2					6	$self->{struct}->{table_func}->{$u_name} = $u_func;
2606	2					7	$self->{struct}->{temp_table} = 1;
2607	2					4	$table = $u_name;
2608							}
2609							else
2610							{
2611	497	100				1143	return undef unless ( $self->TABLE_NAME($table) );
2612							}
2613
2614	494					1371	$table = $self->replace_quoted_ids($table);
2615	494	100				1477	push( @tables, $table =~ m/^"/ ? $table : $table );
2616
2617	494	100				1556	if ($alias)
2618							{
2619	24	50				59	return unless ( $self->TABLE_NAME($alias) );
2620	24					59	$alias = $self->replace_quoted_ids($alias);
2621	24	50				64	if ( $alias =~ m/^"/ )
2622							{
2623	0					0	push( @{ $aliases{$table} }, $alias );
	0					0
2624	0					0	$is_table_alias{$alias} = $table;
2625							}
2626							else
2627							{
2628	24					38	push( @{ $aliases{$table} }, "\L$alias" );
	24					90
2629	24					94	$is_table_alias{"\L$alias"} = $table;
2630							}
2631							}
2632							}
2633	379					828	my %is_table_name = map { $_ => 1 } @tables;
	492					1824
2634	379					1096	$self->{tmp}->{is_table_alias} = \%is_table_alias;
2635	379					742	$self->{tmp}->{is_table_name} = \%is_table_name;
2636	379					732	$self->{struct}->{table_names} = \@tables;
2637	379					673	$self->{struct}->{table_alias} = \%aliases;
2638	379	100				948	$self->{struct}->{multiple_tables} = 1 if ( @tables > 1 );
2639	379					1471	return 1;
2640							}
2641
2642							sub is_func($)
2643							{
2644	3228			3228	1	5781	my ( $self, $name ) = @_;
2645	3228					10898	$name =~ s/^(\S+).*$/$1/;
2646	3228	100				11656	return $name if ( $self->{opts}->{function_names}->{$name} );
2647	2548	100				6512	return uc $name if ( $self->{opts}->{function_names}->{ uc $name } );
2648	2516					6647	undef;
2649							}
2650
2651							#############################
2652							# TABLE_NAME :=
2653							#############################
2654							sub TABLE_NAME
2655							{
2656	917			917	0	1803	my ( $self, $table_name ) = @_;
2657	917	50				2031	if ( $table_name =~ m/^(.+?)\.([^\.]+)$/ )
2658							{
2659	0					0	my $schema = $1; # ignored
2660	0					0	$table_name = $2;
2661							}
2662	917	50				3626	if ( $table_name =~ m/\s*(\S+)\s+\S+/s )
2663							{
2664	0					0	return $self->do_err("Junk after table name '$1'!");
2665							}
2666	917					1647	$table_name =~ s/\s+//s;
2667	917	50				1773	if ( !$table_name )
2668							{
2669	0					0	return $self->do_err('No table name specified!');
2670							}
2671	917	100				2109	return $table_name if ( $self->IDENTIFIER($table_name) );
2672
2673							# return undef if !($self->IDENTIFIER($table_name));
2674							# return 1;
2675							}
2676
2677							sub _verify_tablename
2678							{
2679	244			244		520	my ( $self, $table_name, $location ) = @_;
2680	244	100				473	if ( defined($location) )
2681							{
2682	122					222	$location = " in $location";
2683							}
2684							else
2685							{
2686	122					201	$location = "";
2687							}
2688
2689	244	100				529	if ( $table_name =~ m/^"/ )
2690							{
2691	4	0	33			15	if ( !$self->{tmp}->{is_table_name}->{$table_name}
2692							and !$self->{tmp}->{is_table_alias}->{$table_name} )
2693							{
2694	0					0	return $self->do_err("Table '$table_name' referenced$location but not found in FROM list!");
2695							}
2696							}
2697							else
2698							{
2699	240					336	my @tblnamelist = ( keys( %{ $self->{tmp}->{is_table_name} } ), keys( %{ $self->{tmp}->{is_table_alias} } ) );
	240					705
	240					535
2700	240					538	my $tblnames = join( "\|", @tblnamelist );
2701	240	50				2205	unless ( $table_name =~ m/^(?:$tblnames)$/i )
2702							{
2703	0					0	return $self->do_err(
2704							"Table '$table_name' referenced$location but not found in FROM list (" . join( ",", @tblnamelist ) . ")!" );
2705							}
2706							}
2707
2708	244					481	return 1;
2709							}
2710
2711							###################################################################
2712							# IDENTIFIER ::= { \| _ }...
2713							#
2714							# and must not be a reserved word or over 128 chars in length
2715							###################################################################
2716							sub IDENTIFIER
2717							{
2718	1740			1740	0	3341	my ( $self, $id ) = @_;
2719	1740	100	66			6404	if ( $id =~ m/^\?QI(.+)\?$/ or $id =~ m/^\?(.+)\?$/ )
2720							{
2721	31					130	return 1;
2722							}
2723	1709	100				3423	if ( $id =~ m/^[`](.+)[`]$/ )
2724							{
2725	21	50				117	$id = $1 and return 1;
2726							}
2727	1688	50				3270	if ( $id =~ m/^(.+)\.([^\.]+)$/ )
2728							{
2729	0					0	my $schema = $1; # ignored
2730	0					0	$id = $2;
2731							}
2732	1688					4292	$id =~ s/$\|$//g;
2733	1688	50				3298	return 1 if $id =~ m/^".+?"$/s; # QUOTED IDENTIFIER
2734	1688					3798	my $err = "Bad table or column name: '$id' "; # BAD CHARS
2735	1688	100				3481	if ( $id =~ /\W/ )
2736							{
2737	4					13	$err .= "has chars not alphanumeric or underscore!";
2738	4					13	return $self->do_err($err);
2739							}
2740							# CSV requires optional start with _
2741	1684	50				7099	my $badStartRx = uc( $self->{dialect} ) eq 'ANYDATA' ? qr/^\d/ : qr/^[_\d]/;
2742	1684	50				6952	if ( $id =~ $badStartRx )
2743							{ # BAD START
2744	0					0	$err .= "starts with non-alphabetic character!";
2745	0					0	return $self->do_err($err);
2746							}
2747	1684	50				3812	if ( length $id > 128 )
2748							{ # BAD LENGTH
2749	0					0	$err .= "contains more than 128 characters!";
2750	0					0	return $self->do_err($err);
2751							}
2752	1684					2651	$id = uc $id;
2753	1684	100				4103	if ( $self->{opts}->{reserved_words}->{$id} )
2754							{ # BAD RESERVED WORDS
2755	3					12	$err .= "is a SQL reserved word!";
2756	3					12	return $self->do_err($err);
2757							}
2758	1681					7018	return 1;
2759							}
2760
2761							########################################
2762							# PRIVATE METHODS AND UTILITY FUNCTIONS
2763							########################################
2764							sub order_joins
2765							{
2766	39			39	1	87	my ( $self, $links ) = @_;
2767	39					84	for my $link (@$links)
2768							{
2769	115	100				265	if ( $link !~ /\./ )
2770							{
2771	19					59	return [];
2772							}
2773							}
2774	20					50	@$links = map { s/^(.+)\..*$/$1/; $1; } @$links;
	96					340
	96					244
2775	20					63	my @all_tables;
2776							my %relations;
2777	20					0	my %is_table;
2778	20					67	while (@$links)
2779							{
2780	48					91	my $t1 = shift @$links;
2781	48					78	my $t2 = shift @$links;
2782	48	50	33			183	return undef unless defined $t1 and defined $t2;
2783	48	100				162	push @all_tables, $t1 unless $is_table{$t1}++;
2784	48	100				125	push @all_tables, $t2 unless $is_table{$t2}++;
2785	48					111	$relations{$t1}{$t2}++;
2786	48					126	$relations{$t2}{$t1}++;
2787							}
2788	20					70	my @tables = @all_tables;
2789	20					48	my @order = shift @tables;
2790	20					61	my %is_ordered = ( $order[0] => 1 );
2791	20					30	my %visited;
2792	20					53	while (@tables)
2793							{
2794	32					60	my $t = shift @tables;
2795	32					47	my @rels = keys %{ $relations{$t} };
	32					103
2796	32					72	for my $t2 (@rels)
2797							{
2798	36	100				85	next unless $is_ordered{$t2};
2799	32					57	push @order, $t;
2800	32					56	$is_ordered{$t}++;
2801	32					53	last;
2802							}
2803	32	50				114	if ( !$is_ordered{$t} )
2804							{
2805	0	0				0	push @tables, $t if $visited{$t}++ < @all_tables;
2806							}
2807							}
2808	20	50				62	return $self->do_err("Unconnected tables in equijoin statement!")
2809							if @order < @all_tables;
2810	20					124	return \@order;
2811							}
2812
2813							# PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW
2814							#
2815							#
2816							sub set_feature_flags
2817							{
2818	17			17	1	98	my ( $self, $select, $create ) = @_;
2819	17	50				89	if ( defined $select )
2820							{
2821	0					0	delete $self->{select};
2822							$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} =
2823	0					0	$self->{opts}->{select}->{join} = $select->{join};
2824							}
2825	17	50				73	if ( defined $create )
2826							{
2827	0					0	delete $self->{create};
2828	0					0	for my $key ( keys %$create )
2829							{
2830	0					0	my $type = $key;
2831	0					0	$type =~ s/type_(.*)/\U$1/;
2832							$self->{opts}->{valid_data_types}->{$type} = $self->{opts}->{create}->{$key} =
2833	0					0	$create->{$key};
2834							}
2835							}
2836							}
2837
2838							sub clean_sql
2839							{
2840	872			872	1	1685	my ( $self, $sql ) = @_;
2841	872					1239	my $fields;
2842	872					1352	my $i = -1;
2843	872					1356	my $e = '\\';
2844	872					1655	$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	872					4747	$sql =~ s~(?
	442					1412
	442					720
	442					2111
2851
2852							#
2853	872					2194	foreach (@$fields) { $_ =~ s/''/\\'/g; }
	442					869
2854	872					2084	my @a = $sql =~ m/((?
2855	872	50				2364	if ( ( scalar(@a) % 2 ) == 1 )
2856							{
2857	0					0	$sql =~ s/^.*\?(.+)$/$1/;
2858	0					0	$self->do_err("Mismatched single quote before: <$sql>");
2859							}
2860	872	50				2078	if ( $sql =~ m/\?\?(\d)\?/ )
2861							{
2862	0					0	$sql = $fields->[$1];
2863	0					0	$self->do_err("Mismatched single quote: <$sql>");
2864							}
2865	872					1653	foreach (@$fields) { $_ =~ s/$e'/'/g; s/^'(.*)'$/$1/; }
	442					1143
	442					876
2866
2867							#
2868							# From Steffen G. to correctly return newlines from $dbh->quote;
2869							#
2870	872					1419	foreach (@$fields) { $_ =~ s/([^\\])\\r/$1\r/g; }
	442					716
2871	872					1397	foreach (@$fields) { $_ =~ s/([^\\])\\n/$1\n/g; }
	442					691
2872
2873	872					1746	$self->{struct}->{literals} = $fields;
2874
2875	872					1262	my $qids;
2876	872					1285	$i = -1;
2877	872					1308	$e = q/""/;
2878
2879							# $sql =~ s~"(([^"$e]\|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
2880	872					1970	$sql =~ s/"(([^"]\|"")+)"/push(@$qids,$1);$i++;"?QI$i?"/ge;
	62					194
	62					111
	62					270
2881
2882							#@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids;
2883	872	100				1765	$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	872					1531	my $comment_re = $self->{comment_re};
2891
2892							# if ( $sql =~ s/($comment_re)//gs) {
2893							# $self->{comment} = $1;
2894							# }
2895	872	50				2916	if ( $sql =~ m/(.*)$comment_re$/s )
2896							{
2897	0					0	$sql = $1;
2898	0					0	$self->{comment} = $2;
2899							}
2900	872	100				1895	if ( $sql =~ m/^(.)--(.)(\n\|$)/ )
2901							{
2902	2					6	$sql = $1;
2903	2					6	$self->{comment} = $2;
2904							}
2905
2906	872					1405	$sql =~ s/\n/ /g;
2907	872					5473	$sql =~ s/\s+/ /g;
2908	872					3822	$sql =~ s/(\S)\(/$1 (/g; # ensure whitespace before (
2909	872					1875	$sql =~ s/\)(\S)/) $1/g; # ensure whitespace after )
2910	872					2770	$sql =~ s/\(\s*/(/g; # trim whitespace after (
2911	872					3716	$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	872					7737	$sql =~ s/(\S)([<>]?=\|<>\|<\|>\|\\|\\|)/$1 $2/g;
2921	872					6712	$sql =~ s/([<>]?=\|<>\|<\|>\|\\|\\|)(\S)/$1 $2/g;
2922	872					1570	$sql =~ s/< >/<>/g;
2923	872					1445	$sql =~ s/< =/<=/g;
2924	872					1433	$sql =~ s/> =/>=/g;
2925	872					2773	$sql =~ s/\s*,/,/g;
2926	872					2455	$sql =~ s/,\s*/,/g;
2927	872					1815	$sql =~ s/^\s+//;
2928	872					2390	$sql =~ s/\s+$//;
2929
2930	872					2803	return $sql;
2931							}
2932
2933							sub trim
2934							{
2935	4	50		4	1	14	my $str = $_[0] or return ('');
2936	4					9	$str =~ s/^\s+//;
2937	4					7	$str =~ s/\s+$//;
2938	4					8	return $str;
2939							}
2940
2941							sub do_err
2942							{
2943	19			19	1	52	my ( $self, $err, $errstr ) = @_;
2944
2945							# $err = $errtype ? "DIALECT ERROR: $err" : "SQL ERROR: $err";
2946	19					52	$self->{struct}->{errstr} = $err;
2947
2948	19	50				67	carp $err if ( $self->{PrintError} );
2949	19	100				762	croak $err if ( $self->{RaiseError} );
2950	13					79	return;
2951							}
2952
2953							#
2954							# DAA
2955							# abstract method so subclasses can provide
2956							# their own syntax transformations
2957							#
2958							sub transform_syntax
2959							{
2960	231			231	1	478	my ( $self, $str ) = @_;
2961	231					394	return $str;
2962							}
2963
2964							sub DESTROY
2965							{
2966	12			12		6905	my $self = $_[0];
2967
2968	12					302	undef $self->{opts};
2969	12					107	undef $self->{struct};
2970	12					51	undef $self->{tmp};
2971	12					34	undef $self->{dialect};
2972	12					1907	undef $self->{dialect_set};
2973							}
2974
2975							1;
2976
2977							__END__