rt/lib/RT/Tickets_Overlay_SQL.pm

   1 # BEGIN LICENSE BLOCK
   2 #
   3 # Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
   4 #
   5 # (Except where explictly superceded by other copyright notices)
   6 #
   7 # This work is made available to you under the terms of Version 2 of
   8 # the GNU General Public License. A copy of that license should have
   9 # been provided with this software, but in any event can be snarfed
  10 # from www.gnu.org.
  11 #
  12 # This work is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # Unless otherwise specified, all modifications, corrections or
  18 # extensions to this work which alter its source code become the
  19 # property of Best Practical Solutions, LLC when submitted for
  20 # inclusion in the work.
  21 #
  22 #
  23 # END LICENSE BLOCK
  24 use strict;
  25 use warnings;
  26
  27 # Import configuration data from the lexcial scope of __PACKAGE__ (or
  28 # at least where those two Subroutines are defined.)
  29
  30 my %FIELDS = %{FIELDS()};
  31 my %dispatch = %{dispatch()};
  32 my %can_bundle = %{can_bundle()};
  33
  34 # Lower Case version of FIELDS, for case insensitivity
  35 my %lcfields = map { ( lc($_) => $_ ) } (keys %FIELDS);
  36
  37 sub _InitSQL {
  38   my $self = shift;
  39
  40   # How many of these do we actually still use?
  41
  42   # Private Member Variales (which should get cleaned)
  43   $self->{'_sql_linksc'}        = 0;
  44   $self->{'_sql_watchersc'}     = 0;
  45   $self->{'_sql_keywordsc'}     = 0;
  46   $self->{'_sql_subclause'}     = "a";
  47   $self->{'_sql_first'}         = 0;
  48   $self->{'_sql_opstack'}       = [''];
  49   $self->{'_sql_transalias'}    = undef;
  50   $self->{'_sql_trattachalias'} = undef;
  51   $self->{'_sql_keywordalias'}  = undef;
  52   $self->{'_sql_depth'}         = 0;
  53   $self->{'_sql_localdepth'}    = 0;
  54   $self->{'_sql_query'}         = '';
  55   $self->{'_sql_looking_at'}    = {};
  56
  57 }
  58
  59 sub _SQLLimit {
  60   # All SQL stuff goes into one SB subclause so we can deal with all
  61   # the aggregation
  62   my $this = shift;
  63   $this->SUPER::Limit(@_,
  64                       SUBCLAUSE => 'ticketsql');
  65 }
  66
  67 # Helpers
  68 sub _OpenParen {
  69   $_[0]->SUPER::_OpenParen( 'ticketsql' );
  70 }
  71 sub _CloseParen {
  72   $_[0]->SUPER::_CloseParen( 'ticketsql' );
  73 }
  74
  75 =head1 SQL Functions
  76
  77 =cut
  78
  79 sub _match {
  80   # Case insensitive equality
  81   my ($y,$x) = @_;
  82   return 1 if $x =~ /^$y$/i;
  83   #  return 1 if ((lc $x) eq (lc $y)); # Why isnt this equiv?
  84   return 0;
  85 }
  86
  87 =head2 Robert's Simple SQL Parser
  88
  89 Documentation In Progress
  90
  91 The Parser/Tokenizer is a relatively simple state machine that scans through a SQL WHERE clause type string extracting a token at a time (where a token is:
  92
  93   VALUE -> quoted string or number
  94   AGGREGator -> AND or OR
  95   KEYWORD -> quoted string or single word
  96   OPerator -> =,!=,LIKE,etc..
  97   PARENthesis -> open or close.
  98
  99 And that stream of tokens is passed through the "machine" in order to build up a structure that looks like:
 100
 101        KEY OP VALUE
 102   AND  KEY OP VALUE
 103   OR   KEY OP VALUE
 104
 105 That also deals with parenthesis for nesting.  (The parentheses are
 106 just handed off the SearchBuilder)
 107
 108 =cut
 109
 110 use Regexp::Common qw /delimited/;
 111
 112 # States
 113 use constant VALUE => 1;
 114 use constant AGGREG => 2;
 115 use constant OP => 4;
 116 use constant PAREN => 8;
 117 use constant KEYWORD => 16;
 118 my @tokens = qw[VALUE AGGREG OP PAREN KEYWORD];
 119
 120 my $re_aggreg = qr[(?i:AND|OR)];
 121 my $re_value  = qr[$RE{delimited}{-delim=>qq{\'\"}}|\d+];
 122 my $re_keyword = qr[$RE{delimited}{-delim=>qq{\'\"}}|(?:\{|\}|\w|\.)+];
 123 my $re_op     = qr[=|!=|>=|<=|>|<|(?i:IS NOT)|(?i:IS)|(?i:NOT LIKE)|(?i:LIKE)]; # long to short
 124 my $re_paren  = qr'\(|\)';
 125
 126 sub _close_bundle
 127 {
 128   my ($self, @bundle) = @_;
 129   return unless @bundle;
 130   if (@bundle == 1) {
 131     $bundle[0]->{dispatch}->(
 132                          $self,
 133                          $bundle[0]->{key},
 134                          $bundle[0]->{op},
 135                          $bundle[0]->{val},
 136                          SUBCLAUSE =>  "",
 137                          ENTRYAGGREGATOR => $bundle[0]->{ea},
 138                          SUBKEY => $bundle[0]->{subkey},
 139                         );
 140   } else {
 141     my @args;
 142     for my $chunk (@bundle) {
 143       push @args, [
 144           $chunk->{key},
 145           $chunk->{op},
 146           $chunk->{val},
 147           SUBCLAUSE =>  "",
 148           ENTRYAGGREGATOR => $chunk->{ea},
 149           SUBKEY => $chunk->{subkey},
 150       ];
 151     }
 152     $bundle[0]->{dispatch}->(
 153         $self, \@args,
 154     );
 155   }
 156 }
 157
 158 sub _parser {
 159   my ($self,$string) = @_;
 160   my $want = KEYWORD | PAREN;
 161   my $last = undef;
 162
 163   my $depth = 0;
 164   my @bundle;
 165
 166   my ($ea,$key,$op,$value) = ("","","","");
 167
 168   # order of matches in the RE is important.. op should come early,
 169   # because it has spaces in it.  otherwise "NOT LIKE" might be parsed
 170   # as a keyword or value.
 171
 172   while ($string =~ /(
 173                       $re_aggreg
 174                       |$re_op
 175                       |$re_keyword
 176                       |$re_value
 177                       |$re_paren
 178                      )/igx ) {
 179     my $val = $1;
 180     my $current = 0;
 181
 182     # Highest priority is last
 183     $current = OP      if _match($re_op,$val);
 184     $current = VALUE   if _match($re_value,$val);
 185     $current = KEYWORD if _match($re_keyword,$val) && ($want & KEYWORD);
 186     $current = AGGREG  if _match($re_aggreg,$val);
 187     $current = PAREN   if _match($re_paren,$val);
 188
 189     unless ($current && $want & $current) {
 190       # Error
 191       # FIXME: I will only print out the highest $want value
 192       die "Error near ->$val<- expecting a ", $tokens[((log $want)/(log 2))], " in $string\n";
 193     }
 194
 195     # State Machine:
 196
 197     # Parens are highest priority
 198     if ($current & PAREN) {
 199       if ($val eq "(") {
 200         $self->_close_bundle(@bundle);  @bundle = ();
 201         $depth++;
 202         $self->_OpenParen;
 203
 204       } else {
 205         $self->_close_bundle(@bundle);  @bundle = ();
 206         $depth--;
 207         $self->_CloseParen;
 208       }
 209
 210       $want = KEYWORD | PAREN | AGGREG;
 211     }
 212     elsif ( $current & AGGREG ) {
 213       $ea = $val;
 214       $want = KEYWORD | PAREN;
 215     }
 216     elsif ( $current & KEYWORD ) {
 217       $key = $val;
 218       $want = OP;
 219     }
 220     elsif ( $current & OP ) {
 221       $op = $val;
 222       $want = VALUE;
 223     }
 224     elsif ( $current & VALUE ) {
 225       $value = $val;
 226
 227       # Remove surrounding quotes from $key, $val
 228       # (in future, simplify as for($key,$val) { action on $_ })
 229       if ($key =~ /$RE{delimited}{-delim=>qq{\'\"}}/) {
 230         substr($key,0,1) = "";
 231         substr($key,-1,1) = "";
 232       }
 233       if ($val =~ /$RE{delimited}{-delim=>qq{\'\"}}/) {
 234         substr($val,0,1) = "";
 235         substr($val,-1,1) = "";
 236       }
 237       # Unescape escaped characters
 238       $key =~ s!\\(.)!$1!g;
 239       $val =~ s!\\(.)!$1!g;
 240       #    print "$ea Key=[$key] op=[$op]  val=[$val]\n";
 241
 242
 243    my $subkey;
 244    if ($key =~ /^(.+?)\.(.+)$/) {
 245      $key = $1;
 246      $subkey = $2;
 247    }
 248
 249       my $class;
 250       if (exists $lcfields{lc $key}) {
 251         $key = $lcfields{lc $key};
 252         $class = $FIELDS{$key}->[0];
 253       }
 254    # no longer have a default, since CF's are now a real class, not fallthrough
 255    # fixme: "default class" is not Generic.
 256
 257
 258    die "Unknown field: $key" unless $class;
 259
 260       $self->{_sql_localdepth} = 0;
 261       die "No such dispatch method: $class"
 262         unless exists $dispatch{$class};
 263       my $sub = $dispatch{$class} || die;;
 264       if ($can_bundle{$class} &&
 265           (!@bundle ||
 266             ($bundle[-1]->{dispatch} == $sub &&
 267              $bundle[-1]->{key} eq $key &&
 268              $bundle[-1]->{subkey} eq $subkey)))
 269       {
 270           push @bundle, {
 271               dispatch => $sub,
 272               key      => $key,
 273               op       => $op,
 274               val      => $val,
 275               ea       => $ea || "",
 276               subkey   => $subkey,
 277           };
 278       } else {
 279         $self->_close_bundle(@bundle);  @bundle = ();
 280         $sub->(
 281                $self,
 282                $key,
 283                $op,
 284                $val,
 285                SUBCLAUSE =>  "",  # don't need anymore
 286                ENTRYAGGREGATOR => $ea || "",
 287                SUBKEY => $subkey,
 288               );
 289       }
 290
 291       $self->{_sql_looking_at}{lc $key} = 1;
 292
 293       ($ea,$key,$op,$value) = ("","","","");
 294
 295       $want = PAREN | AGGREG;
 296     } else {
 297       die "I'm lost";
 298     }
 299
 300     $last = $current;
 301   } # while
 302
 303   $self->_close_bundle(@bundle);  @bundle = ();
 304
 305   die "Incomplete query"
 306     unless (($want | PAREN) || ($want | KEYWORD));
 307
 308   die "Incomplete Query"
 309     unless ($last && ($last | PAREN) || ($last || VALUE));
 310
 311   # This will never happen, because the parser will complain
 312   die "Mismatched parentheses"
 313     unless $depth == 0;
 314
 315 }
 316
 317
 318 =head2 ClausesToSQL
 319
 320 =cut
 321
 322 sub ClausesToSQL {
 323   my $self = shift;
 324   my $clauses = shift;
 325   my @sql;
 326
 327   for my $f (keys %{$clauses}) {
 328     my $sql;
 329     my $first = 1;
 330
 331     # Build SQL from the data hash
 332      for my $data ( @{ $clauses->{$f} } ) {
 333       $sql .= $data->[0] unless $first; $first=0;
 334       $sql .= " '". $data->[2] . "' ";
 335       $sql .= $data->[3] . " ";
 336       $sql .= "'". $data->[4] . "' ";
 337     }
 338
 339     push @sql, " ( " . $sql . " ) ";
 340   }
 341
 342   return join("AND",@sql);
 343 }
 344
 345 =head2 FromSQL
 346
 347 Convert a RT-SQL string into a set of SearchBuilder restrictions.
 348
 349 Returns (1, 'Status message') on success and (0, 'Error Message') on
 350 failure.
 351
 352 =cut
 353
 354 sub FromSQL {
 355   my ($self,$query) = @_;
 356
 357   $self->CleanSlate;
 358   $self->_InitSQL();
 359   return (1,"No Query") unless $query;
 360
 361   $self->{_sql_query} = $query;
 362   eval { $self->_parser( $query ); };
 363   $RT::Logger->error( $@ ) if $@;
 364   return(0,$@) if $@;
 365
 366   # We only want to look at EffectiveId's (mostly) for these searches.
 367   unless (exists $self->{_sql_looking_at}{'effectiveid'}) {
 368   $self->SUPER::Limit( FIELD           => 'EffectiveId',
 369                      ENTRYAGGREGATOR => 'AND',
 370                      OPERATOR        => '=',
 371                      QUOTEVALUE      => 0,
 372                      VALUE           => 'main.id'
 373     );    #TODO, we shouldn't be hard #coding the tablename to main.
 374     }
 375   # FIXME: Need to bring this logic back in
 376
 377   #      if ($self->_isLimited && (! $self->{'looking_at_effective_id'})) {
 378   #         $self->SUPER::Limit( FIELD => 'EffectiveId',
 379   #               OPERATOR => '=',
 380   #               QUOTEVALUE => 0,
 381   #               VALUE => 'main.id');   #TODO, we shouldn't be hard coding the tablename to main.
 382   #       }
 383   # --- This is hardcoded above.  This comment block can probably go.
 384   # Or, we need to reimplement the looking_at_effective_id toggle.
 385
 386   # Unless we've explicitly asked to look at a specific Type, we need
 387   # to limit to it.
 388   unless ($self->{looking_at_type}) {
 389     $self->SUPER::Limit( FIELD => 'Type',
 390                          OPERATOR => '=',
 391                          VALUE => 'ticket');
 392   }
 393
 394   # We never ever want to show deleted tickets
 395   $self->SUPER::Limit(FIELD => 'Status' , OPERATOR => '!=', VALUE => 'deleted');
 396
 397
 398   # set SB's dirty flag
 399   $self->{'must_redo_search'} = 1;
 400   $self->{'RecalcTicketLimits'} = 0;
 401
 402   return (1,"Good Query");
 403
 404 }
 405
 406
 407 1;
 408
 409 =pod
 410
 411 =head2 Exceptions
 412
 413 Most of the RT code does not use Exceptions (die/eval) but it is used
 414 in the TicketSQL code for simplicity and historical reasons.  Lest you
 415 be worried that the dies will trigger user visible errors, all are
 416 trapped via evals.
 417
 418 99% of the dies fall in subroutines called via FromSQL and then parse.
 419 (This includes all of the _FooLimit routines in Tickets_Overlay.pm.)
 420 The other 1% or so are via _ProcessRestrictions.
 421
 422 All dies are trapped by eval {}s, and will be logged at the 'error'
 423 log level.  The general failure mode is to not display any tickets.
 424
 425 =head2 General Flow
 426
 427 Legacy Layer:
 428
 429    Legacy LimitFoo routines build up a RestrictionsHash
 430
 431    _ProcessRestrictions converts the Restrictions to Clauses
 432    ([key,op,val,rest]).
 433
 434    Clauses are converted to RT-SQL (TicketSQL)
 435
 436 New RT-SQL Layer:
 437
 438    FromSQL calls the parser
 439
 440    The parser calls the _FooLimit routines to do DBIx::SearchBuilder
 441    limits.
 442
 443 And then the normal SearchBuilder/Ticket routines are used for
 444 display/navigation.
 445
 446 =cut
 447