]>
Commit | Line | Data |
---|---|---|
0a580593 DM |
1 | package PMG::RuleDB::WhoRegex; |
2 | ||
3 | use strict; | |
4 | use warnings; | |
0a580593 DM |
5 | use DBI; |
6 | use Digest::SHA; | |
7 | ||
758c7b6b | 8 | use PMG::Utils; |
0a580593 DM |
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 | ||
0a580593 DM |
25 | sub new { |
26 | my ($type, $address, $ogroup) = @_; | |
27 | ||
28 | my $class = ref($type) || $type; | |
29 | ||
7a2cf7e6 | 30 | my $self = $class->SUPER::new($class->otype(), $ogroup); |
0a580593 DM |
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 | ||
9ef3f143 | 44 | defined($value) || die "undefined value: ERROR"; |
0a580593 DM |
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 | ||
9ef3f143 DM |
57 | defined($self->{ogroup}) || die "undefined ogroup: ERROR"; |
58 | defined($self->{address}) || die "undefined address: ERROR"; | |
0a580593 DM |
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 | ||
758c7b6b | 79 | $self->{id} = PMG::Utils::lastid($ruledb->{dbh}, 'object_id_seq'); |
0a580593 DM |
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 | ||
693cf3b6 DM |
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 | ||
718d48a7 DM |
123 | sub get { |
124 | my ($self) = @_; | |
125 | ||
126 | return { regex => $self->{address} }; | |
127 | } | |
128 | ||
693cf3b6 DM |
129 | sub update { |
130 | my ($self, $param) = @_; | |
131 | ||
132 | $self->{address} = $param->{regex}; | |
133 | } | |
134 | ||
0a580593 DM |
135 | 1; |
136 | ||
137 | __END__ | |
138 | ||
139 | =head1 PMG::RuleDB::WhoRegex | |
140 | ||
141 | A WHO object to check email addresses with regular expresssions. | |
142 | ||
143 | =head2 Attribues | |
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 |