File Coverage

blib/lib/Mail/MtPolicyd/Request.pm
Criterion Covered Total %
statement 29 56 51.7
branch 7 20 35.0
condition 4 15 26.6
subroutine 6 8 75.0
pod 5 5 100.0
total 51 104 49.0


line stmt bran cond sub pod time code
1             package Mail::MtPolicyd::Request;
2              
3 21     21   1664305 use Moose;
  21         7299734  
  21         151  
4 21     21   162029 use namespace::autoclean;
  21         160870  
  21         111  
5              
6 21     21   13908 use Mail::MtPolicyd::Plugin::Result;
  21         82  
  21         17704  
7              
8             our $VERSION = '1.23'; # VERSION
9             # ABSTRACT: the request object
10              
11              
12             has 'attributes' => (
13             is => 'ro', isa => 'HashRef', required => 1,
14             traits => [ 'Hash' ],
15             handles => { 'attr' => 'get' },
16             );
17              
18              
19             # gets attached later
20             has 'session' => ( is => 'rw', isa => 'Maybe[HashRef]' );
21              
22              
23             has 'server' => (
24             is => 'ro', isa => 'Net::Server', required => 1,
25             handles => {
26             'log' => 'log',
27             }
28             );
29              
30              
31             has 'type' => (
32             is => 'ro',
33             isa => 'Str',
34             lazy => 1,
35             default => sub {
36             my $self = shift;
37             return( $self->attr('request') );
38             }
39             );
40              
41              
42             has 'use_caching' => ( is => 'rw', isa => 'Bool', default => 1 );
43              
44              
45             sub dump_attr {
46 0     0 1 0 my $self = shift;
47 0         0 my $attr = $self->attributes;
48 0         0 return( join(', ', map { $_.'='.$attr->{$_} } keys %$attr ) );
  0         0  
49             }
50              
51              
52             sub new_from_fh {
53 0     0 1 0 my ( $class, $fh ) = ( shift, shift );
54 0         0 my $attr = {};
55 0         0 my $complete = 0;
56 0         0 my $line;
57 0         0 while( defined( $line = $fh->getline ) ) {
58 0         0 $line =~ s/\r?\n$//;
59 0 0       0 if( $line eq '') { $complete = 1 ; last; }
  0         0  
  0         0  
60 0         0 my ( $name, $value ) = split('=', $line, 2);
61 0 0       0 if( ! defined $value ) {
62 0         0 die('error parsing request');
63             }
64 0         0 $attr->{$name} = $value;
65             }
66 0 0       0 if( $fh->error ) {
67 0         0 die('while reading request: '.$fh->error);
68             }
69 0 0 0     0 if( ! defined $line && ! $complete ) {
70 0         0 die('connection closed by peer');
71             }
72 0 0       0 if( ! $complete ) {
73 0         0 die('could not parse request');
74             }
75 0         0 my $obj = $class->new(
76             'attributes' => $attr,
77             @_
78             );
79 0         0 return $obj;
80             }
81              
82              
83             sub do_cached {
84 17     17 1 95 my ( $self, $key, $call ) = @_;
85 17         700 my $session = $self->session;
86              
87             # we cant cache a result without session
88 17 100 33     761 if( ! defined $session || ! $self->use_caching ) {
89 16         55 return( $call->() );
90             }
91 1 50       7 if( ! defined $session->{$key} ) {
92 1         4 $session->{$key} = [ $call->() ];
93             }
94 1         53082 return( @{$session->{$key}} );
  1         11  
95             }
96              
97              
98             sub is_already_done {
99 47     47 1 100 my ( $self, $key ) = @_;
100 47         1924 my $session = $self->session;
101              
102             # we cant cache a result without session
103 47 100 33     2094 if( ! defined $session || ! $self->use_caching ) {
104 44         221 return 0;
105             }
106 3 50       19 if( defined $session->{$key} ) {
107 0         0 return(1);
108             }
109 3         11 $session->{$key} = 1;
110 3         67 return 0;
111             }
112              
113              
114             sub is_attr_defined {
115 6     6 1 24 my ( $self, @fields ) = @_;
116 6         315 my $a = $self->attributes;
117              
118 6         19 foreach my $field ( @fields ) {
119 6 50 33     84 if( ! defined $a->{$field}
      33        
120             || $a->{$field} eq ''
121             || $a->{$field} =~ /^\s+$/ ) {
122 0         0 return 0;
123             }
124             }
125              
126 6         110 return 1;
127             }
128              
129             __PACKAGE__->meta->make_immutable;
130              
131             1;
132              
133             __END__
134              
135             =pod
136              
137             =encoding UTF-8
138              
139             =head1 NAME
140              
141             Mail::MtPolicyd::Request - the request object
142              
143             =head1 VERSION
144              
145             version 1.23
146              
147             =head1 ATTRIBUTES
148              
149             =head2 attributes
150              
151             Contains an HashRef with all attributes of the request.
152              
153             To retrieve a single attribute the attr method could be used:
154              
155             $obj->attr('sender');
156              
157             =head2 session
158              
159             Contains a HashRef with all values stored in the session.
160              
161             mtpolicyd will persist the content of this HashRef across requests with the same instance_id.
162              
163             =head2 server
164              
165             Contains the Net::Server object of mtpolicyd.
166              
167             =head2 type
168              
169             The type of the request. Postfix will always use 'smtpd_access_policy'.
170              
171             =head2 use_caching
172              
173             Could be used to disable caching. Only used within the unit tests.
174              
175             =head1 METHODS
176              
177             =head2 dump_attr
178              
179             Returns an string to dump the content of a request.
180              
181             =head2 new_from_fh($fh)
182              
183             An object constructor for creating an request object with the content read
184             for the supplied filehandle $fh.
185              
186             Will die if am error ocours:
187              
188             =over
189              
190             =item error parsing request
191              
192             A line in the request could not be parsed.
193              
194             =item while reading request: <io-error>
195              
196             The filehandle had an error while reading the request.
197              
198             =item connection closed by peer
199              
200             Connection has been closed while reading the request.
201              
202             =item could not parse request
203              
204             The client did not send a complete request.
205              
206             =back
207              
208             =head2 do_cached( $key, $sub )
209              
210             This method will execute the function reference give in $sub and store
211             the return values in $key within the session.
212             If there is already a cached result stored within $key of the session
213             it will return the content instead of calling the reference again.
214              
215             Returns an Array with the return values of the function call.
216              
217             Example:
218              
219             my ( $ip_result, $info ) = $r->do_cached('rbl-'.$self->name.'-result',
220             sub { $self->_rbl->check( $ip ) } );
221              
222             =head2 is_already_done( $key )
223              
224             This function will raise an flag with name of $key within the session and return true if the
225             flag is already set. False otherwise.
226              
227             This could be used to prevent scores or headers from being applied a second time.
228              
229             Example:
230              
231             if( defined $self->score && ! $r->is_already_done('rbl-'.$self->name.'-score') ) {
232             $self->add_score($r, $self->name => $self->score);
233             }
234              
235             =head2 is_attr_defined
236              
237             Returns true if all given attribute names are defined and non-empty.
238              
239             =head1 AUTHOR
240              
241             Markus Benning <ich@markusbenning.de>
242              
243             =head1 COPYRIGHT AND LICENSE
244              
245             This software is Copyright (c) 2014 by Markus Benning <ich@markusbenning.de>.
246              
247             This is free software, licensed under:
248              
249             The GNU General Public License, Version 2, June 1991
250              
251             =cut