[Bps-public-commit] r9316 - in Net-Server-IMAP: lib/Net/Server/IMAP/Command

alexmv at bestpractical.com alexmv at bestpractical.com
Mon Oct 15 19:54:10 EDT 2007


Author: alexmv
Date: Mon Oct 15 19:54:09 2007
New Revision: 9316

Added:
   Net-Server-IMAP/lib/Net/Server/IMAP/Command/Search.pm
Modified:
   Net-Server-IMAP/   (props changed)

Log:
 r23612 at zoq-fot-pik:  chmrr | 2007-10-15 19:51:42 -0400
  * Searching!


Added: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Search.pm
==============================================================================
--- (empty file)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Search.pm	Mon Oct 15 19:54:09 2007
@@ -0,0 +1,165 @@
+package Net::Server::IMAP::Command::Search;
+
+use warnings;
+use strict;
+
+use base qw/Net::Server::IMAP::Command/;
+
+sub validate {
+    my $self = shift;
+
+    return $self->bad_command("Log in first") if $self->connection->is_unauth;
+    return $self->bad_command("Select a mailbox first")
+        unless $self->connection->is_selected;
+
+    return 1;
+}
+
+sub run {
+    my $self = shift;
+
+    my $filter = $self->filter($self->parsed_options);
+    return unless $filter;
+
+    my @results = map {$_->sequence} grep {$filter->($_)} @{$self->connection->selected->messages};
+    $self->untagged_response("SEARCH @results");
+    $self->ok_completed;
+}
+
+sub filter {
+    my $self = shift;
+    my @tokens = [@_]; # This ref is intentional!  It gets us the top-level AND
+    my $filters = []; my @stack;
+    while (@tokens) {
+        my $token = shift @tokens;
+        $token = uc $token unless ref $token;
+        if ($token eq "ALL") {
+            push @{$filters}, sub {1};
+        } elsif ($token eq "ANSWERED") {
+            push @{$filters}, sub {$_[0]->has_flag('\Answered')};
+        } elsif ($token eq "BCC") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $bcc = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->header("Bcc") =~ /\Q$bcc\E/i};
+        # BEFORE
+        } elsif ($token eq "BODY") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $str = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->body =~ /\Q$str\E/i};  # TODO: likely needs to recurse MIME parts?
+        } elsif ($token eq "CC") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $cc = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->header("Cc") =~ /\Q$cc\E/i};
+        } elsif ($token eq "DELETED") {
+            push @{$filters}, sub {$_[0]->has_flag('\Deleted')};
+        } elsif ($token eq "DRAFT") {
+            push @{$filters}, sub {$_[0]->has_flag('\Draft')};
+        } elsif ($token eq "FLAGGED") {
+            push @{$filters}, sub {$_[0]->has_flag('\Flagged')};
+        } elsif ($token eq "FROM") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $from = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->header("From") =~ /\Q$from\E/i};
+        } elsif ($token eq "HEADER") {
+            return $self->bad_command("Parse error") unless @tokens >= 2;
+            my ($header, $value) = splice(@tokens, 0, 2);
+            push @{$filters}, sub {$_[0]->mime->header($header) =~ /\Q$value\E/i};
+        } elsif ($token eq "KEYWORD") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $keyword = shift @tokens;
+            push @{$filters}, sub {$_[0]->has_flag($keyword)};
+        } elsif ($token eq "LARGER") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $size = shift @tokens;
+            push @{$filters}, sub {use bytes; length $_[0]->mime->as_string > $size};
+        } elsif ($token eq "NEW") {
+            push @{$filters}, sub {$_[0]->has_flag('\Recent') and not $_->has_flag('\Seen')};
+        } elsif ($token eq "NOT") {
+            unshift @stack, [NOT => 1 => $filters];
+            my $negation = [];
+            push @{$filters}, sub {not $negation->[0]->(@_)};
+            $filters = $negation;
+        } elsif ($token eq "OLD") {
+            push @{$filters}, sub {not $_[0]->has_flag('\Recent')};
+        # ON
+        } elsif ($token eq "OR") {
+            unshift @stack, [OR => 2 => $filters];
+            my $union = [];
+            push @{$filters}, sub {$union->[0]->(@_) or $union->[1]->(@_)};
+            $filters = $union;
+        } elsif ($token eq "RECENT") {
+            push @{$filters}, sub {$_[0]->has_flag('\Recent')};
+        } elsif ($token eq "SEEN") {
+            push @{$filters}, sub {$_[0]->has_flag('\Seen')};
+        # SENTBEFORE
+        # SENTON
+        # SENTSINCE
+        # SINCE
+        } elsif ($token eq "SMALLER") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $size = shift @tokens;
+            push @{$filters}, sub {use bytes; length $_[0]->mime->as_string < $size};
+        } elsif ($token eq "SUBJECT") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $subj = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->header("Subject") =~ /\Q$subj\E/i};
+        } elsif ($token eq "TEXT") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $str = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->as_string =~ /\Q$str\E/i};
+        } elsif ($token eq "TO") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $to = shift @tokens;
+            push @{$filters}, sub {$_[0]->mime->header("To") =~ /\Q$to\E/i};
+        } elsif ($token eq "UID") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $set = shift @tokens;
+            my %uids;
+            $uids{$_->uid}++ for $self->connection->selected->get_uids($set);
+            push @{$filters}, sub {$uids{$_[0]->uid}};
+        } elsif ($token eq "UNANSWERED") {
+            push @{$filters}, sub {not $_[0]->has_flag('\Answered')};
+        } elsif ($token eq "UNDELETED") {
+            push @{$filters}, sub {not $_[0]->has_flag('\Deleted')};
+        } elsif ($token eq "UNDRAFT") {
+            push @{$filters}, sub {not $_[0]->has_flag('\Draft')};
+        } elsif ($token eq "UNFLAGGED") {
+            push @{$filters}, sub {not $_[0]->has_flag('\Flagged')};
+        } elsif ($token eq "UNKEYWORD") {
+            return $self->bad_command("Parse error") unless @tokens;
+            my $keyword = shift @tokens;
+            push @{$filters}, sub {not $_[0]->has_flag($keyword)};
+        } elsif ($token eq "UNSEEN") {
+            push @{$filters}, sub {not $_[0]->has_flag('\Seen')};
+        } elsif ($token =~ /^\d+(:\d+|:\*)?(,\d+(:\d+|:\*))*$/) {
+            my %uids;
+            $uids{$_->uid}++ for $self->connection->selected->get_messages($token);
+            push @{$filters}, sub {$uids{$_[0]->uid}};
+        } elsif (ref $token) {
+            unshift @stack, [AND => -1 => $filters, \@tokens];
+            @tokens = @{$token};
+            my $intersection = [];
+            push @{$filters}, sub {
+                for my $f (@{$intersection}) {
+                    return unless $f->(@_);
+                }
+                return 1;
+            };
+            $filters = $intersection;
+        } else {
+            return $self->bad_command("Unknown command: $token");
+        }
+
+        while (@stack and (@{$filters} == $stack[0][1] or ($stack[0][3] and not @tokens))) {
+            $filters = $stack[0][2];
+            @tokens = @{$stack[0][3]} if $stack[0][3];
+            shift @stack;
+        }
+    }
+
+    return $self->bad_command("Unclosed NOT/OR") if @stack;
+    
+    return shift @{$filters};
+}
+
+1;



More information about the Bps-public-commit mailing list