File Coverage

blib/lib/Mail/Message/Replace/MailInternet.pm
Criterion Covered Total %
statement 28 181 15.4
branch 0 66 0.0
condition 0 61 0.0
subroutine 10 46 21.7
pod 33 35 94.2
total 71 389 18.2


line stmt bran cond sub pod time code
1             # Copyrights 2001-2023 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.03.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Message::Replace::MailInternet;
10 1     1   912 use vars '$VERSION';
  1         3  
  1         55  
11             $VERSION = '3.013';
12              
13 1     1   6 use base 'Mail::Message';
  1         2  
  1         101  
14              
15 1     1   8 use strict;
  1         2  
  1         21  
16 1     1   5 use warnings;
  1         3  
  1         25  
17              
18 1     1   7 use Mail::Box::FastScalar;
  1         2  
  1         35  
19 1     1   8 use Mail::Box::Parser::Perl;
  1         2  
  1         29  
20 1     1   5 use Mail::Message::Body::Lines;
  1         2  
  1         23  
21              
22 1     1   5 use File::Spec;
  1         3  
  1         2303  
23              
24              
25             sub new(@)
26 0     0 1   { my $class = shift;
27 0 0         my $data = @_ % 2 ? shift : undef;
28 0 0         $class = __PACKAGE__ if $class eq 'Mail::Internet';
29 0           $class->SUPER::new(@_, raw_data => $data);
30             }
31              
32             sub init($)
33 0     0 0   { my ($self, $args) = @_;
34 0   0       $args->{head_type} ||= 'Mail::Message::Replace::MailHeader';
35 0   0       $args->{head} ||= $args->{Header};
36 0   0       $args->{body} ||= $args->{Body};
37              
38 0 0         defined $self->SUPER::init($args) or return;
39              
40 0   0       $self->{MI_wrap} = $args->{FoldLength} || 79;
41 0           $self->{MI_mail_from} = $args->{MailFrom};
42 0 0         $self->{MI_modify} = exists $args->{Modify} ? $args->{Modify} : 1;
43              
44             $self->processRawData($self->{raw_data}, !defined $args->{Header}
45 0 0         , !defined $args->{Body}) if defined $self->{raw_data};
46              
47 0           $self;
48             }
49              
50             sub processRawData($$$)
51 0     0 0   { my ($self, $data, $get_head, $get_body) = @_;
52 0 0 0       return $self unless $get_head || $get_body;
53            
54 0           my ($filename, $lines);
55 0 0 0       if(ref $data eq 'ARRAY')
    0          
    0          
56 0           { $filename = 'array of lines';
57 0           $lines = $data;
58             }
59             elsif(ref $data eq 'GLOB')
60 0           { $filename = 'file (GLOB)';
61 0           $lines = [ <$data> ];
62             }
63             elsif(ref $data && $data->isa('IO::Handle'))
64 0           { $filename = 'file ('.ref($data).')';
65 0           $lines = [ $data->getlines ];
66             }
67             else
68 0           { $self->log(ERROR=> "Mail::Internet does not support this kind of data");
69 0           return undef;
70             }
71              
72 0 0         return unless @$lines;
73              
74 0           my $buffer = join '', @$lines;
75 0           my $file = Mail::Box::FastScalar->new(\$buffer);
76              
77 0           my $parser = Mail::Box::Parser::Perl->new
78             ( filename => $filename
79             , file => $file
80             , trusted => 1
81             );
82              
83 0           my $head;
84 0 0         if($get_head)
85 0 0         { my $from = substr($lines->[0], 0, 5) eq 'From ' ? shift @$lines : undef;
86              
87             my $head = $self->{MM_head_type}->new
88             ( MailFrom => $self->{MI_mail_from}
89             , Modify => $self->{MI_modify}
90             , FoldLength => $self->{MI_wrap}
91 0           );
92 0           $head->read($parser);
93 0 0         $head->mail_from($from) if defined $from;
94 0           $self->head($head);
95             }
96             else
97 0           { $head = $self->head;
98             }
99              
100 0 0         $self->storeBody($self->readBody($parser, $head)) if $get_body;
101 0           $self->addReport($parser);
102 0           $parser->stop;
103 0           $self;
104             }
105              
106              
107             sub dup()
108 0     0 1   { my $self = shift;
109 0           ref($self)->coerce($self->clone);
110             }
111              
112              
113 0     0 1   sub empty() { shift->DESTROY }
114              
115             #--------------------------
116              
117              
118             sub MailFrom(;$)
119 0     0 1   { my $self = shift;
120 0 0         @_ ? ($self->{MI_mail_from} = shift) : $self->{MU_mail_from};
121             }
122              
123             #--------------------------
124              
125              
126             sub read($@)
127 0     0 1   { my $thing = shift;
128              
129 0 0         return $thing->SUPER::read(@_) # Mail::Message behavior
130             unless ref $thing;
131              
132             # Mail::Header emulation
133 0           my $data = shift;
134 0           $thing->processRawData($data, 1, 1);
135             }
136              
137              
138             sub read_body($)
139 0     0 1   { my ($self, $data) = @_;
140 0           $self->processRawData($data, 0, 1);
141             }
142              
143              
144             sub read_header($)
145 0     0 1   { my ($self, $data) = @_;
146 0           $self->processRawData($data, 1, 0);
147             }
148              
149              
150             sub extract($)
151 0     0 1   { my ($self, $data) = @_;
152 0           $self->processRawData($data, 1, 1);
153             }
154              
155              
156             sub reply(@)
157 0     0 1   { my ($self, %args) = @_;
158              
159 0           my $reply_head = $self->{MM_head_type}->new;
160 0   0       my $home = $ENV{HOME} || File::Spec->curdir;
161 0           my $headtemp = File::Spec->catfile($home, '.mailhdr');
162              
163 0 0         if(open HEAD, '<:raw', $headtemp)
164 0           { my $parser = Mail::Box::Parser::Perl->new
165             ( filename => $headtemp
166             , file => \*HEAD
167             , trusted => 1
168             );
169 0           $reply_head->read($parser);
170 0           $parser->close;
171             }
172              
173 0   0       $args{quote} ||= delete $args{Inline} || '>';
      0        
174 0   0       $args{group_reply} ||= delete $args{ReplyAll} || 0;
      0        
175 0   0       my $keep = delete $args{Keep} || [];
176 0   0       my $exclude = delete $args{Exclude} || [];
177              
178 0           my $reply = $self->SUPER::reply(%args);
179              
180 0           my $head = $self->head;
181              
182             $reply_head->add($_->clone)
183 0           foreach map { $head->get($_) } @$keep;
  0            
184              
185 0           $reply_head->reset($_) foreach @$exclude;
186              
187 0           ref($self)->coerce($reply);
188             }
189              
190              
191             sub add_signature(;$)
192 0     0 1   { my $self = shift;
193             my $filename = shift
194 0   0       || File::Spec->catfile($ENV{HOME} || File::Spec->curdir, '.signature');
195 0           $self->sign(File => $filename);
196             }
197              
198              
199             sub sign(@)
200 0     0 1   { my ($self, $args) = @_;
201 0           my $sig;
202              
203 0 0         if(my $filename = delete $self->{File})
    0          
204 0           { $sig = Mail::Message::Body->new(file => $filename);
205             }
206             elsif(my $sig = delete $self->{Signature})
207 0           { $sig = Mail::Message::Body->new(data => $sig);
208             }
209              
210 0 0         return unless defined $sig;
211            
212 0           my $body = $self->decoded->stripSignature;
213 0           my $set = $body->concatenate($body, "-- \n", $sig);
214 0 0         $self->body($set) if defined $set;
215 0           $set;
216             }
217              
218              
219             sub send($@)
220 0     0 1   { my ($self, $type, %args) = @_;
221 0           $self->send(via => $type);
222             }
223              
224              
225             sub nntppost(@)
226 0     0 1   { my ($self, %args) = @_;
227 0   0       $args{port} ||= delete $args{Port};
228 0   0       $args{nntp_debug} ||= delete $args{Debug};
229              
230 0           $self->send(via => 'nntp', %args);
231             }
232              
233              
234              
235             sub head(;$)
236 0     0 1   { my $self = shift;
237 0 0         return $self->SUPER::head(@_) if @_;
238 0 0         $self->SUPER::head || $self->{MM_head_type}->new(message => $self);
239             }
240              
241              
242 0     0 1   sub header(;$) { shift->head->header(@_) }
243              
244              
245 0     0 1   sub fold(;$) { shift->head->fold(@_) }
246              
247              
248 0     0 1   sub fold_length(;$$) { shift->head->fold_length(@_) }
249              
250              
251 0     0 1   sub combine($;$) { shift->head->combine(@_) }
252              
253              
254 0     0 1   sub print_header(@) { shift->head->print(@_) }
255              
256              
257 0     0 1   sub clean_header() { shift->header }
258              
259              
260       0 1   sub tidy_headers() { }
261              
262              
263 0     0 1   sub add(@) { shift->head->add(@_) }
264              
265              
266 0     0 1   sub replace(@) { shift->head->replace(@_) }
267              
268              
269 0     0 1   sub get(@) { shift->head->get(@_) }
270              
271              
272             sub delete(@)
273 0     0 1   { my $self = shift;
274 0 0         @_ ? $self->head->delete(@_) : $self->SUPER::delete;
275             }
276              
277             #------------
278              
279              
280             sub body(@)
281 0     0 1   { my $self = shift;
282              
283 0 0         unless(@_)
284 0           { my $body = $self->body;
285 0 0         return defined $body ? scalar($body->lines) : [];
286             }
287              
288 0 0         my $data = ref $_[0] eq 'ARRAY' ? shift : \@_;
289 0           my $body = Mail::Message::Body::Lines->new(data => $data);
290 0           $self->body($body);
291              
292 0           $body;
293             }
294              
295              
296 0     0 1   sub print_body(@) { shift->SUPER::body->print(@_) }
297              
298              
299 0     0 1   sub bodyObject(;$) { shift->SUPER::body(@_) }
300              
301              
302             sub remove_sig(;$)
303 0     0 1   { my $self = shift;
304 0   0       my $lines = shift || 10;
305 0           my $stripped = $self->decoded->stripSignature(max_lines => $lines);
306 0 0         $self->body($stripped) if defined $stripped;
307 0           $stripped;
308             }
309              
310              
311             sub tidy_body(;$)
312 0     0 1   { my $self = shift;
313              
314 0 0         my $body = $self->body or return;
315 0           my @body = $body->lines;
316              
317 0   0       shift @body while @body && $body[0] =~ m/^\s*$/;
318 0   0       pop @body while @body && $body[-1] =~ m/^\s*$/;
319              
320 0 0         return $body if $body->nrLines == @body;
321 0           my $new = Mail::Message::Body::Lines->new(based_on => $body, data=>\@body);
322 0           $self->body($new);
323             }
324              
325              
326             sub smtpsend(@)
327 0     0 1   { my ($self, %args) = @_;
328 0   0       my $from = $args{MailFrom} || $ENV{MAILADDRESS} || $ENV{USER} || 'unknown';
329 0   0       $args{helo} ||= delete $args{Hello};
330 0   0       $args{port} ||= delete $args{Port};
331 0   0       $args{smtp_debug} ||= delete $args{Debug};
332              
333 0           my $host = $args{Host};
334 0 0         unless(defined $host)
335 0           { my $hosts = $ENV{SMTPHOSTS};
336 0 0         $host = (split /\:/, $hosts)[0] if defined $hosts;
337             }
338 0           $args{host} = $host;
339              
340 0           $self->send(via => 'smtp', %args);
341             }
342              
343             #------------
344              
345              
346             sub as_mbox_string()
347 0     0 1   { my $self = shift;
348 0           my $mboxmsg = Mail::Box::Mbox->coerce($self);
349              
350 0           my $buffer = '';
351 0           my $file = Mail::Box::FastScalar->new(\$buffer);
352 0           $mboxmsg->print($file);
353 0           $buffer;
354             }
355              
356             #------------
357              
358              
359             BEGIN {
360 1     1   9 no warnings;
  1         3  
  1         82  
361             *Mail::Internet::new = sub (@)
362 0     0     { my $class = shift;
363 0           Mail::Message::Replace::MailInternet->new(@_);
364 1     1   118 };
365             }
366              
367              
368             sub isa($)
369 0     0 1   { my ($thing, $class) = @_;
370 0 0         return 1 if $class eq 'Mail::Internet';
371 0           $thing->SUPER::isa($class);
372             }
373              
374             #------------
375              
376              
377             sub coerce() { confess }
378              
379              
380             1;
381