PMG/RuleDB/WhoRegex.pm

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