File Coverage

blib/lib/Mail/Query.pm

Criterion	Covered	Total	%
statement	15	51	29.4
branch	0	26	0.0
condition			n/a
subroutine	5	12	41.6
pod	2	8	25.0
total	22	97	22.6

package Mail::Query;

require 5.005_62;
use strict;
use warnings;
use base 'Mail::Audit';
use Parse::RecDescent;
our $VERSION = '0.01';

sub new {
  my $package = shift;

  my $self = $package->SUPER::new(@_);
  $self->{parser} = new Parse::RecDescent($self->grammar);
  return $self;
}

sub query {
  my ($self, $query) = @_;
  local $self->{parser}{local}{mq} = $self;  # Circular ref, but local.  No sweat.
  return $self->{parser}->where_clause($query);
}

sub compare {
  my ($self, $field, $op, $string) = @_;

  # We handle =, <, and >
  return !$self->compare($field, '=', $string) if $op eq '!=';
  return !$self->compare($field, '<', $string) if $op eq '>=';
  return !$self->compare($field, '>', $string) if $op eq '<=';


  # This should be date-aware, at the least.  So far we punt.
  my $val = $self->get($field);
  #warn "comparing: '$val' $op '$string'";
  return $val eq $string if $op eq '=';
  return $val lt $string if $op eq '<';
  return $val gt $string if $op eq '>';

  die "Unknown operator '$op'";
}

sub between {
  my ($self, $field, $one, $two) = @_;

  # This should be date-aware, at the least.  So far we punt.
  ($one, $two) = ($two, $one) if $one gt $two;
  return 0 unless $one lt $field;
  return 0 unless $field lt $two;
  return 1;
}

sub like {
  my ($self, $field, $pattern) = @_;

  if ($pattern->[1] eq 'regex') {
    (my $pat = $pattern->[0]) =~ s/([\@\$])/\\$1/g;  # A limited quotemeta (is this a good idea?)
    #warn "$field =~ $pat";
    my $result = eval "\$self->get(\$field) =~ $pat";  # eval to maintain 5.004 compat
    warn "Error in pattern $pat" unless defined $result;
    return $result;
  }

  # $pattern->[1] eq 'string'
  # A string like 'boo%hoo' maps to /^boo.*hoo$/
  my $string = quotemeta($pattern->[0]);
  $string =~ s/%/.*/;
  return $self->get($field) =~ /^$string$/;
}

sub exists {
  my ($self, $field) = @_;
  #my $val = $self->get($field); warn "checking for defined($field): ", defined($val);

  return defined $self->get($field);
}

# We implement a 'Recipient' field, which is any of To, Cc, or Bcc
# We also make 'body' a header-like field, for queries like "body LIKE /blah/"
sub get {
  my ($self, $field) = @_;
  return join '', @{$self->body}                              if lc($field) eq 'body';
  return join ', ', map {$self->SUPER::get($_)} qw(To Cc Bcc) if lc($field) eq 'recipient';
  return $self->SUPER::get($field);
}

sub grammar {
  return <<'EOF';
    # Excised from http://www.contrib.andrew.cmu.edu/~shadow/sql/sql2bnf.aug92.txt

    where_clause: search_condition /^\z/                     {$return = $item{search_condition}}
                |

    search_condition:
                      {$return = grep {$_} @{$item[1]}}

    bool_term:
               {$return = !grep {!$_} @{$item[1]}}

    bool_factor: not(?) bool_primary                {$return = @{$item[1]} ? !$item[2] : $item[2]}
    # Don't support IS TRUE and IS NOT UNKNOWN and all that crap

    bool_primary: '('  search_condition ')' {$return = $item[3]}
                | predicate

    predicate: comparison_predicate
             | between_predicate
             | like_predicate
             | null_predicate
              # There's more here, but I'm skipping for now.

    # These only accept header field names as the LHS, and don't allow functions yet.
    comparison_predicate: header comp_op string        {$return = $thisparser->{local}{mq}->compare(@item[1,2,3])}

    between_predicate: header not(?) between string /AND/i string
                                                         {my $x = $thisparser->{local}{mq}->between(@item[1,4,6]);
							  $return = @{$item[2]} ? !$x : $x}

    like_predicate: header not(?) like rhs               {my $x = $thisparser->{local}{mq}->like(@item[1,4]);
							  $return = @{$item[2]} ? !$x : $x}

    null_predicate: header is not(?) null                {my $x = $thisparser->{local}{mq}->exists($item[1]);
						          $return = @{$item[3]} ? $x : !$x}

    rhs: string {$return = [$item[1], 'string']}
       | regex  {$return = [$item[1], 'regex' ]}

    # With a true $arg[0], returns a two-element listref.
    string: {my @x = extract_quotelike($text);
             if ($x[0] and ($x[3] =~ m/^q+$/ or $x[4] =~ m/^['"]$/) ) { # Strings only, not regexes & so on
               substr($text,0,pos($text)) = '';
               $return = $x[5];
             } else {
               $return = undef;
             }
            }

    regex:  {local $_ = extract_quotelike($text);
	     $return = (m/^m/ or m/^\//) ? $_ : undef}

    comp_op: '=' | '!=' | '<=' | '>=' | '<' | '>'

    header: /[\w-]+/  # dashes are allowed, very common in headers.

    not:  /NOT/i
    is:   /IS/i
    like: /LIKE/i
    null: /NULL/i
    between: /BETWEEN/i

EOF
}

1;
__END__