1# Copyrights 2001-2021 by [Mark Overmeer <markov@cpan.org>].
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.02.
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
9package Mail::Message::Body::File;
10use vars '$VERSION';
11$VERSION = '3.011';
12
13use base 'Mail::Message::Body';
14
15use strict;
16use warnings;
17
18use Mail::Box::Parser;
19use Mail::Message;
20
21use Carp;
22use File::Temp qw/tempfile/;
23use File::Copy qw/copy/;
24
25
26sub _data_from_filename(@)
27{   my ($self, $filename) = @_;
28
29    local $_;
30    local (*IN, *OUT);
31
32    unless(open IN, '<:raw', $filename)
33    {   $self->log(ERROR =>
34            "Unable to read file $filename for message body file: $!");
35        return;
36    }
37
38    my $file   = $self->tempFilename;
39    unless(open OUT, '>:raw', $file)
40    {   $self->log(ERROR => "Cannot write to temporary body file $file: $!");
41        return;
42    }
43
44    my $nrlines = 0;
45    while(<IN>) { print OUT; $nrlines++ }
46
47    close OUT;
48    close IN;
49
50    $self->{MMBF_nrlines} = $nrlines;
51    $self;
52}
53
54sub _data_from_filehandle(@)
55{   my ($self, $fh) = @_;
56    my $file    = $self->tempFilename;
57    my $nrlines = 0;
58
59    local *OUT;
60
61    unless(open OUT, '>:raw', $file)
62    {   $self->log(ERROR => "Cannot write to temporary body file $file: $!");
63        return;
64    }
65
66    while(my $l = $fh->getline)
67    {   print OUT $l;
68        $nrlines++;
69    }
70    close OUT;
71
72    $self->{MMBF_nrlines} = $nrlines;
73    $self;
74}
75
76sub _data_from_glob(@)
77{   my ($self, $fh) = @_;
78    my $file    = $self->tempFilename;
79    my $nrlines = 0;
80
81    local $_;
82    local *OUT;
83
84    unless(open OUT, '>:raw', $file)
85    {   $self->log(ERROR => "Cannot write to temporary body file $file: $!");
86        return;
87    }
88
89    while(<$fh>)
90    {   print OUT;
91        $nrlines++;
92    }
93    close OUT;
94
95    $self->{MMBF_nrlines} = $nrlines;
96    $self;
97}
98
99sub _data_from_lines(@)
100{   my ($self, $lines)  = @_;
101    my $file = $self->tempFilename;
102
103    local *OUT;
104
105    unless(open OUT, '>:raw', $file)
106    {   $self->log(ERROR => "Cannot write to $file: $!");
107        return;
108    }
109
110    print OUT @$lines;
111    close OUT;
112
113    $self->{MMBF_nrlines} = @$lines;
114    $self;
115}
116
117sub clone()
118{   my $self  = shift;
119    my $clone = ref($self)->new(based_on => $self);
120
121    copy($self->tempFilename, $clone->tempFilename)
122       or return;
123
124    $clone->{MMBF_nrlines} = $self->{MMBF_nrlines};
125    $clone->{MMBF_size}    = $self->{MMBF_size};
126    $self;
127}
128
129sub nrLines()
130{   my $self    = shift;
131
132    return $self->{MMBF_nrlines}
133        if defined $self->{MMBF_nrlines};
134
135    my $file    = $self->tempFilename;
136    my $nrlines = 0;
137
138    local $_;
139    local *IN;
140
141    open IN, '<:raw', $file
142        or die "Cannot read from $file: $!\n";
143
144    $nrlines++ while <IN>;
145    close IN;
146
147    $self->{MMBF_nrlines} = $nrlines;
148}
149
150#------------------------------------------
151
152sub size()
153{   my $self = shift;
154
155    return $self->{MMBF_size}
156       if exists $self->{MMBF_size};
157
158    my $size = eval { -s $self->tempFilename };
159
160    $size   -= $self->nrLines
161        if $Mail::Message::crlf_platform;   # remove count for extra CR's
162
163    $self->{MMBF_size} = $size;
164}
165
166sub string()
167{   my $self = shift;
168
169    my $file = $self->tempFilename;
170
171    local *IN;
172
173    open IN, '<:raw', $file
174        or die "Cannot read from $file: $!\n";
175
176    my $return = join '', <IN>;
177    close IN;
178
179    $return;
180}
181
182sub lines()
183{   my $self = shift;
184
185    my $file = $self->tempFilename;
186
187    local *IN;
188    open IN, '<:raw', $file
189        or die "Cannot read from $file: $!\n";
190
191    my @r = <IN>;
192    close IN;
193
194    $self->{MMBF_nrlines} = @r;
195    wantarray ? @r: \@r;
196}
197
198sub file()
199{   open my $tmp, '<:raw', shift->tempFilename;
200    $tmp;
201}
202
203sub print(;$)
204{   my $self = shift;
205    my $fh   = shift || select;
206    my $file = $self->tempFilename;
207
208    local $_;
209    local *IN;
210
211    open IN, '<:raw', $file
212        or croak "Cannot read from $file: $!\n";
213
214    if(ref $fh eq 'GLOB') {print $fh $_ while <IN>}
215    else                  {$fh->print($_) while <IN>}
216    close IN;
217
218    $self;
219}
220
221sub read($$;$@)
222{   my ($self, $parser, $head, $bodytype) = splice @_, 0, 4;
223    my $file = $self->tempFilename;
224
225    local *OUT;
226
227    open OUT, '>:raw', $file
228        or die "Cannot write to $file: $!.\n";
229
230    (my $begin, my $end, $self->{MMBF_nrlines}) = $parser->bodyAsFile(\*OUT,@_);
231    close OUT;
232
233    $self->fileLocation($begin, $end);
234    $self;
235}
236
237# on UNIX always true.  Expensive to calculate on Windows: message size
238# may be off-by-one in rare cases.
239sub endsOnNewline() { shift->size==0 }
240
241#------------------------------------------
242
243
244sub tempFilename(;$)
245{   my $self = shift;
246
247      @_                     ? ($self->{MMBF_filename} = shift)
248    : $self->{MMBF_filename} ? $self->{MMBF_filename}
249    :                          ($self->{MMBF_filename} = (tempfile)[1]);
250}
251
252#------------------------------------------
253
254
255sub DESTROY { unlink shift->tempFilename }
256
257#------------------------------------------
258
2591;
260