src/PMG/RuleDB/WhoRegex.pm

   1 package PMG::RuleDB::WhoRegex;
   2
   3 use strict;
   4 use warnings;
   5 use DBI;
   6 use Digest::SHA;
   7
   8 use PMG::Utils;
   9 use PMG::RuleDB::Object;
  10
  11 use base qw(PMG::RuleDB::Object);
  12
  13 sub otype {
  14     return 1000;
  15 }
  16
  17 sub oclass {
  18     return 'who';
  19 }
  20
  21 sub otype_text {
  22     return 'Regular Expression';
  23 }
  24
  25 sub new {
  26     my ($type, $address, $ogroup) = @_;
  27
  28     my $class = ref($type) || $type;
  29
  30     my $self = $class->SUPER::new($class->otype(), $ogroup);
  31
  32     $address //= '.*@domain\.tld';
  33
  34     $self->{address} = $address;
  35
  36     return $self;
  37 }
  38
  39 sub load_attr {
  40     my ($type, $ruledb, $id, $ogroup, $value) = @_;
  41
  42     my $class = ref($type) || $type;
  43
  44     defined($value) || die "undefined value: ERROR";
  45
  46     my $obj = $class->new ($value, $ogroup);
  47     $obj->{id} = $id;
  48
  49     $obj->{digest} = Digest::SHA::sha1_hex($id, $value, $ogroup);
  50
  51     return $obj;
  52 }
  53
  54 sub save {
  55     my ($self, $ruledb) = @_;
  56
  57     defined($self->{ogroup}) || die "undefined ogroup: ERROR";
  58     defined($self->{address}) || die "undefined address: ERROR";
  59
  60     my $adr = $self->{address};
  61     $adr =~ s/\\/\\\\/g;
  62
  63     if (defined ($self->{id})) {
  64         # update
  65
  66         $ruledb->{dbh}->do (
  67             "UPDATE Object SET Value = ? WHERE ID = ?",
  68             undef, $adr, $self->{id});
  69
  70     } else {
  71         # insert
  72
  73         my $sth = $ruledb->{dbh}->prepare (
  74             "INSERT INTO Object (Objectgroup_ID, ObjectType, Value) " .
  75             "VALUES (?, ?, ?);");
  76
  77         $sth->execute($self->{ogroup}, $self->otype, $adr);
  78
  79         $self->{id} = PMG::Utils::lastid($ruledb->{dbh}, 'object_id_seq');
  80     }
  81
  82     return $self->{id};
  83 }
  84
  85 sub who_match {
  86     my ($self, $addr) = @_;
  87
  88     my $t = $self->address;
  89
  90     return $addr =~ m/^$t$/i;
  91 }
  92
  93 sub address {
  94     my ($self, $addr) = @_;
  95
  96     if (defined ($addr)) {
  97         $self->{address} = $addr;
  98     }
  99
 100     $self->{address};
 101 }
 102
 103 sub short_desc {
 104     my $self = shift;
 105
 106     my $desc = $self->{address};
 107
 108     return $desc;
 109 }
 110
 111 sub properties {
 112     my ($class) = @_;
 113
 114     return {
 115         regex => {
 116             description => "Email address regular expression.",
 117             type => 'string',
 118             maxLength => 1024,
 119         },
 120     };
 121 }
 122
 123 sub get {
 124     my ($self) = @_;
 125
 126     return { regex => $self->{address} };
 127 }
 128
 129 sub update {
 130     my ($self, $param) = @_;
 131
 132     $self->{address} = $param->{regex};
 133 }
 134
 135 1;
 136
 137 __END__
 138
 139 =head1 PMG::RuleDB::WhoRegex
 140
 141 A WHO object to check email addresses with regular expressions.
 142
 143 =head2 Attributes
 144
 145 =head3 address
 146
 147 A Perl regular expression used to compare email addresses (ignore case).
 148
 149 =head2 Examples
 150
 151     $obj = PMG::RuleDB::WhoRegex->new ('.*@yourdomain.com');
 152