- my ($self,$string) = @_;
- my $want = KEYWORD | PAREN;
- my $last = undef;
-
- my $depth = 0;
- my @bundle;
-
- my ($ea,$key,$op,$value) = ("","","","");
-
- # order of matches in the RE is important.. op should come early,
- # because it has spaces in it. otherwise "NOT LIKE" might be parsed
- # as a keyword or value.
-
-
-
-
-
- while ($string =~ /(
- $re_aggreg
- |$re_op
- |$re_keyword
- |$re_value
- |$re_paren
- )/igx ) {
- my $val = $1;
- my $current = 0;
-
- # Highest priority is last
- $current = OP if _match($re_op,$val) ;
- $current = VALUE if _match($re_value,$val);
- $current = KEYWORD if _match($re_keyword,$val) && ($want & KEYWORD);
- $current = AGGREG if _match($re_aggreg,$val);
- $current = PAREN if _match($re_paren,$val);
-
-
- unless ($current && $want & $current) {
- # Error
- # FIXME: I will only print out the highest $want value
- die "Error near ->$val<- expecting a ", $tokens[((log $want)/(log 2))], " in $string\n";
- }
-
- # State Machine:
-
- #$RT::Logger->debug("We've just found a '$current' called '$val'");
-
- # Parens are highest priority
- if ($current & PAREN) {
- if ($val eq "(") {
- $self->_close_bundle(@bundle); @bundle = ();
- $depth++;
- $self->_OpenParen;
-
- } else {
- $self->_close_bundle(@bundle); @bundle = ();
- $depth--;
- $self->_CloseParen;
- }
-
- $want = KEYWORD | PAREN | AGGREG;
- }
-
- elsif ( $current & AGGREG ) {
- $ea = $val;
- $want = KEYWORD | PAREN;
- }
- elsif ( $current & KEYWORD ) {
- $key = $val;
- $want = OP;
- }
- elsif ( $current & OP ) {
- $op = $val;
- $want = VALUE;
- }
- elsif ( $current & VALUE ) {
- $value = $val;
-
- # Remove surrounding quotes from $key, $val
- # (in future, simplify as for($key,$val) { action on $_ })
- if ($key =~ /$RE{delimited}{-delim=>qq{\'\"}}/) {
- substr($key,0,1) = "";
- substr($key,-1,1) = "";
- }
- if ($val =~ /$RE{delimited}{-delim=>qq{\'\"}}/) {
- substr($val,0,1) = "";
- substr($val,-1,1) = "";
- }
- # Unescape escaped characters
- $key =~ s!\\(.)!$1!g;
- $val =~ s!\\(.)!$1!g;
- # print "$ea Key=[$key] op=[$op] val=[$val]\n";
-
-
- my $subkey;
- if ($key =~ /^(.+?)\.(.+)$/) {
- $key = $1;
- $subkey = $2;
- }
-
- my $class;
- if (exists $lcfields{lc $key}) {
- $key = $lcfields{lc $key};
- $class = $FIELDS{$key}->[0];
- }
- # no longer have a default, since CF's are now a real class, not fallthrough
- # fixme: "default class" is not Generic.
-
-
- die "Unknown field: $key" unless $class;
-
- $self->{_sql_localdepth} = 0;
- die "No such dispatch method: $class"
- unless exists $dispatch{$class};
- my $sub = $dispatch{$class} || die;;
- if ($can_bundle{$class} &&
- (!@bundle ||
- ($bundle[-1]->{dispatch} == $sub &&
- $bundle[-1]->{key} eq $key &&
- $bundle[-1]->{subkey} eq $subkey)))
- {
- push @bundle, {
- dispatch => $sub,
- key => $key,
- op => $op,
- val => $val,
- ea => $ea || "",
- subkey => $subkey,
- };
- } else {
- $self->_close_bundle(@bundle); @bundle = ();
- $sub->(
- $self,
- $key,
- $op,
- $val,
- SUBCLAUSE => "", # don't need anymore
- ENTRYAGGREGATOR => $ea || "",
- SUBKEY => $subkey,
- );
- }
-
- $self->{_sql_looking_at}{lc $key} = 1;
-
- ($ea,$key,$op,$value) = ("","","","");
-
- $want = PAREN | AGGREG;
- } else {
- die "I'm lost";
- }
-
- $last = $current;
- } # while
-
- $self->_close_bundle(@bundle); @bundle = ();
-
- die "Incomplete query"
- unless (($want | PAREN) || ($want | KEYWORD));
-
- die "Incomplete Query"
- unless ($last && ($last | PAREN) || ($last || VALUE));
-
- # This will never happen, because the parser will complain
- die "Mismatched parentheses"
- unless $depth == 0;
-
+ my ($self,$string) = @_;
+ my @bundle;
+ my $ea = '';
+
+ my %callback;
+ $callback{'OpenParen'} = sub {
+ $self->_close_bundle(@bundle); @bundle = ();
+ $self->_OpenParen
+ };
+ $callback{'CloseParen'} = sub {
+ $self->_close_bundle(@bundle); @bundle = ();
+ $self->_CloseParen;
+ };
+ $callback{'EntryAggregator'} = sub { $ea = $_[0] || '' };
+ $callback{'Condition'} = sub {
+ my ($key, $op, $value) = @_;
+
+ # key has dot then it's compound variant and we have subkey
+ my $subkey = '';
+ ($key, $subkey) = ($1, $2) if $key =~ /^([^\.]+)\.(.+)$/;
+
+ # normalize key and get class (type)
+ my $class;
+ if (exists $lcfields{lc $key}) {
+ $key = $lcfields{lc $key};
+ $class = $FIELD_METADATA{$key}->[0];
+ }
+ die "Unknown field '$key' in '$string'" unless $class;
+
+ # replace __CurrentUser__ with id
+ $value = $self->CurrentUser->id if $value eq '__CurrentUser__';
+
+
+ unless( $dispatch{ $class } ) {
+ die "No dispatch method for class '$class'"
+ }
+ my $sub = $dispatch{ $class };
+
+ if ( $can_bundle{ $class }
+ && ( !@bundle
+ || ( $bundle[-1]->{dispatch} == $sub
+ && $bundle[-1]->{key} eq $key
+ && $bundle[-1]->{subkey} eq $subkey
+ )
+ )
+ )
+ {
+ push @bundle, {
+ dispatch => $sub,
+ key => $key,
+ op => $op,
+ val => $value,
+ ea => $ea,
+ subkey => $subkey,
+ };
+ }
+ else {
+ $self->_close_bundle(@bundle); @bundle = ();
+ $sub->( $self, $key, $op, $value,
+ SUBCLAUSE => '', # don't need anymore
+ ENTRYAGGREGATOR => $ea,
+ SUBKEY => $subkey,
+ );
+ }
+ $self->{_sql_looking_at}{lc $key} = 1;
+ $ea = '';
+ };
+ RT::SQL::Parse($string, \%callback);
+ $self->_close_bundle(@bundle); @bundle = ();