File Coverage

752							#
753							###################################################################
754							sub UPDATE
755							{
756	10			10	0	16	my ( $self, $str ) = @_;
757	10					25	$self->{struct}->{command} = 'UPDATE';
758	10					48	my ( $table_name, $remainder ) = $str =~ m/^UPDATE (.+?) SET (.+)$/i;
759	10	50	33			57	return $self->do_err('Incomplete UPDATE clause') unless ( $table_name && $remainder );
760	10	50				22	return undef unless ( $self->TABLE_NAME($table_name) );
761	10					31	$self->{tmp}->{is_table_name} = { $table_name => 1 };
762	10					23	$self->{struct}->{table_names} = [$table_name];
763	10					42	my ( $set_clause, $where_clause ) = $remainder =~ m/(.?) WHERE (.)$/i;
764	10	100				23	$set_clause = $remainder if ( !$set_clause );
765	10	100				39	return undef unless ( $self->SET_CLAUSE_LIST($set_clause) );
766
767	9	100				22	if ($where_clause)
768							{
769	6	50				18	return undef unless ( $self->SEARCH_CONDITION($where_clause) );
770							}
771
772	9					9	my @vals = @{ $self->{struct}->{values}->[0] };
	9					24
773	9					11	my $num_val_placeholders = 0;
774	9					17	for my $v (@vals)
775							{
776	14	100				39	++$num_val_placeholders if ( $v->{type} eq 'placeholder' );
777							}
778	9					15	$self->{struct}->{num_val_placeholders} = $num_val_placeholders;
779
780	9					17	return 1;
781							}
782
783							############
784							# FUNCTIONS
785							############
786							sub LOAD
787							{
788	18			18	0	38	my ( $self, $str ) = @_;
789	18					72	$self->{struct}->{command} = 'LOAD';
790	18					37	$self->{struct}->{no_execute} = 1;
791	18					91	my ($package) = $str =~ /^LOAD\s+(.+)$/;
792	18					30	$str = $package;
793	18					40	$package =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
794
795	18					54	$self->_load_class($package);
796
797	18					996	my %subs = eval '%' . $package . '::';
798
799	18					1090	for my $sub ( keys %subs )
800							{
801	2975	100				4539	next unless ( $sub =~ m/^SQL_FUNCTION_([A-Z_0-9]+)$/ );
802	1854					1658	my $funcName = uc $1;
803	1854					1983	my $subname = $package . '::' . 'SQL_FUNCTION_' . $funcName;
804	1854					2228	$self->{opts}->{function_names}->{$funcName} = $subname;
805	1854					1512	delete $self->{opts}->{_udf_function_names};
806							}
807	18					613	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	5	my ( $self, $stmt ) = @_;
842	3					5	$self->{struct}->{command} = 'CREATE_FUNCTION';
843	3					6	$self->{struct}->{no_execute} = 1;
844	3					4	my ( $func, $subname );
845	3					6	$stmt =~ s/\s*EXTERNAL//i;
846	3	100				9	if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi )
847							{
848	2					5	$func = trim($1);
849	2					4	$subname = trim($2);
850							}
851	3		66			9	$func \|\|= $stmt;
852	3		66			15	$subname \|\|= $func;
853	3	50				8	if ( $func =~ /^\?QI(\d+)\?$/ )
854							{
855	0					0	$func = $self->{struct}->{quoted_ids}->[$1];
856							}
857	3	100				11	if ( $subname =~ /^\?QI(\d+)\?$/ )
858							{
859	2					5	$subname = $self->{struct}->{quoted_ids}->[$1];
860							}
861	3					9	$self->{opts}->{function_names}->{ uc $func } = $subname;
862	3					4	delete $self->{opts}->{_udf_function_names};
863
864	3					7	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	4	my ( $self, $type ) = @_;
879	3					6	$self->{struct}->{command} = 'CREATE_TYPE';
880	3					4	$self->{struct}->{no_execute} = 1;
881	3					11	$self->feature( 'valid_data_types', uc $type, 1 );
882							}
883
884							sub DROP_TYPE
885							{
886	1			1	0	2	my ( $self, $type ) = @_;
887	1					2	$self->{struct}->{command} = 'DROP_TYPE';
888	1					1	$self->{struct}->{no_execute} = 1;
889	1					4	$self->feature( 'valid_data_types', uc $type, 0 );
890							}
891
892							sub CREATE_KEYWORD
893							{
894	1			1	0	2	my ( $self, $type ) = @_;
895	1					3	$self->{struct}->{command} = 'CREATE_KEYWORD';
896	1					1	$self->{struct}->{no_execute} = 1;
897	1					4	$self->feature( 'reserved_words', uc $type, 1 );
898							}
899
900							sub DROP_KEYWORD
901							{
902	1			1	0	1	my ( $self, $type ) = @_;
903	1					3	$self->{struct}->{command} = 'DROP_KEYWORD';
904	1					3	$self->{struct}->{no_execute} = 1;
905	1					3	$self->feature( 'reserved_words', uc $type, 0 );
906							}
907
908							sub CREATE_OPERATOR
909							{
910	2			2	0	3	my ( $self, $stmt ) = @_;
911	2					3	$self->{struct}->{command} = 'CREATE_OPERATOR';
912	2					5	$self->{struct}->{no_execute} = 1;
913
914	2					2	my ( $func, $subname );
915	2					3	$stmt =~ s/\s*EXTERNAL//i;
916	2	50				5	if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi )
917							{
918	0					0	$func = trim($1);
919	0					0	$subname = trim($2);
920							}
921	2		33			8	$func \|\|= $stmt;
922	2		33			7	$subname \|\|= $func;
923	2	50				4	if ( $func =~ /^\?QI(\d+)\?$/ )
924							{
925	0					0	$func = $self->{struct}->{quoted_ids}->[$1];
926							}
927	2	50				5	if ( $subname =~ /^\?QI(\d+)\?$/ )
928							{
929	0					0	$subname = $self->{struct}->{quoted_ids}->[$1];
930							}
931	2					6	$self->{opts}->{function_names}->{ uc $func } = $subname;
932	2					3	delete $self->{opts}->{_udf_function_names};
933
934	2					11	$self->feature( 'valid_comparison_operators', uc $func, 1 );
935	2					6	return $self->create_op_regexen();
936							}
937
938							sub DROP_OPERATOR
939							{
940	1			1	0	2	my ( $self, $type ) = @_;
941	1					3	$self->{struct}->{command} = 'DROP_OPERATOR';
942	1					1	$self->{struct}->{no_execute} = 1;
943	1					4	$self->feature( 'valid_comparison_operators', uc $type, 0 );
944	1					3	return $self->create_op_regexen();
945							}
946
947							sub replace_quoted($)
948							{
949	9			9	1	8	my ( $self, $str ) = @_;
950	9					14	my @l = map { $self->replace_quoted_ids($_) } split( ',', $self->replace_quoted_commas($str) );
	18					18
951	9					17	return @l;
952							}
953
954							#########
955							# CREATE
956							#########
957							sub CREATE
958							{
959	70			70	0	83	my ( $self, $stmt ) = @_;
960	70					88	my $features = 'TYPE\|KEYWORD\|FUNCTION\|OPERATOR\|PREDICATE';
961	70	100				911	if ( $stmt =~ m/^\s*CREATE\s+($features)\s+(.+)$/si )
962							{
963	9					21	my ( $sub, $arg ) = ( $1, $2 );
964	9					15	$sub = 'CREATE_' . uc $sub;
965	9					28	return $self->$sub($arg);
966							}
967
968	61					137	$stmt =~ s/^CREATE (LOCAL\|GLOBAL) /CREATE /si;
969	61	100				264	if ( $stmt =~ m/^\s*CREATE\s+(?:TEMP\|TEMPORARY)\s+TABLE\s+(.+)$/si )
970							{
971	43					114	$stmt = "CREATE TABLE $1";
972	43					89	$self->{struct}->{is_ram_table} = 1;
973							}
974	61					105	$self->{struct}->{command} = 'CREATE';
975	61					73	my ( $table_name, $table_element_def, %is_col_name );
976
977	61	100				225	if ( $stmt =~ m/^(.) ON COMMIT (DELETE\|PRESERVE) ROWS\s$/si )
978							{
979	4					18	$stmt = $1;
980	4					9	$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				211	if ( $stmt =~ m/^CREATE TABLE (\S+) $(.*)$$/si )
		0
989							{
990	61					101	$table_name = $1;
991	61					96	$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				143	return undef unless ( $self->TABLE_NAME($table_name) );
1016	61					160	$table_element_def =~ s/\s+\(/(/g;
1017	61					59	my $primary_defined;
1018	61					223	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					221	for my $col ( split( ',', $table_element_def ) )
1032							{
1033	139	100				375	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					9	my ( $name, $local_cols, $referenced_table, $referenced_cols ) = ( $1, $2, $3, $4 );
1047	3					5	my @local_cols = $self->replace_quoted($local_cols);
1048	3					5	$referenced_table = $self->replace_quoted_ids($referenced_table);
1049	3					6	my @referenced_cols = $self->replace_quoted($referenced_cols);
1050
1051	3	100				7	if ( defined $name )
1052							{
1053	2					3	$name = $self->replace_quoted_ids($name);
1054							}
1055							else
1056							{
1057	1					2	$name = $self->replace_quoted_ids($table_name);
1058	1					1	my ($quote_char) = '';
1059	1	50				4	if ( $name =~ s/(\W)$// )
1060							{
1061	0					0	$quote_char = ($1);
1062							}
1063	1					2	foreach my $local_col (@local_cols)
1064							{
1065	2					3	my $col_name = $local_col;
1066	2					4	$col_name =~ s/^\W//;
1067	2					4	$col_name =~ s/\W$//;
1068	2					3	$name .= '_' . $col_name;
1069							}
1070	1					1	$name .= '_fkey' . $quote_char;
1071							}
1072
1073	3					6	$self->{struct}->{table_defs}->{$name}->{type} = 'FOREIGN';
1074	3					4	$self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols;
1075	3					6	$self->{struct}->{table_defs}->{$name}->{referenced_table} = $referenced_table;
1076	3					3	$self->{struct}->{table_defs}->{$name}->{referenced_cols} = \@referenced_cols;
1077	3					4	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					7	my ( $name, $local_cols ) = ( $1, $2 );
1088	3					6	my @local_cols = $self->replace_quoted($local_cols);
1089	3	100				8	if ( defined $name )
1090							{
1091	2					5	$name = $self->replace_quoted_ids($name);
1092							}
1093							else
1094							{
1095	1					2	$name = $table_name;
1096	1	50				6	if ( $name =~ s/(\W)$// )
1097							{
1098	0					0	$name .= '_pkey' . $1;
1099							}
1100							else
1101							{
1102	1					2	$name .= '_pkey';
1103							}
1104							}
1105	3					8	$self->{struct}->{table_defs}->{$name}->{type} = 'PRIMARY';
1106	3					5	$self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols;
1107	3					4	next;
1108							}
1109
1110							# it seems, perl 5.6 isn't greedy enough .. let's help a bit
1111	133					124	my ($data_types_regex) = join( '\|', sort { length($b) <=> length($a) } keys %{ $self->{opts}->{valid_data_types} } );
	12843					8408
	133					826
1112	133					884	$data_types_regex =~ s/ /\\ /g; # backslash spaces to allow the /x modifier below
1113	133					2292	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				284	return $self->do_err("Column definition is missing a data type!") unless ($type);
1121	133	50				224	return undef unless ( $self->IDENTIFIER($name) );
1122
1123	133					252	$name = $self->replace_quoted_ids($name);
1124
1125	133					267	my @possible_constraints = ('PRIMARY KEY', 'NOT NULL', 'UNIQUE');
1126
1127	133					167	for my $constraint (@possible_constraints)
1128							{
1129	399					1834	my $count = $suffix =~ s/$constraint//gi;
1130	399	100				665	next if $count == 0;
1131
1132	10	50				16	return $self->do_err(qq~Duplicate column constraint: '$constraint'!~)
1133							if $count > 1;
1134
1135	10	50	66			22	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					9	push @{ $self->{struct}->{table_defs}->{columns}->{$name}->{constraints} }, $constraint;
	10					29
1139							}
1140
1141	133					132	$suffix =~ s/^\s+//;
1142	133					116	$suffix =~ s/\s+$//;
1143
1144	133	50				226	return $self->do_err("Unknown column constraint: '$suffix'!") unless ($suffix eq '');
1145
1146	133					145	$type = uc $type;
1147	133					96	my $length;
1148	133	100				346	if ( $type =~ m/(.+)$(.+)$/ )
1149							{
1150	20					37	$type = $1;
1151	20					49	$length = $2;
1152							}
1153	133	100				270	if ( !$self->{opts}->{valid_data_types}->{$type} )
1154							{
1155	2					9	return $self->do_err("'$type' is not a recognized data type!");
1156							}
1157	131					353	$self->{struct}->{table_defs}->{columns}->{$name}->{data_type} = $type;
1158	131					176	$self->{struct}->{table_defs}->{columns}->{$name}->{data_length} = $length;
1159							push(
1160	131					113	@{ $self->{struct}->{column_defs} },
	131					465
1161							{
1162							type => 'column',
1163							value => $name,
1164							fullorg => $name,
1165							}
1166							);
1167
1168	131					146	my $tmpname = $name;
1169	131	100				326	$tmpname = lc $tmpname unless ( $tmpname =~ m/^(?:\p{Word}+\.)?"/ );
1170	131	50				467	return $self->do_err("Duplicate column names!") if $is_col_name{$tmpname}++;
1171
1172							}
1173	59					174	$self->{struct}->{table_names} = [$table_name];
1174	59					161	return 1;
1175							}
1176
1177							###############
1178							# SQL SUBRULES
1179							###############
1180
1181							sub SET_CLAUSE_LIST
1182							{
1183	10			10	0	16	my ( $self, $set_string ) = @_;
1184	10					43	my @sets = split( /,/, $set_string );
1185	10					9	my ( @cols, @vals );
1186	10					21	for my $set (@sets)
1187							{
1188	16					39	my ( $col, $val ) = split( m/ = /, $set );
1189	16	100	66			68	return $self->do_err('Incomplete SET clause!') unless ( defined($col) && defined($val) );
1190	15					18	push( @cols, $col );
1191	15					22	push( @vals, $val );
1192							}
1193							return undef
1194	9	50				40	unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST( join ',', @cols ) );
1195	9	50				33	return undef unless ( $self->LITERAL_LIST( join ',', @vals ) );
1196	9					31	return 1;
1197							}
1198
1199							sub SET_QUANTIFIER
1200							{
1201	0			0	0	0	my ( $self, $str ) = @_;
1202	0	0				0	if ( $str =~ /^(DISTINCT\|ALL)\s+(.*)$/si )
1203							{
1204	0					0	$self->{struct}->{set_quantifier} = uc $1;
1205	0					0	$str = $2;
1206							}
1207	0					0	return $str;
1208							}
1209
1210							#
1211							# DAA v1.11
1212							# modify to transform \|\| strings into
1213							# CONCAT(); note that we
1214							# only xform the topmost expressions;
1215							# if a concat is contained within a subfunction,
1216							# it should get handled by ROW_VALUE()
1217							#
1218							sub transform_concat
1219							{
1220	1			1	1	1	my ( $obj, $colstr ) = @_;
1221
1222	1					2	pos($colstr) = 0;
1223	1					3	my $parens = 0;
1224	1					1	my $spos = 0;
1225	1					2	my @concats = ();
1226	1	50				4	my $alias = ( $colstr =~ s/^(.+)(\s+AS\s+\S+)$/$1/ ) ? $2 : '';
1227
1228	1					4	while ( $colstr =~ /\G.*?([\\|])/gcs )
1229							{
1230	10	100	33			28	if ( $1 eq '(' )
		100
		50
1231							{
1232	3					7	$parens++;
1233							}
1234							elsif ( $1 eq ')' )
1235							{
1236	3					6	$parens--;
1237							}
1238							elsif (( !$parens )
1239							&& ( substr( $colstr, $-[1] + 1, 1 ) eq '\|' ) )
1240							{
1241
1242							#
1243							# its a concat outside of parens, push prior string on stack
1244							#
1245	0					0	push @concats, substr( $colstr, $spos, $-[1] - $spos );
1246	0					0	$spos = $+[1] + 1;
1247	0					0	pos($colstr) = $spos;
1248							}
1249							}
1250
1251							#
1252							# no concats, return original
1253							#
1254	1	50				5	return $colstr unless scalar @concats;
1255
1256							#
1257							# don't forget the last one!
1258							#
1259	0					0	push @concats, substr( $colstr, $spos );
1260	0					0	return 'CONCAT(' . join( ', ', @concats ) . ")$alias";
1261							}
1262
1263							#
1264							# DAA v1.10
1265							# improved column list extraction
1266							# original doesn't seem to handle
1267							# commas within function argument lists
1268							#
1269							# DAA v1.11
1270							# modify to transform \|\| strings into
1271							# CONCAT()
1272							#
1273							sub extract_column_list
1274							{
1275	315			315	1	295	my ( $self, $colstr ) = @_;
1276
1277	315					330	my @collist = ();
1278	315					615	pos($colstr) = 0;
1279	315					440	my $parens = 0;
1280	315					243	my $spos = 0;
1281	315					1092	while ( $colstr =~ m/\G.*?([,])/gcs )
1282							{
1283	711	100				1577	if ( $1 eq '(' )
		100
		100
1284							{
1285	242					525	$parens++;
1286							}
1287							elsif ( $1 eq ')' )
1288							{
1289	239					392	$parens--;
1290							}
1291							elsif ( !$parens )
1292							{ # its a comma outside of parens
1293	137					400	push( @collist, substr( $colstr, $spos, $-[1] - $spos ) );
1294	137					255	$collist[-1] =~ s/^\s+//;
1295	137					196	$collist[-1] =~ s/\s+$//;
1296	137	50				213	return $self->do_err('Bad column list!') if ( $collist[-1] eq '' );
1297	137					493	$spos = $+[1];
1298							}
1299							}
1300	315	100				441	return $self->do_err('Unbalanced parentheses!') if ($parens);
1301
1302							# don't forget the last one!
1303	312					518	push( @collist, substr( $colstr, $spos ) );
1304	312					387	$collist[-1] =~ s/^\s+//;
1305	312					450	$collist[-1] =~ s/\s+$//;
1306	312	50				466	return $self->do_err('Bad column list!') if ( $collist[-1] eq '' );
1307
1308							# scan for and convert string concats to CONCAT()
1309	312					611	foreach ( 0 .. $#collist )
1310							{
1311	449	100				904	$collist[$_] = $self->transform_concat( $collist[$_] ) if ( $collist[$_] =~ m/\\|\\|/ );
1312							}
1313
1314	312					783	return @collist;
1315							}
1316
1317							sub SELECT_LIST
1318							{
1319	547			547	0	539	my ( $self, $col_str ) = @_;
1320	547	100				1584	if ( $col_str =~ m/^\s\\s*$/ )
1321							{
1322							$self->{struct}->{column_defs} = [
1323							{
1324	232					822	type => 'column',
1325							value => '*'
1326							}
1327							];
1328	232					435	$self->{struct}->{column_aliases} = {};
1329
1330	232					652	return 1;
1331							}
1332	315					484	my @col_list = $self->extract_column_list($col_str);
1333	315	100				551	return undef unless ( scalar(@col_list) );
1334
1335	312					268	my ( @newcols, %aliases );
1336	312					347	for my $col (@col_list)
1337							{
1338							# DAA:
1339							# need better alias test here, since AS is a common
1340							# keyword that might be used in a function
1341	445	100				1778	my ( $fld, $alias ) =
1342							( $col =~ m/^(.+?)\s+(?:AS\s+)?([A-Z]\p{Word}*\|\?QI\d+\?)$/i )
1343							? ( $1, $2 )
1344							: ( $col, undef );
1345	445					405	$col = $fld;
1346	445	100				600	if ( $col =~ m/^(\S+)\.\*$/ )
1347							{
1348	2					3	my $table = $1;
1349	2	50				5	if ( defined($alias) )
1350							{
1351	0					0	return $self->do_err("'$table.*' cannot be aliased");
1352							}
1353							$table = $self->{tmp}->{is_table_alias}->{$table}
1354	2	50				6	if ( $self->{tmp}->{is_table_alias}->{$table} );
1355							$table = $self->{tmp}->{is_table_alias}->{"\L$table"}
1356	2	50				5	if ( $self->{tmp}->{is_table_alias}->{"\L$table"} );
1357	2	50				3	return undef unless ( $self->TABLE_NAME($table) );
1358	2					3	$table = $self->replace_quoted_ids($table);
1359	2					8	push(
1360							@newcols,
1361							{
1362							type => 'column',
1363							value => "$table.*",
1364							}
1365							);
1366							}
1367							else
1368							{
1369	443					320	my $newcol;
1370	443					719	$newcol = $self->SET_FUNCTION_SPEC($col);
1371	443	100				856	return if ( $self->{struct}->{errstr} );
1372	440		66			1034	$newcol \|\|= $self->ROW_VALUE($col);
1373	440	100				854	return if ( $self->{struct}->{errstr} );
1374	439	50				1058	return $self->do_err("Invalid SELECT entry '$col'")
1375							unless ( defined( _HASH($newcol) ) );
1376
1377							# FIXME this might be better done later and only if not 2 functions with the same name are selected
1378	439	100	100			1772	if ( !defined($alias)
			66
1379							&& ( ( 'function' eq $newcol->{type} ) \|\| ( 'setfunc' eq $newcol->{type} ) ) )
1380							{
1381	220					252	$alias = $newcol->{name};
1382							}
1383
1384	439	100				604	if ( defined($alias) )
1385							{
1386	236					395	$alias = $self->replace_quoted_ids($alias);
1387	236					317	$newcol->{alias} = $alias;
1388	236					423	$aliases{ $newcol->{fullorg} } = $alias;
1389	236					387	$self->{struct}->{ORG_NAME}->{ $newcol->{fullorg} } = $alias;
1390	236					424	$self->{struct}->{ALIASES}->{$alias} = $newcol->{fullorg};
1391							}
1392	439					841	push( @newcols, $newcol );
1393							}
1394							}
1395	308					559	$self->{struct}->{column_aliases} = \%aliases;
1396	308					430	$self->{struct}->{column_defs} = \@newcols;
1397	308					1023	return 1;
1398							}
1399
1400							sub SET_FUNCTION_SPEC
1401							{
1402	443			443	0	419	my ( $self, $col_str ) = @_;
1403
1404	443	100				773	if ( $col_str =~ m/^(COUNT\|AVG\|SUM\|MAX\|MIN) $(.)$\s$/i )
1405							{
1406	34					58	my $set_function_name = uc $1;
1407	34					47	my $set_function_arg_str = $2;
1408	34					35	my $distinct = 'ALL';
1409	34	100				99	if ( $set_function_arg_str =~ s/(DISTINCT\|ALL) (.+)$/$2/i )
1410							{
1411	5					8	$distinct = uc $1;
1412							}
1413	34		100			94	my $count_star = ( $set_function_name eq 'COUNT' ) && ( $set_function_arg_str eq '*' );
1414
1415	34					29	my $set_function_arg;
1416	34	100				50	if ($count_star)
1417							{
1418	8	100				27	return $self->do_err("Keyword DISTINCT is not allowed for COUNT(*)")
1419							if ( 'DISTINCT' eq $distinct );
1420	7					24	$set_function_arg = {
1421							type => 'column',
1422							value => '*'
1423							};
1424							}
1425							else
1426							{
1427	26					48	$set_function_arg = $self->ROW_VALUE($set_function_arg_str);
1428	26	50				65	return if ( $self->{struct}->{errstr} );
1429	26	50				77	return unless ( defined( _HASH($set_function_arg) ) );
1430							}
1431
1432	33					63	$self->{struct}->{has_set_functions} = 1;
1433
1434	33					130	my $value = {
1435							name => $set_function_name,
1436							arg => $set_function_arg,
1437							argstr => lc($set_function_arg_str),
1438							distinct => $distinct,
1439							type => 'setfunc',
1440							fullorg => $col_str,
1441							};
1442	33					57	return $value;
1443							}
1444							else
1445							{
1446	409					553	return undef;
1447							}
1448							}
1449
1450							sub LIMIT_CLAUSE
1451							{
1452	9			9	0	15	my ( $self, $limit_clause ) = @_;
1453
1454							# $limit_clause = trim($limit_clause);
1455	9					17	$limit_clause =~ s/^\s+//;
1456	9					15	$limit_clause =~ s/\s+$//;
1457
1458	9	50				23	return 1 if !$limit_clause;
1459	9					9	my $offset;
1460							my $limit;
1461	0					0	my $junk;
1462	9					37	($offset, $limit, $junk ) = split /,\|OFFSET/i, $limit_clause;
1463	9	100				24	if ($limit_clause =~ m/(\d+)\s+OFFSET\s+(\d+)/) {
1464	1					2	$limit = $1;
1465	1					1	$offset = $2;
1466							} else {
1467	8					19	( $offset, $limit, $junk ) = split /,/i, $limit_clause;
1468							}
1469	9	50	66			108	return $self->do_err('Bad limit clause!:'.$limit_clause)
			33
			33
			33
1470							if ( defined $limit and $limit =~ /[^\d]/ )
1471							or ( defined $offset and $offset =~ /[^\d]/ )
1472							or defined $junk;
1473	9	100	66			40	if ( defined $offset and !defined $limit )
1474							{
1475	2					3	$limit = $offset;
1476	2					2	undef $offset;
1477							}
1478							$self->{struct}->{limit_clause} = {
1479	9					32	limit => $limit,
1480							offset => $offset,
1481							};
1482	9					21	return 1;
1483							}
1484
1485							sub SORT_SPEC_LIST
1486							{
1487	20			20	0	129	my ( $self, $order_clause ) = @_;
1488	20	50				47	return 1 if !$order_clause;
1489	20					25	my @ocols;
1490	20					78	my @order_columns = split ',', $order_clause;
1491	20					43	for my $col (@order_columns)
1492							{
1493	26					24	my $newcol;
1494							my $newarg;
1495	26	100				157	if ( $col =~ /\s*(\S+)\s+(ASC\|DESC)/si )
		50
1496							{
1497	9					18	$newcol = $1;
1498	9					17	$newarg = uc $2;
1499							}
1500							elsif ( $col =~ /^\s(\S+)\s$/si )
1501							{
1502	17					33	$newcol = $1;
1503	17					20	$newarg = 'ASC';
1504							}
1505							else
1506							{
1507	0					0	return $self->do_err('Junk after column name in ORDER BY clause!');
1508							}
1509	26	50				58	$newcol = $self->COLUMN_NAME($newcol) or return;
1510	26	100				69	if ( $newcol =~ /^(.+)\..+$/s )
1511							{
1512	3					4	my $table = $1;
1513	3					7	$self->_verify_tablename( $table, "ORDER BY" );
1514							}
1515	26					76	push( @ocols, { $newcol => $newarg } );
1516							}
1517	20					34	$self->{struct}->{sort_spec_list} = \@ocols;
1518	20					56	return 1;
1519							}
1520
1521							sub SEARCH_CONDITION
1522							{
1523	231			231	0	262	my ( $self, $str ) = @_;
1524	231					306	$str =~ s/^\s*WHERE (.+)/$1/;
1525	231					327	$str =~ s/^\s+//;
1526	231					440	$str =~ s/\s+$//;
1527	231	50				332	return $self->do_err("Couldn't find WHERE clause!") unless $str;
1528
1529							#
1530							# DAA
1531							# make these OO so subclasses can override them
1532							#
1533	231					368	$str = $self->repl_btwin($str);
1534
1535							#
1536							# DAA
1537							# add another abstract method so subclasses
1538							# can inject their own syntax transforms
1539							#
1540	231					401	$str = $self->transform_syntax($str);
1541
1542	231					291	my $open_parens = $str =~ tr/\(//;
1543	231					204	my $close_parens = $str =~ tr/\)//;
1544	231	50				386	if ( $open_parens != $close_parens )
1545							{
1546	0					0	return $self->do_err("Mismatched parentheses in WHERE clause!");
1547							}
1548	231					378	$str = nongroup_numeric( $self->nongroup_string($str) );
1549	231	100				605	my $pred =
1550							$open_parens
1551							? $self->parens_search( $str, [] )
1552							: $self->non_parens_search( $str, [] );
1553	229	50				391	return $self->do_err("Couldn't find predicate!") unless $pred;
1554	229					290	$self->{struct}->{where_clause} = $pred;
1555	229					427	return 1;
1556							}
1557
1558							############################################################
1559							# UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE
1560							############################################################
1561
1562							sub repl_btwin
1563							{
1564	231			231	1	239	my ( $self, $str ) = @_; # DAA make OO for subclassing
1565	231					179	my @lids;
1566
1567	231					235	my $i = -1;
1568	231					746	while ( $str =~ m/\G.*(?:IN\|BETWEEN)\s+\(/g )
1569							{
1570	32					46	my $start = pos($str) - 1;
1571	32					29	my $lparens = 1;
1572	32					29	my $rparens = 0;
1573	32					106	while ( $str =~ m/\G.*?([])/gcs )
1574							{
1575	36	100				78	++$lparens if ( '(' eq $1 );
1576	36	100				63	++$rparens if ( ')' eq $1 );
1577	36	100				70	last if ( $lparens == $rparens );
1578							}
1579	32					35	my $now = pos($str);
1580	32					25	++$i;
1581	32					46	my $subst = "?LI$i?";
1582	32					72	my $term = substr( $str, $start, $now - $start, $subst );
1583	32					47	$term = substr( $term, 1, length($term) - 2 );
1584	32					41	push( @lids, $term );
1585	32					111	pos($str) = $start + length($subst);
1586							}
1587
1588	231					298	$self->{struct}->{list_ids} = \@lids;
1589	231					363	return $str;
1590							}
1591
1592							# groups clauses by nested parens
1593							#
1594							# DAA
1595							# rewrite to correct paren scan
1596							# and optimize code, and remove
1597							# recursion
1598							#
1599							sub parens_search
1600							{
1601	135			135	1	141	my ( $self, $str, $predicates ) = @_;
1602	135					111	my $index = scalar( @{$predicates} );
	135					143
1603
1604							# to handle WHERE (a=b) AND (c=d)
1605							# but needs escape space to not foul up AND/OR
1606
1607							# locate all open parens
1608							# locate all close parens
1609							# apply non_paren_search to contents of
1610							# inner parens
1611
1612	135					131	my $lparens = ( $str =~ tr/\(// );
1613	135					101	my $rparens = ( $str =~ tr/\)// );
1614	135	0				221	return $self->do_err( 'Unmatched ' . ( ( $lparens > $rparens ) ? 'left' : 'right' ) . " parentheses in '$str'!" )
		50
1615							unless ( $lparens == $rparens );
1616
1617	135	100				282	return $self->non_parens_search( $str, $predicates )
1618							unless $lparens;
1619
1620	8					15	my @lparens = ();
1621	8					27	while ( $str =~ m/\G.*?([])/gcs )
1622							{
1623	20	100				73	push( @lparens, $-[1] ), next
1624							if ( $1 eq '(' );
1625
1626							#
1627							# got a close paren, so pop the position of matching
1628							# left paren and extract the expression, removing the
1629							# parens
1630							#
1631	10					13	my $pos = pop @lparens;
1632	10					22	my $predlen = $+[1] - $pos;
1633	10					22	my $pred = substr( $str, $pos + 1, $predlen - 2 );
1634
1635							#
1636							# note that this will pass thru any prior ^$index^ xlation,
1637							# so we don't need to recurse to recover the predicate
1638							#
1639	10	100				63	substr( $str, $pos, $predlen ) = $pred, pos($str) = $pos + length($pred), next
1640							unless ( $pred =~ / (AND\|OR) /i );
1641
1642							#
1643							# handle AND/OR
1644							#
1645	3					9	push( @$predicates, substr( $str, $pos + 1, $predlen - 2 ) );
1646	3					7	my $replacement = "^$#$predicates^";
1647	3					8	substr( $str, $pos, $predlen ) = $replacement;
1648	3					11	pos($str) = $pos + length($replacement);
1649							}
1650
1651	8					20	return $self->non_parens_search( $str, $predicates );
1652							}
1653
1654							# creates predicates from clauses that either have no parens
1655							# or ANDs or have been previously grouped by parens and ANDs
1656							#
1657							# DAA
1658							# rewrite to fix paren scanning
1659							#
1660							sub non_parens_search
1661							{
1662	311			311	1	308	my ( $self, $str, $predicates ) = @_;
1663	311					234	my $neg = 0;
1664	311					293	my $nots = {};
1665
1666	311	50				610	$neg = 1, $nots = { pred => 1 }
1667							if ( $str =~ s/^NOT (\^.+)$/$1/i );
1668
1669	311					259	my ( $pred1, $pred2, $op );
1670	311					270	my $and_preds = [];
1671	311					438	( $str, $and_preds ) = group_ands($str);
1672	311	50				558	$str = $and_preds->[$1]
1673							if $str =~ /^\s~(\d+)~\s$/;
1674
1675	311	100				491	return $self->non_parens_search( $$predicates[$1], $predicates )
1676							if ( $str =~ /^\s\^(\d+)\^\s$/ );
1677
1678	309	100				1256	if ( $str =~ /\G(.?)\s+(AND\|OR)\s+(.)$/igcs )
1679							{
1680	39					113	( $pred1, $op, $pred2 ) = ( $1, $2, $3 );
1681
1682	39	100				71	if ( $pred1 =~ /^\s\^(\d+)\^\s$/ )
1683							{
1684	1					4	$pred1 = $self->non_parens_search( $$predicates[$1], $predicates );
1685							}
1686							else
1687							{
1688	38					62	$pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
1689	38					99	$pred1 = $self->non_parens_search( $pred1, $predicates );
1690							}
1691
1692							#
1693							# handle pred2 as a full predicate
1694							#
1695	39					61	$pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
1696	39					72	$pred2 = $self->non_parens_search( $pred2, $predicates );
1697
1698							return {
1699	39					174	neg => $neg,
1700							nots => $nots,
1701							arg1 => $pred1,
1702							op => uc $op,
1703							arg2 => $pred2,
1704							};
1705							}
1706
1707							#
1708							# terminal predicate
1709							# need to check for singleton functions here
1710							#
1711	270					232	my $xstr = $str;
1712	270					191	my ( $k, $v );
1713	270	100				657	if ( $str =~ /^\s([A-Z]\p{Word})\s*\[/gcs )
1714							{
1715
1716							#
1717							# we've got a function, check if its a singleton
1718							#
1719	120					94	my $parens = 1;
1720	120					163	my $spos = $-[1];
1721	120					114	my $epos = 0;
1722	120	100	66			841	$epos = $-[1], $parens += ( $1 eq '[' ) ? 1 : -1 while ( ( $parens > 0 ) && ( $str =~ /\G.*?([\[\]])/gcs ) );
1723	120					189	$k = substr( $str, $spos, $epos - $spos + 1 );
1724	120					201	$k =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
1725
1726							#
1727							# for now we assume our parens are balanced
1728							# now look for a predicate operator and a right operand
1729							#
1730	120	100				436	$v = $1, $v =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g
1731							if ( $str =~ /\G\s+\S+\s(.+)\s$/gcs );
1732							}
1733							else
1734							{
1735	150					283	$xstr =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
1736	150					566	( $k, $v ) = $xstr =~ /^(\S+?)\s+\S+\s(.+)\s$/;
1737							}
1738	270	50				461	push @{ $self->{struct}{where_cols}{$k} }, $v
	270					832
1739							if defined $k;
1740	270					468	return $self->PREDICATE($str);
1741							}
1742
1743							# groups AND clauses that aren't already grouped by parens
1744							#
1745							sub group_ands
1746							{
1747	315			315	1	278	my $str = shift;
1748	315		100			801	my $and_preds = shift \|\| [];
1749	315	100	100			1109	return ( $str, $and_preds )
1750							unless $str =~ / AND / and $str =~ / OR /;
1751
1752	4	50				16	return $str, $and_preds
1753							unless ( $str =~ /^(.?) AND (.)$/i );
1754
1755	4					13	my ( $front, $back ) = ( $1, $2 );
1756	4					5	my $index = scalar @$and_preds;
1757	4	50				13	$front = $1
1758							if ( $front =~ /^.* OR (.*)$/i );
1759
1760	4	50				19	$back = $1
1761							if ( $back =~ /^(.?) (OR\|AND) .$/i );
1762
1763	4					8	my $newpred = "$front AND $back";
1764	4					5	push @$and_preds, $newpred;
1765	4					41	$str =~ s/\Q$newpred/~$index~/i;
1766	4					11	return group_ands( $str, $and_preds );
1767							}
1768
1769							# replaces string function parens with square brackets
1770							# e.g TRIM (foo) -> TRIM[foo]
1771							#
1772							# DAA update to support UDFs
1773							# and remove recursion
1774							#
1775							sub nongroup_string
1776							{
1777	231			231	1	228	my ( $self, $str ) = @_;
1778
1779							#
1780							# add in any user defined functions
1781							#
1782	231					362	my $f = join( '\|', FUNCTION_NAMES, $self->_udf_function_names );
1783
1784							#
1785							# we need a scan here to permit arbitrarily nested paren
1786							# arguments to functions
1787							#
1788	231					222	my $parens = 0;
1789	231					165	my $pos;
1790	231					237	my @lparens = ();
1791	231					6581	while ( $str =~ /\G.?((\b($f)\s$)\|[\($])/igcs )
1792							{
1793	298	100				585	if ( $1 eq ')' )
		100
1794							{
1795							#
1796							# close paren, see if any pending function open
1797							# paren matches it
1798							#
1799	149					112	--$parens;
1800	149	100	66			1517	$pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ']', pos($str) = $pos, pop(@lparens)
1801							if ( @lparens && ( $lparens[-1] == $parens ) );
1802							}
1803							elsif ( $1 eq '(' )
1804							{
1805
1806							#
1807							# just an open paren, count it and go on
1808							#
1809	15					101	++$parens;
1810							}
1811							else
1812							{
1813
1814							#
1815							# new function definition, capture its open paren
1816							# also uppercase the function name
1817							#
1818	134					226	$pos = $+[0];
1819	134					447	substr( $str, $-[3], length($3) ) = uc $3;
1820	134					224	substr( $str, $+[0] - 1, 1 ) = '[';
1821	134					175	pos($str) = $pos;
1822	134					143	push @lparens, $parens;
1823	134					805	++$parens;
1824							}
1825							}
1826
1827							# return $self->do_err('Unmatched ' .
1828							# (($parens > 0) ? 'left' : 'right') . ' parentheses!')
1829							# if $parens;
1830							#
1831							# DAA
1832							# remove scoped recursion
1833							#
1834							# return ( $str =~ /($f)\s*\(/i ) ?
1835							# nongroup_string($str) : $str;
1836	231					594	return $str;
1837							}
1838
1839							# replaces math parens with square brackets
1840							# e.g (4-(6+7)9) -> MATH[4-MATH[6+7]9]
1841							#
1842							sub nongroup_numeric
1843							{
1844	233			233	1	281	my $str = $_[0];
1845	233					208	my $has_op;
1846
1847							#
1848							# DAA
1849							# optimize regex
1850							#
1851	233	100				480	if ( $str =~ m/$([\p{Word} \*\/\+\-\[\]\?]+)$/ )
1852							{
1853	7					11	my $match = $1;
1854	7	100				29	if ( $match !~ m/(LIKE \|IS\|BETWEEN\|IN)/i )
1855							{
1856	5					8	my $re = quotemeta($match);
1857	5					69	$str =~ s/$$re$/MATH\[$match\]/;
1858							}
1859							else
1860							{
1861	2					3	$has_op++;
1862							}
1863							}
1864
1865							#
1866							# DAA
1867							# remove scoped recursion
1868							#
1869	233	100	100			925	return ( !$has_op and $str =~ /$([\p{Word} \*\/\+\-\[\]\?]+)$/ )
1870							? nongroup_numeric($str)
1871							: $str;
1872							}
1873							############################################################
1874
1875							#########################################################
1876							# LITERAL_LIST ::= [,]
1877							#########################################################
1878							sub LITERAL_LIST
1879							{
1880	187			187	0	387	my ( $self, $str ) = @_;
1881	187					474	my @tokens = split /,/, $str;
1882	187					186	my @values;
1883	187					251	for my $tok (@tokens)
1884							{
1885	602					921	my $val = $self->ROW_VALUE($tok);
1886	602	50				972	return $self->do_err(qq('$tok' is not a valid value or is not quoted!))
1887							unless $val;
1888	602					830	push @values, $val;
1889							}
1890	187					190	push( @{ $self->{struct}->{values} }, \@values );
	187					432
1891	187					497	return 1;
1892							}
1893
1894							#############################################################################
1895							# LITERAL ::= \| \| \| NULL/TRUE/FALSE
1896							#############################################################################
1897							sub LITERAL
1898							{
1899	1868			1868	0	1675	my ( $self, $str ) = @_;
1900
1901							#
1902							# DAA
1903							# strip parens (if any)
1904							#
1905	1868					2787	$str = $1 while ( $str =~ m/^\s$\s(.+)\s$\s$/ );
1906
1907	1868	100				2572	return 'null' if $str =~ m/^NULL$/i; # NULL
1908	1841	100				2662	return 'boolean' if $str =~ m/^(?:TRUE\|FALSE)$/i; # TRUE/FALSE
1909
1910							# return 'empty_string' if $str =~ /^~E~$/i; # NULL
1911	1828	100				2615	if ( $str eq '?' )
1912							{
1913	36					86	$self->{struct}->{num_placeholders}++;
1914	36					83	return 'placeholder';
1915							}
1916
1917							# return 'placeholder' if $str eq '?'; # placeholder question mark
1918	1792	100				2618	return 'string' if $str =~ m/^'.*'$/s; # quoted string
1919							# return 'number' if $str =~ m/^[+-]?(?=\d\|\.\d)\d(\.\d)?([Ee]([+-]?\d+))?$/; # number
1920	1791	100				5366	return 'number' if ( looks_like_number($str) ); # number
1921
1922	1096					1756	return undef;
1923							}
1924							###################################################################
1925							# PREDICATE
1926							###################################################################
1927							sub PREDICATE
1928							{
1929	270			270	0	254	my ( $self, $str ) = @_;
1930
1931	270					187	my ( $arg1, $op, $arg2, $opexp );
1932
1933							$opexp = $self->{opts}{valid_comparison_NOT_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1934	270	50				1737	if $self->{opts}{valid_comparison_NOT_ops_regex};
1935
1936							$opexp = $self->{opts}{valid_comparison_twochar_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1937							if ( !defined($op)
1938	270	50	66			1585	&& $self->{opts}{valid_comparison_twochar_ops_regex} );
1939
1940							$opexp = $self->{opts}{valid_comparison_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i
1941	270	50	66			2104	if ( !defined($op) && $self->{opts}{valid_comparison_ops_regex} );
1942
1943							#
1944							### USER-DEFINED PREDICATE
1945							#
1946	269	50	66			1155	unless ( defined $arg1 && defined $op && defined $arg2 )
			66
1947							{
1948	57					45	$arg1 = $str;
1949	57					44	$op = 'USER_DEFINED';
1950	57					37	$arg2 = '';
1951							}
1952
1953	269					284	$op = uc $op;
1954
1955							# my $uname = $self->is_func($arg1);
1956							# if (!$uname) {
1957							# $arg1 =~ s/^(\S+).*$/$1/;
1958							# return $self->do_err("Bad predicate: '$arg1'!");
1959							# }
1960
1961	269					212	my $negated = 0; # boolean value showing if predicate is negated
1962	269					217	my %not; # hash showing elements modified by NOT
1963							#
1964							# e.g. "NOT bar = foo" -> %not = (arg1=>1)
1965							# "bar NOT LIKE foo" -> %not = (op=>1)
1966							# "NOT bar NOT LIKE foo" -> %not = (arg1=>1,op=>1);
1967							# "NOT bar IS NOT NULL" -> %not = (arg1=>1,op=>1);
1968							# "bar = foo" -> %not = undef;
1969							#
1970	269	100				579	$not{arg1}++
1971							if ( $arg1 =~ s/^NOT (.+)$/$1/i );
1972
1973	269	100	100			935	$not{op}++
1974							if ( $op =~ s/^(.+) NOT$/$1/i
1975							\|\| $op =~ s/^NOT (.+)$/$1/i );
1976
1977	269	100	66			559	$negated = 1 if %not and scalar keys %not == 1;
1978
1979	269	50				441	return undef unless $arg1 = $self->ROW_VALUE($arg1);
1980
1981	268	100				422	if ( $op ne 'USER_DEFINED' )
1982							{ # USER-PREDICATE;
1983	212	50				320	return undef unless $arg2 = $self->ROW_VALUE($arg2);
1984							}
1985							else
1986							{
1987
1988							# $arg2 = $self->ROW_VALUE($arg2);
1989							}
1990
1991	268	100	66			2271	if ( defined( _HASH($arg1) )
			50
			100
			50
			100
			100
1992							and defined( _HASH($arg2) )
1993							and ( ( $arg1->{type} \|\| '' ) eq 'column' )
1994							and ( ( $arg2->{type} \|\| '' ) eq 'column' )
1995							and ( $op eq '=' ) )
1996							{
1997	27					29	push( @{ $self->{struct}->{keycols} }, $arg1->{value} );
	27					72
1998	27					27	push( @{ $self->{struct}->{keycols} }, $arg2->{value} );
	27					45
1999							}
2000
2001							return {
2002	268					1432	neg => $negated,
2003							nots => \%not,
2004							arg1 => $arg1,
2005							op => $op,
2006							arg2 => $arg2,
2007							};
2008							}
2009
2010							sub _udf_function_names
2011							{
2012							$_[0]->{opts}->{_udf_function_names}
2013	2500	100		2500		4135	or return $_[0]->{opts}->{_udf_function_names} = join( "\|", map { uc $_ } keys %{ $_[0]->{opts}->{function_names} } );
	1971					1901
	18					326
2014	2482					4714	$_[0]->{opts}->{_udf_function_names};
2015							}
2016
2017							sub undo_string_funcs
2018							{
2019	2269			2269	1	1970	my ( $self, $str ) = @_;
2020	2269					2871	my $f = join( '\|', FUNCTION_NAMES, $self->_udf_function_names );
2021
2022							# eliminate recursion:
2023							# we have to scan for closing brackets, since we may
2024							# have intervening MATH elements with brackets
2025	2269					2955	my ( $brackets, $pos, @lbrackets ) = (0);
2026	2269					20159	while ( $str =~ /\G.?((\b($f)\s\[)\|[\[\]])/igcs )
2027							{
2028	278	100				484	if ( $1 eq ']' )
		100
2029							{
2030							# close paren, see if any pending function open
2031							# paren matches it
2032	139					128	$brackets--;
2033	139	100	66			1118	$pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ')', pos($str) = $pos, pop @lbrackets
2034							if ( @lbrackets && ( $lbrackets[-1] == $brackets ) );
2035							}
2036							elsif ( $1 eq '[' )
2037							{
2038							# just an open paren, count it and go on
2039	5					27	$brackets++;
2040							}
2041							else
2042							{
2043							# new function definition, capture its open paren
2044							# also uppercase the function name
2045	134					170	$pos = $+[0];
2046	134					353	substr( $str, $-[3], length($3) ) = uc $3;
2047	134					224	substr( $str, $+[0] - 1, 1 ) = '(';
2048	134					165	pos($str) = $pos;
2049	134					148	push @lbrackets, $brackets;
2050	134					963	$brackets++;
2051							}
2052							}
2053
2054	2269					3556	return $str;
2055							}
2056
2057							sub undo_math_funcs
2058							{
2059	2269			2269	1	1867	my $str = $_[0];
2060
2061							# eliminate recursion
2062	2269					3643	while ( $str =~ s/MATH\[([^\]\[]+?)\]/($1)/ )
2063							{
2064							}
2065
2066	2269					2316	return $str;
2067							}
2068
2069							#
2070							# DAA
2071							# need better nested function/parens handling
2072							#
2073							sub extract_func_args
2074							{
2075	339			339	1	317	my ( $self, $value ) = @_;
2076
2077	339					337	my @final_args = ();
2078	339					337	my ( $spos, $parens, $epos, $delim ) = ( 0, 0, 0, 0 );
2079	339					849	while ( $value =~ m/\G.*?([,])/gcs )
2080							{
2081	193					295	$epos = $+[0];
2082	193					224	$delim = $1;
2083	193	100	100			607	unless ( $parens or ( $delim ne ',' ) )
2084							{
2085	143					353	push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos - 1 ) ) );
2086	143					190	$spos = $epos;
2087	143					430	next;
2088							}
2089
2090	50	100				98	unless ( $delim eq ',' )
2091							{
2092	36	100				105	$parens += ( $delim eq '(' ) ? 1 : -1;
2093							}
2094							}
2095
2096							# don't forget the last argument
2097	339	100				527	if ( $spos != length($value) )
2098							{
2099	305					219	$epos = length($value);
2100	305					739	push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos ) ) ); # XXX
2101							}
2102
2103	339					765	return @final_args;
2104							}
2105
2106							###################################################################
2107							# ROW_VALUE ::= \|
2108							###################################################################
2109							sub ROW_VALUE
2110							{
2111	2269			2269	0	2717	my ( $self, $str ) = @_;
2112
2113	2269					3062	$str =~ s/^\s+//;
2114	2269					2587	$str =~ s/\s+$//;
2115	2269					2913	$str = $self->undo_string_funcs($str);
2116	2269					2877	$str = undo_math_funcs($str);
2117	2269					2452	my ( $orgstr, $f, $bf ) = ( $str, FUNCTION_NAMES, BAREWORD_FUNCTIONS );
2118
2119							# USER-DEFINED FUNCTION
2120	2269					1687	my ( $user_func_name, $user_func_args, $is_func );
2121
2122							# DAA
2123							# need better paren check here
2124	2269	100				5911	if ( $str =~ m/^([^\s\(]+)\s(.)\s*$/ )
2125							{
2126	2265					2693	$user_func_name = $1;
2127	2265					2493	$user_func_args = $2;
2128
2129							# convert operator-like function to parenthetical format
2130	2265	100	100			3053	if ( ( $is_func = $self->is_func($user_func_name) )
			100
2131							&& ( $user_func_args !~ m/^$.*$$/ )
2132							&& ( $is_func =~ /^(?:$bf)$/i ) )
2133							{
2134	8					32	$orgstr = $str = "$user_func_name ($user_func_args)";
2135							}
2136							}
2137							else
2138							{
2139	4					4	$user_func_name = $str;
2140	4					13	$user_func_name =~ s/^(\S+).*$/$1/;
2141	4					7	$user_func_args = '';
2142	4					8	$is_func = $self->is_func($user_func_name);
2143							}
2144
2145							# BLKB
2146							# Limiting the parens convert shortcut, so that "SELECT LOG(1), PI" works as a
2147							# two functions, and "SELECT x FROM log" works as a table
2148	2269	100	100			6171	undef $is_func if ( $is_func && $is_func !~ /^(?:$bf)$/i && $str !~ m/^\S+\s$.$\s*$/ );
			100
2149
2150	2269	100	66			4476	if ( $is_func && ( uc($is_func) !~ m/^($f)$/ ) )
2151							{
2152	339					441	my ( $name, $value ) = ( $user_func_name, '' );
2153	339	50				929	if ( $str =~ m/^(\S+)\s$(.)$\s*$/ )
2154							{
2155	339					378	$name = $1;
2156	339					356	$value = $2;
2157	339					461	$is_func = $self->is_func($name);
2158							}
2159
2160	339	50				538	if ($is_func)
2161							{
2162							#
2163							# DAA
2164							# need a better argument extractor, since it can
2165							# contain arbitrary (possibly parenthesized)
2166							# expressions/functions
2167							#
2168							# if ($value =~ /\(/ ) {
2169							# $value = $self->ROW_VALUE($value);
2170							# }
2171							# my @args = split ',',$value;
2172
2173	339					521	my @final_args = $self->extract_func_args($value);
2174	339					511	my $usr_sub = $self->{opts}->{function_names}->{$is_func};
2175	339					480	$self->{struct}->{procedure} = {};
2176	339	50				567	if ($usr_sub)
2177							{
2178	339					1100	$value = {
2179							type => 'function',
2180							name => lc $name,
2181							subname => $usr_sub,
2182							value => \@final_args,
2183							fullorg => $orgstr,
2184							};
2185
2186	339					1120	return $value;
2187							}
2188							}
2189							}
2190
2191	1930					1653	my $type;
2192							# MATH
2193							#
2194	1930	100				3473	if ( $str =~ m/[\*\+\-\/\%]/ )
2195							{
2196	44					41	my @vals;
2197	44					40	my $i = -1;
2198	44					60	my $open_parens = $str =~ tr/\(//;
2199	44					35	my $close_parens = $str =~ tr/\)//;
2200	44	50				89	if ( $open_parens != $close_parens )
2201							{
2202	0					0	return $self->do_err("Mismatched parentheses in term '$str'!");
2203							}
2204
2205							# $str =~ s/([^\s\*\+\-\/\%\)\(]+)/push @vals,$1;++$i;"?$i?"/ge;
2206	44					137	while ( $str =~ m/\G.?([^\s\\+\-\/\%\)\(]+)/g )
2207							{
2208	72					89	my $term = $1;
2209	72					69	my $start = pos($str) - length($term);
2210	72	100				87	if ( $self->is_func($term) )
2211							{
2212	4					5	my $lparens = 0;
2213	4					3	my $rparens = 0;
2214	4					17	while ( $str =~ m/\G.*?([])/gcs )
2215							{
2216	2	50				6	++$lparens if ( '(' eq $1 );
2217	2	50				4	++$rparens if ( ')' eq $1 );
2218	2	50				8	last if ( $lparens == $rparens );
2219							}
2220	4					7	my $now = pos($str);
2221	4					6	++$i;
2222	4					14	$term = substr( $str, $start, $now - $start, "?$i?" );
2223	4					6	push( @vals, $term );
2224	4					18	pos($str) = $start + length("?$i?");
2225							}
2226							else
2227							{
2228	68					73	push( @vals, $term );
2229	68					55	++$i;
2230	68					151	substr( $str, $start, length($term), "?$i?" );
2231	68					254	pos($str) = $start + length("?$i?");
2232							}
2233							}
2234
2235	44					38	my @newvalues;
2236	44					55	foreach my $val (@vals)
2237							{
2238	72					103	my $newval = $self->ROW_VALUE($val);
2239	72	50	66			416	if ( $newval && $newval->{type} !~ m/number\|column\|placeholder\|function/ )
2240							{
2241	0					0	return $self->do_err(qq[String '$val' not allowed in Numeric expression!]);
2242							}
2243	72					121	push( @newvalues, $newval );
2244							}
2245
2246							return {
2247	44					205	type => 'function',
2248							name => 'numeric_exp',
2249							str => $str,
2250							value => \@newvalues,
2251							fullorg => $orgstr,
2252							};
2253							}
2254
2255							# SUBSTRING (value FROM start [FOR length])
2256							#
2257	1886	100				2549	if ( $str =~ m/^SUBSTRING $(.+?) FROM (.+)$\s*$/i )
2258							{
2259	4					6	my $name = 'SUBSTRING';
2260	4					8	my $start = $2;
2261	4					7	my $value = $self->ROW_VALUE($1);
2262	4					4	my $length;
2263	4	100				18	if ( $start =~ /^(.+?) FOR (.+)$/i )
2264							{
2265	3					4	$start = $1;
2266	3					7	$length = $2;
2267	3					7	$length = $self->ROW_VALUE($length);
2268							}
2269	4					9	$start = $self->ROW_VALUE($start);
2270	4					9	$str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2271	4	50	33			25	if ( ( $start->{type} eq 'string' )
			33
2272							or ( $start->{length} && ( $start->{length}->{type} eq 'string' ) ) )
2273							{
2274	0					0	return $self->do_err("Can't use a string as a SUBSTRING position: '$str'!");
2275							}
2276	4	50				9	return undef unless ($value);
2277							return $self->do_err("Can't use a number in SUBSTRING: '$str'!")
2278	4	50				9	if $value->{type} eq 'number';
2279							return {
2280	4					29	type => 'function',
2281							name => $name,
2282							value => [$value],
2283							start => $start,
2284							length => $length,
2285							fullorg => $orgstr,
2286							};
2287							}
2288
2289							# TRIM ( [ [TRAILING\|LEADING\|BOTH] ['char'] FROM ] value )
2290							#
2291	1882	100				2450	if ( $str =~ m/^(TRIM) $(.+)$\s*$/i )
2292							{
2293	11					20	my $name = uc $1;
2294	11					15	my $value = $2;
2295	11					9	my ( $trim_spec, $trim_char );
2296	11	100				34	if ( $value =~ m/^(.+) FROM ([^]+)$/i )
2297							{
2298	5					6	my $front = $1;
2299	5					8	$value = $2;
2300	5	50				22	if ( $front =~ m/^\s(TRAILING\|LEADING\|BOTH)(.)$/i )
2301							{
2302	5					8	$trim_spec = uc $1;
2303	5					6	$trim_char = $2;
2304	5					8	$trim_char =~ s/^\s+//;
2305	5					7	$trim_char =~ s/\s+$//;
2306	5	100				15	undef $trim_char if ( length($trim_char) == 0 );
2307							}
2308							else
2309							{
2310	0					0	$trim_char = $front;
2311	0					0	$trim_char =~ s/^\s+//;
2312	0					0	$trim_char =~ s/\s+$//;
2313							}
2314							}
2315
2316	11		100			39	$trim_char \|\|= '';
2317	11					21	$trim_char =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2318	11					40	$value = $self->ROW_VALUE($value);
2319	11	50				29	return undef unless ($value);
2320	11					32	$str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g;
2321	11	50				33	my $value_type = $value->{type} if ref $value eq 'HASH';
2322	11	50				36	$value_type = $value->[0] if ( defined( _ARRAY($value) ) );
2323	11	50	33			245	return $self->do_err("Can't use a number in TRIM: '$str'!")
2324							if ( $value_type and $value_type eq 'number' );
2325
2326							return {
2327	11					72	type => 'function',
2328							name => $name,
2329							value => [$value],
2330							trim_spec => $trim_spec,
2331							trim_char => $trim_char,
2332							fullorg => $orgstr,
2333							};
2334							}
2335
2336							# UNKNOWN FUNCTION
2337	1871	100				2633	if ( $str =~ m/^(\S+) \(/ )
2338							{
2339	2					9	return $self->do_err("Unknown function '$1'");
2340							}
2341
2342							# STRING CONCATENATION
2343							#
2344	1869	100				2583	if ( $str =~ m/\\|\\|/ )
2345							{
2346	1					5	my @vals = split( m/ \\|\\| /, $str );
2347	1					1	my @newvals;
2348	1					2	for my $val (@vals)
2349							{
2350	3					5	my $newval = $self->ROW_VALUE($val);
2351	3	50				7	return undef unless ($newval);
2352							return $self->do_err("Can't use a number in string concatenation: '$str'!")
2353	3	50				8	if ( $newval->{type} eq 'number' );
2354	3					5	push @newvals, $newval;
2355							}
2356							return {
2357	1					5	type => 'function',
2358							name => 'str_concat',
2359							value => \@newvals,
2360							fullorg => $orgstr,
2361							};
2362							}
2363
2364							# NULL, BOOLEAN, PLACEHOLDER, NUMBER
2365							#
2366	1868	100				2499	if ( $type = $self->LITERAL($str) )
2367							{
2368	772	100				1168	undef $str if ( $type eq 'null' );
2369	772	100	66			1392	$str = 1 if ( $type eq 'boolean' and $str =~ /^TRUE$/i );
2370	772	50	66			1221	$str = 0 if ( $type eq 'boolean' and $str =~ /^FALSE$/i );
2371
2372							# if ($type eq 'empty_string') {
2373							# $str = '';
2374							# $type = 'string';
2375							# }
2376	772	100	100			2303	$str = '' if ( $str and $str eq q('') );
2377							return {
2378	772					2767	type => $type,
2379							value => $str,
2380							fullorg => $orgstr,
2381							};
2382							}
2383
2384							# QUOTED STRING LITERAL
2385							#
2386	1096	100				2986	if ( $str =~ m/\?(\d+)\?/ )
		100
2387							{
2388							return {
2389							type => 'string',
2390							value => $self->{struct}->{literals}->[$1],
2391	419					2005	fullorg => $self->{struct}->{literals}->[$1],
2392							};
2393							}
2394							elsif ( $str =~ /^\?LI(\d+)\?$/ )
2395							{
2396	30					82	return $self->ROW_VALUE_LIST( $self->{struct}->{list_ids}->[$1] );
2397							}
2398
2399							# COLUMN NAME
2400							#
2401	647	100				1026	return undef unless ( $str = $self->COLUMN_NAME($str) );
2402
2403	645	100				1219	if ( $str =~ m/^(.*)\./ )
2404							{
2405	119					160	my $table_name = $1;
2406	119					175	$self->_verify_tablename( $table_name, "WHERE" );
2407							}
2408
2409							# push @{ $self->{struct}->{where_cols}},$str
2410							# unless $self->{tmp}->{where_cols}->{"$str"};
2411	645					2098	++$self->{tmp}->{where_cols}->{$str};
2412							return {
2413	645					2458	type => 'column',
2414							value => $str,
2415							fullorg => $orgstr,
2416							};
2417							}
2418
2419							#########################################################
2420							# ROW_VALUE_LIST ::= [,...]
2421							#########################################################
2422							sub ROW_VALUE_LIST
2423							{
2424	51			51	0	61	my ( $self, $row_str ) = @_;
2425	51					126	my @row_list = split ',', $row_str;
2426	51	50				93	if ( !( scalar @row_list ) )
2427							{
2428	0					0	return $self->do_err('Missing row value list!');
2429							}
2430	51					324	my @newvals;
2431							my $newval;
2432	51					70	for my $row_val (@row_list)
2433							{
2434	119					156	$row_val =~ s/^\s+//;
2435	119					118	$row_val =~ s/\s+$//;
2436
2437	119	50				167	return undef if !( $newval = $self->ROW_VALUE($row_val) );
2438	119					191	push @newvals, $newval;
2439							}
2440	51					175	return \@newvals;
2441							}
2442
2443							###############################################
2444							# COLUMN NAME ::= [.]
2445							###############################################
2446
2447							sub COLUMN_NAME
2448							{
2449	673			673	0	621	my ( $self, $str ) = @_;
2450	673					528	my ( $table_name, $col_name );
2451	673	100				1121	if ( $str =~ m/^\s*(\S+)\.(\S+)$/s )
2452							{
2453	122					260	( $table_name, $col_name ) = ( $1, $2 );
2454	122	50				238	if ( !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} )
2455							{
2456	0					0	return $self->do_err('Dialect does not support multiple tables!');
2457							}
2458	122	50				171	return undef unless ( $table_name = $self->TABLE_NAME($table_name) );
2459	122					225	$table_name = $self->replace_quoted_ids($table_name);
2460	122					194	$self->_verify_tablename($table_name);
2461							}
2462							else
2463							{
2464	551					499	$col_name = $str;
2465							}
2466
2467	673					920	$col_name =~ s/^\s+//;
2468	673					712	$col_name =~ s/\s+$//;
2469
2470	673					659	my $user_func = $col_name;
2471	673					1582	$user_func =~ s/^(\S+).*$/$1/;
2472	673	50				1373	if ( $col_name !~ m/^(TRIM\|SUBSTRING)$/i )
2473							{
2474	673	100				1564	undef $user_func unless ( $self->{opts}->{function_names}->{ uc $user_func } );
2475							}
2476	673	100				885	if ( !$user_func )
2477							{
2478	670	100	66			1578	return undef unless ( ( $col_name eq '*' ) \|\| $self->IDENTIFIER($col_name) );
2479							}
2480
2481							#
2482							# MAKE COL NAMES ALL UPPER CASE UNLESS IS DELIMITED IDENTIFIER
2483	671					652	my $orgcol = $col_name;
2484
2485	671	100				862	if ( $col_name =~ m/^\?QI(\d+)\?$/ )
2486							{
2487	10					28	$col_name = '"' . $self->{struct}->{quoted_ids}->[$1] . '"';
2488							}
2489							else
2490							{
2491							$col_name = lc $col_name
2492							unless (
2493	661	50	33			2805	( $self->{struct}->{command} eq 'CREATE' )
2494							##############################################
2495							#
2496							# JZ addition to RR's alias patch
2497							#
2498							or ( $col_name =~ m/^(?:\p{Word}+\.)?"/ )
2499							);
2500
2501							}
2502
2503							#
2504							$col_name = $self->{struct}->{column_aliases}->{$col_name}
2505	671	50				1208	if ( $self->{struct}->{column_aliases}->{$col_name} );
2506
2507							# $orgcol = $self->replace_quoted_ids($orgcol);
2508							##############################################
2509
2510	671	100				878	if ($table_name)
2511							{
2512	122					157	my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"};
2513	122	100				173	$table_name = $alias if ( defined($alias) );
2514	122	100				210	$table_name = lc $table_name unless ( $table_name =~ m/^"/ );
2515	122	50				297	$col_name = "$table_name.$col_name" if ( -1 == index( $col_name, '.' ) );
2516							}
2517	671					1384	return $col_name;
2518							}
2519
2520							#########################################################
2521							# COLUMN NAME_LIST ::= [,...]
2522							#########################################################
2523							sub COLUMN_NAME_LIST
2524							{
2525	0			0	0	0	my ( $self, $col_str ) = @_;
2526
2527	0					0	my @col_list = split( ',', $col_str );
2528	0	0				0	return $self->do_err('Missing column name list!') unless ( scalar(@col_list) );
2529
2530	0					0	my @newcols;
2531	0					0	for my $col (@col_list)
2532							{
2533	0					0	$col =~ s/^\s+//;
2534	0					0	$col =~ s/\s+$//;
2535
2536	0					0	my $newcol;
2537	0	0				0	return undef unless ( $newcol = $self->COLUMN_NAME($col) );
2538	0					0	push( @newcols, $newcol );
2539							}
2540
2541	0					0	return \@newcols;
2542							}
2543
2544							#####################################################
2545							# TABLE_NAME_LIST := [,...]
2546							#####################################################
2547							sub TABLE_NAME_LIST
2548							{
2549	386			386	0	364	my ( $self, $table_name_str ) = @_;
2550	386					553	my %aliases = ();
2551	386					320	my @tables;
2552	386					409	$table_name_str =~ s/(\?\d+\?),/$1:/g; # fudge commas in functions
2553	386					809	my @table_names = split ',', $table_name_str;
2554	386	50	66			1066	if ( scalar @table_names > 1
2555							and !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} )
2556							{
2557	0					0	return $self->do_err('Dialect does not support multiple tables!');
2558							}
2559
2560	386					410	my $bf = BAREWORD_FUNCTIONS;
2561	386					305	my %is_table_alias;
2562	386					453	for my $table_str (@table_names)
2563							{
2564	501					462	$table_str =~ s/(\?\d+\?):/$1,/g; # unfudge commas in functions
2565	501					467	$table_str =~ s/\s+\(/\(/g; # fudge spaces in functions
2566	501					380	my ( $table, $alias );
2567	501					937	my (@tstr) = split( m/\s+/, $table_str );
2568	501	100				874	if ( @tstr == 1 )
		100
		100
2569							{
2570	475					482	$table = $tstr[0];
2571							}
2572							elsif ( @tstr == 2 )
2573							{
2574	11					11	$table = $tstr[0];
2575	11					13	$alias = $tstr[1];
2576							}
2577							elsif ( @tstr == 3 )
2578							{
2579	13	50				33	return $self->do_err("Can't find alias in FROM clause!")
2580							unless ( uc( $tstr[1] ) eq 'AS' );
2581	13					16	$table = $tstr[0];
2582	13					14	$alias = $tstr[2];
2583							}
2584							else
2585							{
2586	2					6	return $self->do_err("Can't find table names in FROM clause!");
2587							}
2588
2589	499					525	$table =~ s/\(/ \(/g; # unfudge spaces in functions
2590	499					547	my $u_name = $table;
2591	499					1391	$u_name =~ s/^(\S+)\s(.$)/$1/;
2592	499					543	my $u_args = $2;
2593
2594	499	100	66			735	if ( ( $u_name = $self->is_func($u_name) )
			66
2595							&& ( $u_name =~ /^(?:$bf)$/i \|\| $table =~ /^$u_name\s*\(/i ) )
2596							{
2597	2	50				5	$u_args = " $u_args" if ($u_args);
2598	2					8	my $u_func = $self->ROW_VALUE( $u_name . $u_args );
2599	2					5	$self->{struct}->{table_func}->{$u_name} = $u_func;
2600	2					4	$self->{struct}->{temp_table} = 1;
2601	2					3	$table = $u_name;
2602							}
2603							else
2604							{
2605	497	100				718	return undef unless ( $self->TABLE_NAME($table) );
2606							}
2607
2608	494					969	$table = $self->replace_quoted_ids($table);
2609	494	100				1217	push( @tables, $table =~ m/^"/ ? $table : $table );
2610
2611	494	100				1065	if ($alias)
2612							{
2613	24	50				36	return unless ( $self->TABLE_NAME($alias) );
2614	24					38	$alias = $self->replace_quoted_ids($alias);
2615	24	50				46	if ( $alias =~ m/^"/ )
2616							{
2617	0					0	push( @{ $aliases{$table} }, $alias );
	0					0
2618	0					0	$is_table_alias{$alias} = $table;
2619							}
2620							else
2621							{
2622	24					18	push( @{ $aliases{$table} }, "\L$alias" );
	24					57
2623	24					63	$is_table_alias{"\L$alias"} = $table;
2624							}
2625							}
2626							}
2627	379					464	my %is_table_name = map { $_ => 1 } @tables;
	492					1339
2628	379					679	$self->{tmp}->{is_table_alias} = \%is_table_alias;
2629	379					458	$self->{tmp}->{is_table_name} = \%is_table_name;
2630	379					454	$self->{struct}->{table_names} = \@tables;
2631	379					402	$self->{struct}->{table_alias} = \%aliases;
2632	379	100				706	$self->{struct}->{multiple_tables} = 1 if ( @tables > 1 );
2633	379					1118	return 1;
2634							}
2635
2636							sub is_func($)
2637							{
2638	3179			3179	1	2774	my ( $self, $name ) = @_;
2639	3179					6793	$name =~ s/^(\S+).*$/$1/;
2640	3179	100				8655	return $name if ( $self->{opts}->{function_names}->{$name} );
2641	2514	100				4589	return uc $name if ( $self->{opts}->{function_names}->{ uc $name } );
2642	2482					4902	undef;
2643							}
2644
2645							#############################
2646							# TABLE_NAME :=
2647							#############################
2648							sub TABLE_NAME
2649							{
2650	913			913	0	918	my ( $self, $table_name ) = @_;
2651	913	50				1586	if ( $table_name =~ m/^(.+?)\.([^\.]+)$/ )
2652							{
2653	0					0	my $schema = $1; # ignored
2654	0					0	$table_name = $2;
2655							}
2656	913	50				2830	if ( $table_name =~ m/\s*(\S+)\s+\S+/s )
2657							{
2658	0					0	return $self->do_err("Junk after table name '$1'!");
2659							}
2660	913					979	$table_name =~ s/\s+//s;
2661	913	50				1242	if ( !$table_name )
2662							{
2663	0					0	return $self->do_err('No table name specified!');
2664							}
2665	913	100				1389	return $table_name if ( $self->IDENTIFIER($table_name) );
2666
2667							# return undef if !($self->IDENTIFIER($table_name));
2668							# return 1;
2669							}
2670
2671							sub _verify_tablename
2672							{
2673	244			244		262	my ( $self, $table_name, $location ) = @_;
2674	244	100				292	if ( defined($location) )
2675							{
2676	122					132	$location = " in $location";
2677							}
2678							else
2679							{
2680	122					120	$location = "";
2681							}
2682
2683	244	100				332	if ( $table_name =~ m/^"/ )
2684							{
2685	4	0	33			11	if ( !$self->{tmp}->{is_table_name}->{$table_name}
2686							and !$self->{tmp}->{is_table_alias}->{$table_name} )
2687							{
2688	0					0	return $self->do_err("Table '$table_name' referenced$location but not found in FROM list!");
2689							}
2690							}
2691							else
2692							{
2693	240					152	my @tblnamelist = ( keys( %{ $self->{tmp}->{is_table_name} } ), keys( %{ $self->{tmp}->{is_table_alias} } ) );
	240					479
	240					480
2694	240					428	my $tblnames = join( "\|", @tblnamelist );
2695	240	50				1828	unless ( $table_name =~ m/^(?:$tblnames)$/i )
2696							{
2697	0					0	return $self->do_err(
2698							"Table '$table_name' referenced$location but not found in FROM list (" . join( ",", @tblnamelist ) . ")!" );
2699							}
2700							}
2701
2702	244					235	return 1;
2703							}
2704
2705							###################################################################
2706							# IDENTIFIER ::= { \| _ }...
2707							#
2708							# and must not be a reserved word or over 128 chars in length
2709							###################################################################
2710							sub IDENTIFIER
2711							{
2712	1716			1716	0	1571	my ( $self, $id ) = @_;
2713	1716	100	66			5810	if ( $id =~ m/^\?QI(.+)\?$/ or $id =~ m/^\?(.+)\?$/ )
2714							{
2715	31					97	return 1;
2716							}
2717	1685	100				2315	if ( $id =~ m/^[`](.+)[`]$/ )
2718							{
2719	21	50				98	$id = $1 and return 1;
2720							}
2721	1664	50				2243	if ( $id =~ m/^(.+)\.([^\.]+)$/ )
2722							{
2723	0					0	my $schema = $1; # ignored
2724	0					0	$id = $2;
2725							}
2726	1664					3005	$id =~ s/$\|$//g;
2727	1664	50				2653	return 1 if $id =~ m/^".+?"$/s; # QUOTED IDENTIFIER
2728	1664					2218	my $err = "Bad table or column name: '$id' "; # BAD CHARS
2729	1664	100				2716	if ( $id =~ /\W/ )
2730							{
2731	4					6	$err .= "has chars not alphanumeric or underscore!";
2732	4					10	return $self->do_err($err);
2733							}
2734							# CSV requires optional start with _
2735	1660	50				5079	my $badStartRx = uc( $self->{dialect} ) eq 'ANYDATA' ? qr/^\d/ : qr/^[_\d]/;
2736	1660	50				4940	if ( $id =~ $badStartRx )
2737							{ # BAD START
2738	0					0	$err .= "starts with non-alphabetic character!";
2739	0					0	return $self->do_err($err);
2740							}
2741	1660	50				2575	if ( length $id > 128 )
2742							{ # BAD LENGTH
2743	0					0	$err .= "contains more than 128 characters!";
2744	0					0	return $self->do_err($err);
2745							}
2746	1660					1533	$id = uc $id;
2747	1660	100				3071	if ( $self->{opts}->{reserved_words}->{$id} )
2748							{ # BAD RESERVED WORDS
2749	3					6	$err .= "is a SQL reserved word!";
2750	3					9	return $self->do_err($err);
2751							}
2752	1657					5736	return 1;
2753							}
2754
2755							########################################
2756							# PRIVATE METHODS AND UTILITY FUNCTIONS
2757							########################################
2758							sub order_joins
2759							{
2760	39			39	1	47	my ( $self, $links ) = @_;
2761	39					67	for my $link (@$links)
2762							{
2763	115	100				213	if ( $link !~ /\./ )
2764							{
2765	19					53	return [];
2766							}
2767							}
2768	20					35	@$links = map { s/^(.+)\..*$/$1/; $1; } @$links;
	96					222
	96					178
2769	20					36	my @all_tables;
2770							my %relations;
2771	0					0	my %is_table;
2772	20					54	while (@$links)
2773							{
2774	48					84	my $t1 = shift @$links;
2775	48					49	my $t2 = shift @$links;
2776	48	50	33			160	return undef unless defined $t1 and defined $t2;
2777	48	100				113	push @all_tables, $t1 unless $is_table{$t1}++;
2778	48	100				93	push @all_tables, $t2 unless $is_table{$t2}++;
2779	48					63	$relations{$t1}{$t2}++;
2780	48					95	$relations{$t2}{$t1}++;
2781							}
2782	20					40	my @tables = @all_tables;
2783	20					38	my @order = shift @tables;
2784	20					42	my %is_ordered = ( $order[0] => 1 );
2785	20					16	my %visited;
2786	20					49	while (@tables)
2787							{
2788	32					34	my $t = shift @tables;
2789	32					34	my @rels = keys %{ $relations{$t} };
	32					325
2790	32					47	for my $t2 (@rels)
2791							{
2792	38	100				67	next unless $is_ordered{$t2};
2793	32					39	push @order, $t;
2794	32					34	$is_ordered{$t}++;
2795	32					30	last;
2796							}
2797	32	50				96	if ( !$is_ordered{$t} )
2798							{
2799	0	0				0	push @tables, $t if $visited{$t}++ < @all_tables;
2800							}
2801							}
2802	20	50				43	return $self->do_err("Unconnected tables in equijoin statement!")
2803							if @order < @all_tables;
2804	20					98	return \@order;
2805							}
2806
2807							# PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW
2808							#
2809							#
2810							sub set_feature_flags
2811							{
2812	17			17	1	61	my ( $self, $select, $create ) = @_;
2813	17	50				65	if ( defined $select )
2814							{
2815	0					0	delete $self->{select};
2816							$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} =
2817	0					0	$self->{opts}->{select}->{join} = $select->{join};
2818							}
2819	17	50				65	if ( defined $create )
2820							{
2821	0					0	delete $self->{create};
2822	0					0	for my $key ( keys %$create )
2823							{
2824	0					0	my $type = $key;
2825	0					0	$type =~ s/type_(.*)/\U$1/;
2826							$self->{opts}->{valid_data_types}->{$type} = $self->{opts}->{create}->{$key} =
2827	0					0	$create->{$key};
2828							}
2829							}
2830							}
2831
2832							sub clean_sql
2833							{
2834	868			868	1	888	my ( $self, $sql ) = @_;
2835	868					696	my $fields;
2836	868					801	my $i = -1;
2837	868					847	my $e = '\\';
2838	868					951	$e = quotemeta($e);
2839
2840							#
2841							# patch from cpan@goess.org, adds support for col2=''
2842							#
2843							# $sql =~ s~'(([^'$e]\|$e.\|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge;
2844	868					3591	$sql =~ s~(?
	426					867
	426					449
	426					1431
2845
2846							#
2847	868					1302	foreach (@$fields) { $_ =~ s/''/\\'/g; }
	426					528
2848	868					1487	my @a = $sql =~ m/((?
2849	868	50				1909	if ( ( scalar(@a) % 2 ) == 1 )
2850							{
2851	0					0	$sql =~ s/^.*\?(.+)$/$1/;
2852	0					0	$self->do_err("Mismatched single quote before: <$sql>");
2853							}
2854	868	50				1583	if ( $sql =~ m/\?\?(\d)\?/ )
2855							{
2856	0					0	$sql = $fields->[$1];
2857	0					0	$self->do_err("Mismatched single quote: <$sql>");
2858							}
2859	868					911	foreach (@$fields) { $_ =~ s/$e'/'/g; s/^'(.*)'$/$1/; }
	426					715
	426					545
2860
2861							#
2862							# From Steffen G. to correctly return newlines from $dbh->quote;
2863							#
2864	868					822	foreach (@$fields) { $_ =~ s/([^\\])\\r/$1\r/g; }
	426					434
2865	868					857	foreach (@$fields) { $_ =~ s/([^\\])\\n/$1\n/g; }
	426					428
2866
2867	868					1066	$self->{struct}->{literals} = $fields;
2868
2869	868					725	my $qids;
2870	868					719	$i = -1;
2871	868					713	$e = q/""/;
2872
2873							# $sql =~ s~"(([^"$e]\|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
2874	868					1061	$sql =~ s/"(([^"]\|"")+)"/push(@$qids,$1);$i++;"?QI$i?"/ge;
	62					100
	62					46
	62					166
2875
2876							#@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids;
2877	868	100				1293	$self->{struct}->{quoted_ids} = $qids if ($qids);
2878
2879							# $sql =~ s~'(([^'\\]\|\\.)+)'~push(@$fields,$1);$i++;"?$i?"~ge;
2880							# @$fields = map { s/\\'/'/g; s/^'(.*)'$/$1/; $_} @$fields;
2881							#print "$sql [@$fields]\n";# if $sql =~ /SELECT/;
2882
2883							## before line 1511
2884	868					887	my $comment_re = $self->{comment_re};
2885
2886							# if ( $sql =~ s/($comment_re)//gs) {
2887							# $self->{comment} = $1;
2888							# }
2889	868	50				2227	if ( $sql =~ m/(.*)$comment_re$/s )
2890							{
2891	0					0	$sql = $1;
2892	0					0	$self->{comment} = $2;
2893							}
2894	868	100				1393	if ( $sql =~ m/^(.)--(.)(\n\|$)/ )
2895							{
2896	2					4	$sql = $1;
2897	2					4	$self->{comment} = $2;
2898							}
2899
2900	868					871	$sql =~ s/\n/ /g;
2901	868					4242	$sql =~ s/\s+/ /g;
2902	868					2669	$sql =~ s/(\S)\(/$1 (/g; # ensure whitespace before (
2903	868					978	$sql =~ s/\)(\S)/) $1/g; # ensure whitespace after )
2904	868					1829	$sql =~ s/\(\s*/(/g; # trim whitespace after (
2905	868					2541	$sql =~ s/\s*\)/)/g; # trim whitespace before )
2906							#
2907							# $sql =~ s/\s*\(/(/g; # trim whitespace before (
2908							# $sql =~ s/\)\s*/)/g; # trim whitespace after )
2909							# for my $op (qw(= <> < > <= >= \\|\\|))
2910							# {
2911							# $sql =~ s/(\S)$op/$1 $op/g;
2912							# $sql =~ s/$op(\S)/$op $1/g;
2913							# }
2914	868					5358	$sql =~ s/(\S)([<>]?=\|<>\|<\|>\|\\|\\|)/$1 $2/g;
2915	868					4706	$sql =~ s/([<>]?=\|<>\|<\|>\|\\|\\|)(\S)/$1 $2/g;
2916	868					966	$sql =~ s/< >/<>/g;
2917	868					848	$sql =~ s/< =/<=/g;
2918	868					757	$sql =~ s/> =/>=/g;
2919	868					1879	$sql =~ s/\s*,/,/g;
2920	868					1437	$sql =~ s/,\s*/,/g;
2921	868					909	$sql =~ s/^\s+//;
2922	868					1525	$sql =~ s/\s+$//;
2923
2924	868					2120	return $sql;
2925							}
2926
2927							sub trim
2928							{
2929	4	50		4	1	8	my $str = $_[0] or return ('');
2930	4					5	$str =~ s/^\s+//;
2931	4					5	$str =~ s/\s+$//;
2932	4					6	return $str;
2933							}
2934
2935							sub do_err
2936							{
2937	20			20	1	29	my ( $self, $err, $errstr ) = @_;
2938
2939							# $err = $errtype ? "DIALECT ERROR: $err" : "SQL ERROR: $err";
2940	20					35	$self->{struct}->{errstr} = $err;
2941
2942	20	50				40	carp $err if ( $self->{PrintError} );
2943	20	100				667	croak $err if ( $self->{RaiseError} );
2944	14					58	return;
2945							}
2946
2947							#
2948							# DAA
2949							# abstract method so subclasses can provide
2950							# their own syntax transformations
2951							#
2952							sub transform_syntax
2953							{
2954	231			231	1	210	my ( $self, $str ) = @_;
2955	231					230	return $str;
2956							}
2957
2958							sub DESTROY
2959							{
2960	12			12		4056	my $self = $_[0];
2961
2962	12					392	undef $self->{opts};
2963	12					69	undef $self->{struct};
2964	12					44	undef $self->{tmp};
2965	12					21	undef $self->{dialect};
2966	12					143	undef $self->{dialect_set};
2967							}
2968
2969							1;
2970
2971							__END__