# # MailScanner - SMTP E-Mail Virus Scanner # Copyright (C) 2002 Julian Field # # $Id: PFDiskStore.pm 3914 2007-05-25 15:48:04Z sysjkf $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # The author, Julian Field, can be contacted by email at # Jules@JulianField.net # or by paper mail at # Julian Field # Dept of Electronics & Computer Science # University of Southampton # Southampton # SO17 1BJ # United Kingdom # package MailScanner::SMDiskStore; use strict 'vars'; use strict 'refs'; no strict 'subs'; # Allow bare words for parameter %'s use File::Basename; use File::Copy; use IO::File; use IO::Pipe; use MailScanner::Lock; use MailScanner::Config; use vars qw($VERSION @DeletesPending); ### The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = substr q$Revision: 3914 $, 10; # List of pending delete operations so we can clear up properly when killed @DeletesPending = (); ################################# #package MailScanner::SMDiskStore; # #@MailScanner::SMDiskStore::ISA = qw(MailScanner::DiskStore); # #use vars qw($VERSION); # #### The package version, both in 1.23 style *and* usable by MakeMaker: #$VERSION = substr q$Revision: 3914 $, 10; # Attributes are # # $dir set by new (incoming queue dir in case we use it) #ZZ $dname set by new (filename component only) # $hdname set by new (filename component only) # $tname set by new (filename component only) #ZZ $dpath set by new (full path) # $hdpath set by new (full path) # $size set by size # $inhdhandle set by lock #ZZ $indhandle set by lock # # # Constructor. # Takes message id and directory name. sub new { my $type = shift; my($id, $dir) = @_; my $this = {}; my $mta = $global::MS->{mta}; $this->{dir} = $dir; #print STDERR "Creating SMDiskStore($id)\n"; $this->{hdname} = $mta->HDFileName($id); $this->{tname} = $mta->TFileName($id); if ($MailScanner::SMDiskStore::HashDirDepth == 2) { $this->{hdname} =~ /^(.)(.)(.*)$/; $this->{hdpath} = "$dir/$1/$2/" . $this->{hdname}; } elsif ($MailScanner::SMDiskStore::HashDirDepth == 1) { $this->{hdname} =~ /^(.)(.*)$/; $this->{hdpath} = "$dir/$1/" . $this->{hdname}; } elsif ($MailScanner::SMDiskStore::HashDirDepth == 0) { $this->{hdname} =~ /^(.*)$/; $this->{hdpath} = "$dir/" . $this->{hdname}; } #print STDERR "Created new message object at " . $this->{hdpath} . "\n"; $this->{inhdhandle} = new FileHandle; bless $this, $type; return $this; } # Print the contents of the structure sub print { my $this = shift; print STDERR "hdpath = " . $this->{hdpath} . "\n" . "inhdhandle = " . $this->{inhdhandle} . "\n" . "size = " . $this->{size} . "\n"; } # Open and lock the message sub Lock { my $this = shift; #print STDERR "About to lock " . $this->{hdpath} . "\n"; MailScanner::Lock::openlock($this->{inhdhandle}, '+<' . $this->{hdpath}, 'w', 'quiet') or return undef; #print STDERR "Got hdlock\n"; return undef unless $this->{inhdhandle}; return 1; } # Close and unlock the message sub Unlock { my $this = shift; MailScanner::Lock::unlockclose($this->{inhdhandle}); } # Delete a message (from incoming queue) sub Delete { my $this = shift; # Maintain a list of pending deletes so we can clear up properly # when killed my $path = $this->{hdpath}; my $deferpath = $path; $deferpath =~ s/deferred/defer/gi; @DeletesPending = ($path, $deferpath); unlink $path, $deferpath; # Clear list of pending deletes @DeletesPending = (); } # Delete and unlock a message (from the incoming queue) # This will almost certainly be called more than once for each message sub DeleteUnlock { my $this = shift; #print STDERR "DeleteUnlock message\n"; # Maintain a list of pending deletes so we can clear up properly # when killed my $path = $this->{hdpath}; my $deferpath = $path; $deferpath =~ s/deferred/defer/gi; @DeletesPending = ($path, $deferpath); unlink $path, $deferpath; MailScanner::Lock::unlockclose($this->{inhdhandle}); # Clear list of pending deletes @DeletesPending = (); } # Carry out any pending delete operations so we leave the incoming queue # nice and tidy. We don't do anything except the delete operations as # the outgoing queue runner will pick up the messages eventually anyway. sub DoPendingDeletes { unlink @DeletesPending if @DeletesPending; @DeletesPending = (); } # Link at least the data portion of the message # There are not separate part for the data and headers in ZMailer # so, we do nothing. # TODO: LEOH # I don't think this is good, but the call to this function is in # Messages (I'm trying to modify only ZMailer* files) sub LinkData { my $this = shift; my($OutQ) = @_; #print STDERR "Marking body as original data in LinkData\n"; $this->{body}=[ "ORIGINAL", $OutQ ]; return; } # Write the temporary header data file, before it is made "live" by # renaming it. # Passed the parent message object we are working on, and the outqueue dir. # There is only one message, so this function have to write "both" # REVISO LEOH sub WriteHeader { my $this = shift; my($message, $Outq) = @_; my($tfile, $Tf, $predata, $HeaderStartPos, $TimestampInPre); #print STDERR "Writing header for message " . $message->{id} . "\n"; $tfile = $Outq . '/' . $this->{tname}; #$file .= '/' . $this->{tname}; #print STDERR "Writing header to temp file $tfile\n"; ($predata, $HeaderStartPos, $TimestampInPre) = MailScanner::Sendmail::PreDataString($message); # If we found more than 1 timestamp in the pre-data string, then # ditch this message and leave it back in the incoming queue #print STDERR "Predata is \"$predata\"\n"; #print STDERR "HeaderStartPos is \"$HeaderStartPos\"\n"; #print STDERR "TimestampInPre is \"$TimestampInPre\"\n"; if ($TimestampInPre != 1) { # Quietly drop the data structures of this message. MailScanner::Log::WarnLog("Message %s is currently invalid, retrying", $message->{id}); my @toclear = ( $message->{id} ); $global::MS->{work}->ClearIds(\@toclear); # Delete attachments $message->DropFromBatch(); return; } umask 0077; # Add this to try to stop 0666 qf files $Tf = new FileHandle; MailScanner::Lock::openlock($Tf, "+>$tfile", "w") or MailScanner::Log::DieLog("Cannot create + lock clean tempfile %s, %s", $tfile, $!); #print STDERR "Writing predata \"$predata\"\n"; #print STDERR "Length of predata is " . length($predata) . "\n"; #print STDERR "Before writing predata we are at " . $Tf->tell . "\n"; $Tf->print($predata); #print STDERR "Predata is \"$predata\"\n"; #print STDERR "After writing predata, file is at " . $Tf->tell() . "\n"; # Flush the filehandle to save duplicate writes in some Perls $Tf->flush(); #print STDERR "In WriteHeader, header starts at $HeaderStartPos\n"; if ($this->{body}[0] eq "ORIGINAL") { # # Create a body instance with the already open filehandle # my $b= Body->new( $this->{inhdhandle} ); if ($b) { $b->Start(); my $line; #print STDERR "originalBody\n"; while(defined($line = $b->Next())) { #print STDERR "Original: \"$line\"\n"; $Tf->print(MailScanner::Sendmail::Record2String('N', $line)); #print STDERR "BODY: $line\n"; } $b->Done(); } $Tf->flush(); } elsif ($this->{body}[0] eq "MIME" ) { my ($type, $id, $entity, $outq)= @{$this->{body}}; # This needs re-writing, as we need to massage every line # Create a pipe to squirt the message body through my $pipe = new IO::Pipe; my $pid; if (not defined $pipe or not defined ($pid = fork)) { MailScanner::Log::WarnLog("Pipe creation failed in WriteHeader, %s", $!); } elsif ($pid) { # Parent $Tf->flush(); # JKF 20050317 $pipe->reader(); # Read the pipe a line at a time and write an N record for each line. while(<$pipe>) { chomp; $Tf->print(MailScanner::Sendmail::Record2String('N', $_)); #print STDERR "Body: $_\n"; } # We have to tell the caller what the child's pid is in order to # reap it. Although IO::Pipe does this for us when it is told to # fork and exec, it unfortunately doesn't have a neat hook for us # to tell it the pid when we do the fork. Bah. $pipe->close(); $Tf->flush(); # JKF 20050307 waitpid $pid, 0; } else { # Child $Tf->flush(); # JKF 20050317 $pipe->writer(); $entity->print_body($pipe) or MailScanner::Log::WarnLog("WriteMIMEBody to %s possibly failed, %s", $tfile, $!); $pipe->close(); #$Tf->flush(); # JKF 20050307 exit; } } my($PostStartPos, $HeaderLength, $PostData, $TimestampInPost); $PostStartPos = tell $Tf; #print STDERR "\n\nPost data starts at $PostStartPos\n"; ($PostData, $TimestampInPost) = MailScanner::Sendmail::PostDataString($message); $Tf->print($PostData); #print STDERR "TimestampInPost = \"$TimestampInPost\"\n"; #print STDERR "PostDataString = \"$PostData\"\n"; $Tf->flush(); # If we found any timestamp in the post-data string, and we had one in # the pre-data string, then ditch this message and leave it back in the # incoming queue. if ($TimestampInPre && $TimestampInPost) { #print STDERR "We had trouble!\n"; # Quietly drop the data structures of this message. $message->{deleted} = 1; $message->{gonefromdisk} = 1; # Don't try to delete the original unlink $tfile; # Delete the new file from the queue MailScanner::Lock::unlockclose($Tf); return; } # Now over-write the length records in the 1st record and in the M record seek $Tf, 2, 0; #print STDERR "\n\nPostStartPos = \"$PostStartPos\"\n\n"; #print STDERR "\n\nHeaderStartPos = \"$HeaderStartPos\"\n\n"; $HeaderLength = ($PostStartPos-$HeaderStartPos); #print STDERR "\nC record contains headerlength " . $HeaderLength . # " and headerstartpos " . $HeaderStartPos . "\n"; # Count the number of recipients in the metadata now my ($recipcounter, $record); $recipcounter = 0; foreach $record (@{$message->{metadata}}) { $record =~ /^(.)(.*)$/; $recipcounter++ if $1 =~ /R/; } #print STDERR "Writing Data length = " . $PostStartPos-$HeaderStartPos . " Header start = $HeaderStartPos Recip Counter = $recipcounter\n"; printf $Tf "%15ld %15ld %15ld", $HeaderLength, $HeaderStartPos, $recipcounter; printf $Tf " %15ld", $message->{PostfixQmgrOpts} if $message->{PostfixQmgrOpts} ne ""; seek $Tf, 0, 0; #print STDERR "Seeked to start of file\n"; # Find the M record my($MPos, $type, $data); $MPos = 0; ($type, $data) = MailScanner::Sendmail::ReadRecord($Tf); while(defined($type) && $type ne 'M') { $MPos = tell $Tf; ($type, $data) = MailScanner::Sendmail::ReadRecord($Tf); #print STDERR "Skipping over record \"$data\"\n"; } MailScanner::Log::WarnLog("Corrupt queue output file") unless defined($type); unless ($MailScanner::Postfix::DataStructure > 0) { seek $Tf, $MPos+2, 0; printf $Tf "%15ld", $PostStartPos; } MailScanner::Lock::unlockclose($Tf); undef $Tf; # Try to ensure Tf is completely closed, flushed, everything my($hddirbase, $hddir1, $hddir2, $hdoutfile, $now); # Postfix wants the message file to have perms 0700 for some reason chmod 0700, "$tfile"; $now = time; if ($MailScanner::SMDiskStore::HashDirDepth == 2) { ($hddirbase, $hddir1, $hddir2, $hdoutfile) = MailScanner::Sendmail::HDOutFileName($tfile); #print STDERR "tfile = $tfile and hdoutfile = $hdoutfile\n"; mkdir "$hddirbase/$hddir1", 0755; mkdir "$hddirbase/$hddir1/$hddir2", 0755; chmod 0755, "$hddirbase/$hddir1", "$hddirbase/$hddir1/$hddir2"; # Update all the datestamps so that Postfix qmgr will see them utime $now, $now, "$hddirbase/$hddir1", "$hddirbase/$hddir1/$hddir2", "$tfile"; rename "$tfile", "$hddirbase/$hddir1/$hddir2/$hdoutfile" or MailScanner::Log::DieLog("Cannot rename clean %s to %s, %s", $tfile, $hdoutfile, $!); MailScanner::Log::InfoLog("Requeue: %s to %s", $message->{id},$hdoutfile); } elsif ($MailScanner::SMDiskStore::HashDirDepth == 1) { ($hddirbase, $hddir1, $hdoutfile) = MailScanner::Sendmail::HDOutFileName($tfile); #print STDERR "tfile = $tfile and hdoutfile = $hdoutfile\n"; mkdir "$hddirbase/$hddir1", 0755; chmod 0755, "$hddirbase/$hddir1"; # Update all the datestamps so that Postfix qmgr will see them utime $now, $now, "$hddirbase/$hddir1", "$tfile"; rename "$tfile", "$hddirbase/$hddir1/$hdoutfile" or MailScanner::Log::DieLog("Cannot rename clean %s to %s, %s", $tfile, $hdoutfile, $!); MailScanner::Log::InfoLog("Requeue: %s to %s", $message->{id},$hdoutfile); } elsif ($MailScanner::SMDiskStore::HashDirDepth == 0) { ($hddirbase, $hdoutfile) = MailScanner::Sendmail::HDOutFileName($tfile); #print STDERR "tfile = $tfile and hdoutfile = $hdoutfile\n"; # Update all the datestamps so that Postfix qmgr will see them utime $now, $now, "$tfile"; rename "$tfile", "$hddirbase/$hdoutfile" or MailScanner::Log::DieLog("Cannot rename clean %s to %s, %s", $tfile, $hdoutfile, $!); MailScanner::Log::InfoLog("Requeue: %s to %s", $message->{id},$hdoutfile); } } # Return the size of the message (Header+body) #REVISO LEOH sub size { my $this = shift; my($size, $hdpath); # Return previous calculated value if it exists $size = $this->{size}; return $size if $size; # Calculate it $hdpath = $this->{hdpath}; $size = -s $hdpath if -e $hdpath; # Store and return $this->{size} = $size; return $size; } # Return the size of the body (body) sub dsize { my $this = shift; my($size, $hdpath); # Return previous calculated value if it exists $size = $this->{size}; return $size if $size; # Calculate it $hdpath = $this->{hdpath}; $size = -s $hdpath if -e $hdpath; # Store and return $this->{size} = $size; return $size; } # Read the message body into an array. # Passed a ref to the array. # Read up to at least "$max" bytes, if the 2nd parameter is non-zero. sub ReadBody { my $this = shift; my($body, $max) = @_; my $line; my $lastlineread = undef; my $b = Body->new( $this->{inhdhandle} ); return unless $b; # Restraint is disabled, do the whole message. print "max message size is '$max'\n"; unless ($max) { while(defined($lastlineread = $b->Next())) { # End of line characters are already there, so don't add them push @{$body}, $lastlineread . "\n"; #print STDERR "Line read is ****" . $_ . "****\n"; } $b->Done(); return; } my @configwords = split(" ", $max); $max = $configwords[0]; $max =~ s/_//g; $max =~ s/k$/000/ig; $max =~ s/m$/000000/ig; $max =~ s/g$/000000000/ig; #print STDERR "Words are " . join(',',@configwords) . "\n"; # Read the body up to the limit my($line, $size); $size = 0; while(defined($line = $b->Next()) && $size<$max) { push @{$body}, $line . "\n"; $size += length($line); #print STDERR "Line read2 is ****" . $line . "****\n"; } $lastlineread = $line; #print STDERR "Initially read $size bytes\n"; # Handle trackback -- This is the tricky one if ($configwords[1] =~ /tr[ua]/i) { #print STDERR "Trackback:\n"; while (${@{$body}}[scalar(@{$body})-1] !~ /^\s*$/) { print "Line is ****" . ${@{$body}}[scalar(@{$body})-1] . "****\n"; pop @{$body}; #print STDERR "."; } #print STDERR "\n"; $b->Done(); return; } # Handle continue if ($configwords[1] =~ /con/i) { #print STDERR "Continue:\n"; my $maxsizes = 0; my $maxsize = 0; # Work out the number they have put in the .conf line after "continue" $maxsizes = $configwords[2] if $configwords[2] =~ /^[0-9]/; $maxsizes =~ s/_//g; if ($maxsizes =~ s/k$//i) { $maxsize = $maxsizes * 1000; } elsif ($maxsizes =~ s/m$//i) { $maxsize = $maxsizes * 1000000; } elsif ($maxsizes =~ s/g$//i) { $maxsize = $maxsizes * 1000000000; } elsif ($maxsizes =~ s/[^0-9]*//g) { $maxsize = $maxsizes; } # Value provided in .conf is the number of extra bytes to read. $maxsize += $max; #print STDERR "Maxsize = $maxsize\n"; # Now need to read extra bytes up to $maxsize bytes while(defined $lastlineread && $lastlineread !~ /^\s*$/) { #print "Continue added '$lastlineread'\n"; $size += length($lastlineread); last if $size > $maxsize; push @{$body}, $lastlineread . "\n"; $lastlineread = $b->Next(); #print STDERR "Added $lastlineread"; } $b->Done(); return; } #**************************************************************** # # Was the $max parameter used at all? # if ($max) { # my $size = 0; # $b->Start(); # while(defined($line = $b->Next()) && $size<$max) { # push @{$body}, $line . "\n"; # $size += length($line)+1; # } # # Continue copying until we hit a blank line, gives SA a complete # # encoded attachment # #while(defined $line) { # # $line = $b->Next(); # # last if $line =~ /^\s+$/; # # push @{$body}, $line . "\n" if defined $line; # #} # $b->Done(); # } else { # # No $max passed, so do as before # $b->Start(); # while(defined($line = $b->Next())) { # push @{$body}, $line . "\n"; # } # $b->Done(); # } } # Write the message body to a file in the outgoing queue. # Passed the message id, the root entity of the MIME structure # and the outgoing queue directory. sub WriteMIMEBody { my $this = shift; my($id, $entity, $outq) = @_; $this->{body}=[ "MIME", $id, $entity, $outq ]; return; } # Copy an entire copy of the message into a named file. # The target directory name will already exist. # May be more efficient to do this directly in perl # rather than by invoking a shell to run cat. # But it doesn't happen very often anyway. #REVISO LEOH # JKF This is wrong, it should copy not rename. # JKF Have decided that the hdname will contain *just* the filename # JKF and no directory components. # JKF The hashing directory components will be extracted when needed. # JKF Is now much simpler, just calls the functions that do the job already. # $targetfile can be 'message' or undef which indicates we are storing in the # main quarantine, not in the outgoing mail dir. sub CopyEntireMessage { my $this = shift; my($message, $targetdir, $targetfile, $uid, $gid, $changeowner) = @_; #print STDERR "Copying to $targetdir $targetfile\n"; if (MailScanner::Config::Value('storeentireasdfqf')) { #print STDERR "Copying to dir $targetdir\n"; return ($this->CopyToDir($targetdir, $targetfile, $uid, $gid, $changeowner)); } else { #print STDERR "Copying to file $targetdir/$targetfile\n"; my $target = new IO::File "$targetdir/$targetfile", "w"; MailScanner::Log::WarnLog("writing to $targetdir/$targetfile: $!") if not defined $target; $this->WriteEntireMessage($message, $target); return $targetdir . '/' . $targetfile; } } # my $hdfile = $this->{hdpath}; # # if ($MailScanner::SMDiskStore::HashDirDepth == 2) { # $hdfile =~ /(.)\/(.)\/[^\/]+$/; # mkdir "$targetdir/$1"; # mkdir "$targetdir/$1/$2"; # rename("$hdfile", "$targetdir/$1/$2/$$this{hdname}"); # } elsif ($MailScanner::SMDiskStore::HashDirDepth == 1) { # $hdfile =~ /(.)\/[^\/]+$/; # mkdir "$targetdir/$1"; # rename("$hdfile", "$targetdir/$1/$$this{hdname}"); # } #} # Writes the whole message to a handle. # Need to be passed the message to find the headers path # as it's not part of the DiskStore. sub ReadMessageHandle { my $this = shift; my ($message, $handle) = @_; # we use already opened handles my $hdhandle = $this->{inhdhandle}; # Where did we start? my $oldpos = sysseek $hdhandle, 0, 1; #print STDERR "Old position = $oldpos\n"; # rewind files to read and write with File::Copy sysseek($hdhandle, 0, 0) or die "$!,$^E"; # Rewind the file # Write the whole message in RFC822 format to the handle. # That means 1 CR-terminated line for every N record in the file. my $b = Body->new($hdhandle); #if ($b) { $b->Start(1); # 1 says we want the headers as well as the body my $line; #print STDERR "\n\n\n\n\n"; while(defined($line = $b->Next())) { #print STDERR "print $line\n"; print $handle "$line\n" or die "$!, $^E"; } $b->Done(); #} else { # die "Couldn't create new body object from $hdhandle, $!, $^E"; #} # rewind tmpfile to read it later $handle->seek(0,0) or die "$!, $^E"; # Rewind the file #print STDERR "\n\n\nTmp File is this:\n"; #while(<$handle>) { # print STDERR $_; #} #print STDERR "Tmp File End\n"; #$handle->seek(0,0) or die "$!, $^E"; # Rewind the file # rewind source files sysseek($hdhandle, 0, 0); # Rewind the file sysseek($hdhandle, $oldpos, 0); # Rewind the file #print STDERR "Done ReadMessageHandle\n"; return 1; } # Produce a pipe that will read the whole message. # Need to be passed the message to find the headers path # as it's not part of the DiskStore. # REVISO LEOH sub ReadMessagePipe { my $this = shift; my $message = shift; my $pipe = new IO::Pipe; my $pid; if (not defined $pipe or not defined ($pid = fork)) { MailScanner::Log::WarnLog("Cannot build message from $this->{hdpath}" . ", %s", $!); } elsif ($pid) { # Parent $pipe->reader(); # We have to tell the caller what the child's pid is in order to # reap it. Although IO::Pipe does this for us when it is told to # fork and exec, it unfortunately doesn't have a neat hook for us # to tell it the pid when we do the fork. Bah. return ($pipe,$pid); } else { # Child $pipe->writer(); $this->WriteEntireMessage($message, $pipe); $pipe->close(); exit; } } # Write a message to a filehandle sub WriteEntireMessage { my($this, $message, $handle) = @_; # Write the whole message in RFC822 format to the filehandle. # That means 1 CR-terminated line for every N record in the file. my $b= Body->new( $this->{inhdhandle} ); if ($b) { $b->Start(1); # 1 says we want the headers as well as the body my $line; #print STDERR "WriteEntireMessage\n"; while(defined($line = $b->Next())) { $handle->print($line . "\n"); #print STDERR "BODY: $line\n"; } $b->Done(); } } # Copy a hdfile to a directory # The Postfix version of this needs to know the destination filename too # so it can work out whether to use the hdpath as the destination filename # (which just has the 10 hex digits in it) or the message id, which has # the random number added to the end of it too. sub CopyToDir { my($this,$dir,$file,$uid,$gid,$changeowner) = @_; my($hdpath, $hdfile); $hdpath = $this->{hdpath}; if ($file && $file ne 'message') { #$hdfile = basename($hdpath); $hdfile = $file; } else { # We weren't passed a sensible filename, so work one out for ourselves. $hdfile = basename($hdpath); #$hdfile = $this->{id}; #basename($hdpath); #print STDERR "hdfile = $hdfile\n"; } copy($hdpath, "$dir/$hdfile"); chown $uid, $gid, "$dir/$hdfile" if $changeowner; return "$dir/$hdfile"; } package Body; # Stefan Baltus, October 2003 # # This package opens the body message. Multiple instances of this # packges can exist at the same time on the same file. If this file # is already open and locked in the same process, the lock will be # released when the file is re-opened and consequently closed. # # (from man fcntl in solaris 9): # # All locks associated with a file for a given process are # removed when a file descriptor for that file is closed by # that process or the process holding that file descriptor # terminates. Locks are not inherited by a child process # created using fork(2). # # These semantics don't seem to hold for various other systems, like # BSD and Linux, so the original code works fine. # # This package is changed in such a way that you need an open file- # descriptor to the file you have probably already open (and locked). # Returns () if it fails sub new { my $type = shift; my $self=(); my ($handle) = @_; # take handle as parameter seek $handle, 0, 0; # reset the handle if (defined $handle) { $self={ _handle => $handle, _startpos => -1, _donestart => 0 }; bless $self, $type; return $self; } else { #MailScanner::Log::DieLog("Cannot open %s, %s", $hdpathname, $!); return undef; } } # Find the start of the real message text. # If $entiremessage is true, then it looks for the start of the headers, # otherwise it looks for the start of the body after all the headers. sub Start { my($this, $entiremessage) = @_; my($offset); $$this{_donestart} = 1; if ($$this{_startpos} == -1) { #print STDERR "In Start() looking for start of message body\n"; # Read the 1st record containing the 3 offsets/lengths my($type, $data) = MailScanner::Sendmail::ReadRecord($$this{_handle}); MailScanner::Log::WarnLog("In Start didn't find a C record when I " . "wanted one %s %s", $type, $data) unless $type eq 'C'; $data =~ /^[0-9 ]{15} ([0-9 ]{15})/; $offset = $1 + 0; #print STDERR "In Start, data = \"$data\" and offset = $offset\n"; seek $$this{_handle}, $offset, 0; # IF they want the headers as well, then just get out now if ($entiremessage) { return; } while(($type, $data) = MailScanner::Sendmail::ReadRecord($$this{_handle})) { last if $type eq 'N' && $data eq ""; last if $type eq 'X'; } $$this{_startpos}= tell $$this{_handle}; #print STDERR "_startpos=$$this{_startpos}\n"; } seek $$this{_handle}, $$this{_startpos}, 0; } sub Next { my($this) = @_; $this->Start() unless $$this{_donestart}; my($type,$data) = MailScanner::Sendmail::ReadRecord($$this{_handle}); # p record handling by Glenn 2007-01-17 # assumption: ReadQf has already validated most of this queue file, so # skip the sanity checks. Just do the seeks as needed and read the next # record. Also, skip any deleted data records (type w). Could've done # this with recursion:-). while ($type eq 'p' || $type eq 'w') { seek $$this{_handle}, $data+0, 0 if ($type eq 'p' && $data+0 > 0); ($type,$data) = MailScanner::Sendmail::ReadRecord($$this{_handle}); } return undef if $type eq 'X'; return $data; } sub Done { my ($this) = @_; undef $$this{_handle}; $$this{_startpos} = -1; $$this{_donestart} = 0; } 1;