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