view release on metacpan or  search on metacpan

lib/Mail/MtPolicyd/Plugin/RegexList.pm  view on Meta::CPAN

package Mail::MtPolicyd::Plugin::RegexList;

use Moose;
use namespace::autoclean;

our $VERSION = '2.05'; # VERSION
# ABSTRACT: mtpolicyd plugin for regex matching

extends 'Mail::MtPolicyd::Plugin';
with 'Mail::MtPolicyd::Plugin::Role::Scoring';
with 'Mail::MtPolicyd::Plugin::Role::UserConfig' => {
	'uc_attributes' => [ 'enabled', 'score', 'action' ],
};
with 'Mail::MtPolicyd::Plugin::Role::PluginChain';

use Mail::MtPolicyd::Plugin::Result;
use File::Slurp;


has 'enabled' => ( is => 'rw', isa => 'Str', default => 'on' );

has 'key' => ( is => 'rw', isa => 'Str', required => 1 );

has 'invert' => ( is => 'rw', isa => 'Bool', default => 0 );
has 'score' => ( is => 'rw', isa => 'Maybe[Num]' );
has 'action' => ( is => 'rw', isa => 'Maybe[Str]' );

around BUILDARGS => sub {
  my $orig  = shift;
  my $class = shift;
  my %params = @_;

  if ( defined $params{'regex'} ) {
    if( ! ref($params{'regex'}) ) {
      $params{'regex'} = [ $params{'regex'} ];
    }
  }
  return $class->$orig(%params);
};

has 'regex' => ( is => 'rw', isa => 'ArrayRef[Str]', default => sub { [] });

has 'file' => ( is => 'rw', isa => 'Maybe[Str]' );

has '_file_regex_list' => (
  is => 'ro', isa => 'ArrayRef', lazy => 1,
  default => sub {
    my $self = shift;
    if( ! defined $self->file ) {
      return [];
    }
    my @regexes;
    foreach my $line ( read_file($self->file) ) {
      chomp $line;
      if( $line =~ /^\s*$/ ) {
        next;
      }
      if( $line =~ /^\s*#/ ) {
        next;
      }
      push( @regexes, $line );
    }
    return \@regexes;
  },
);

has '_regex_list' => (
  is => 'ro', isa => 'ArrayRef', lazy => 1,
  default => sub {
    my $self = shift;
    return [ @{$self->regex}, @{$self->_file_regex_list} ]
  },
);

sub _match_regex_list {
  my ( $self, $r, $value ) = @_;

  foreach my $regex_str ( @{$self->_regex_list} ) {
    my $regex = eval { qr/$regex_str/ };
    if( $@ ) {
      $self->log($r, "invalid regex $regex: $@");
      next;
    }
    if( $value =~ /$regex/ ) {
      return $regex_str;
    }
  }

  return;
}

sub run {
	my ( $self, $r ) = @_;
	my $value = $r->get( $self->key );
	my $session = $r->session;

	if( $self->get_uc( $session, 'enabled') eq 'off' ) {
		return;
	}

	if( ! defined $value) {
		$self->log($r, 'no attribute \''.$self->key.'\' in request');
		return;
	}

	my ( $regex ) = $r->do_cached( $self->name.'-result',
			sub { $self->_match_regex_list($r, $value) } );

	if( ( ! $self->invert && defined $regex )
      || ( $self->invert && ! defined $regex ) ) {
		$self->log($r, $self->key.'='.$value.' matched '.$self->name);
    my $score = $self->get_uc( $session, 'score');
		if( defined $score
				&& ! $r->is_already_done($self->name.'-score') ) {
			$self->add_score($r, $self->name => $score);
		}
    # apply action
    my $action = $self->get_uc( $session, 'action');
		if( defined $action ) {
			return Mail::MtPolicyd::Plugin::Result->new(
				action => $action,
				abort => 1,
			);
		}
    # or cascade
		if( defined $self->chain ) {
			my $chain_result = $self->chain->run( $r );
			return( @{$chain_result->plugin_results} );