File Coverage

blib/lib/Mail/Box/File.pm

Criterion	Covered	Total	%
statement	217	251	86.4
branch	73	126	57.9
condition	35	66	53.0
subroutine	31	35	88.5
pod	14	16	87.5
total	370	494	74.9

# This code is part of Perl distribution Mail-Box version 4.01.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 2001-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later


package Mail::Box::File;{
our $VERSION = '4.01';
}

use parent 'Mail::Box';

use strict;
use warnings;

use Log::Report      'mail-box', import => [ qw/__x error fault trace warning/ ];

use Mail::Box::File::Message       ();
use Mail::Message::Body::Lines     ();
use Mail::Message::Body::File      ();
use Mail::Message::Body::Delayed   ();
use Mail::Message::Body::Multipart ();
use Mail::Message::Head            ();

use File::Copy            qw/move/;
use File::Spec::Functions qw/file_name_is_absolute catfile/;
use File::Basename        qw/dirname basename/;
use Scalar::Util          qw/blessed/;
#use POSIX                qw/:unistd_h/;

my $windows;
BEGIN { $windows = $^O =~ m/mswin32/i }

#--------------------

my $default_folder_dir = exists $ENV{HOME} ? $ENV{HOME} . '/Mail' : '.';

sub _default_body_type($$)
{	my $size = shift->guessBodySize || 0;
	'Mail::Message::Body::'.($size > 100000 ? 'File' : 'Lines');
}

sub init($)
{	my ($self, $args) = @_;
	$args->{folderdir} ||= $default_folder_dir;
	$args->{body_type} ||= \&_default_body_type;
	$args->{lock_file} ||= '--';   # to be resolved later
	$self->SUPER::init($args);

	my $class    = ref $self;
	my $filename = $self->{MBF_filename} = $self->folderToFilename($self->name, $self->folderdir);

	if(-e $filename) {;}    # Folder already exists
	elsif($args->{create} && $class->create($args->{folder}, %$args)) {;}
	else
	{	error __x"folder file {file} does not exist.", file => $filename;
	}

	$self->{MBF_policy}  = $args->{write_policy};

	# Lock the folder.

	my $locker   = $self->locker;

	my $lockfile = $locker->filename;
	if($lockfile eq '--')            # filename to be used not resolved yet
	{	my $lockdir   = $filename =~ s!/([^/]*)$!!r;
		my $extension = $args->{lock_extension} || '.lock';
		my $fn
		  = file_name_is_absolute($extension) ? $extension
		  : $extension =~ m!^\.!  ? "$filename$extension"
		  :    catfile($lockdir, $extension);

		$locker->filename($fn);
	}

	$locker->lock
		or error __x"cannot get a lock on {type} folder {name}.", type => $class, name => $self->name;

	# Check if we can write to the folder, if we need to.
	if($self->writable && ! -w $filename)
	{	warning __x"folder {name} file {file} is write-protected.", name => $self->name, file => $filename;
		$self->access('r');
	}

	# Start parser if reading is required.
	$self->parser if $self->access =~ m/r/;
	$self;
}


sub create($@)
{	my ($thingy, $name, %args) = @_;
	my $class     = ref $thingy      || $thingy;
	my $folderdir = $args{folderdir} || $default_folder_dir;
	my $subext    = $args{subfolder_extension};    # not always available
	my $filename  = $class->folderToFilename($name, $folderdir, $subext);

	return $class if -f $filename;

	my $dir       = dirname $filename;
	if(-f $dir && defined $subext)
	{	$dir      .= $subext;
		$filename  = catfile $dir, basename $filename;
	}

	-d $dir || mkdir $dir, 0755
		or fault __x"cannot create directory {dir} for folder $name: $!", dir => $dir, name => $name;

	$class->moveAwaySubFolder($filename, $subext)
		if -d $filename && defined $subext;

	open my $create, '>:raw', $filename
		or fault __x"cannot create folder file {file}", file => $filename;

	trace "Created folder $name in $filename.";
	$create->close or return;
	$class;
}

#--------------------

sub filename() { $_[0]->{MBF_filename} }

sub foundIn($@)
{	my $class = shift;
	my $name  = @_ % 2 ? shift : undef;
	my %args  = @_;
	$name   ||= $args{folder} or return;

	my $folderdir = $args{folderdir} || $default_folder_dir;
	my $filename  = $class->folderToFilename($name, $folderdir);

	-f $filename;
}

sub organization() { 'FILE' }

sub size()
{	my $self = shift;
	$self->isModified ? $self->SUPER::size : -s $self->filename;
}

sub close(@)
{	my $self = $_[0];            # be careful, we want to set the calling
	undef $_[0];                 #    ref to undef, as the SUPER does.
	shift;

	my $rc = $self->SUPER::close(@_);

	if(my $parser = delete $self->{MBF_parser}) { $parser->stop }

	$rc;
}

#--------------------

sub appendMessages(@)
{	my $class  = shift;
	my %args   = @_;

	my @messages
	  = exists $args{message}  ? $args{message}
	  : exists $args{messages} ? @{$args{messages}}
	  :   return ();

	my $folder   = $class->new(lock_type => 'NONE', @_, access => 'w+')
		or return ();

	my $filename = $folder->filename;
	open my $out, '>>', $filename
		or fault __x"cannot append messages to folder file {file}.", file => $filename;

	my $msgtype = $class.'::Message';
	my @coerced;

	foreach my $msg (@messages)
	{	my $coerced = $msg->isa($msgtype) ? $msg : $msgtype->coerce($msg->can('clone') ? $msg->clone : $msg);
		$coerced->write($out);
		push @coerced, $coerced;
	}

	my $ok = $folder->close;
	$out->close && $ok
		or return ();

	@coerced;
}

#--------------------

sub parser()
{	my $self   = shift;
	return $self->{MBF_parser} if defined $self->{MBF_parser};

	my $source = $self->filename;
	my $mode   = $self->access || 'r';
	$mode      = 'r+' if $mode eq 'rw' || $mode eq 'a';

	my $parser = $self->{MBF_parser} = Mail::Box::Parser->new(
		filename          => $source,
		mode              => $mode,
		trusted           => $self->isTrusted,
		fix_header_errors => $self->fixHeaders,
	);
	$parser->pushSeparator('From ');
	$parser;
}

sub readMessages(@)
{	my ($self, %args) = @_;

	$self->messageCreateOptions(
		$args{message_type},
		folder     => $self,
		head_type  => $args{head_type},
		field_type => $args{field_type},
		trusted    => $args{trusted},
	);

	$self->updateMessages;
}


sub updateMessages(@)
{	my ($self, %args) = @_;
	my $parser   = $self->parser or return;

	# On a directory, simulate an empty folder with only subfolders.
	my $filename = $self->filename;
	return $self if -d $filename;

	if(my $last  = $self->message(-1))
	{	(undef, my $end) = $last->fileLocation;
		$parser->filePosition($end);
	}

	my ($type, @msgopts) = $self->messageCreateOptions;
	my $count    = 0;

	while(1)
	{	my $message = $type->new(@msgopts);
		$message->readFromParser($parser) or last;
		$self->storeMessage($message);
		$count++;
	}

	trace "found $count new messages in $filename";
	$self;
}


sub messageCreateOptions(@)
{	my ($self, @options) = @_;
	if(@options)
	{	blessed $_ && (ref $_) =~ m/^Mail::/ && weaken $_ for @options;
		$self->{MBF_create_options} = \@options;
	}

	@{$self->{MBF_create_options}};
}


sub moveAwaySubFolder($$)
{	my ($self, $dir, $extension) = @_;

	move $dir, $dir.$extension
		or fault __x"cannot move away sub-folder {dir}", dir => $dir;

	$self;
}

sub delete(@)
{	my $self = shift;
	$self->SUPER::delete(@_);
	unlink $self->filename;
}


sub writeMessages($)
{	my ($self, $args) = @_;

	my $filename = $self->filename;
	if( ! @{$args->{messages}} && $self->removeEmpty)
	{	unlink $filename
			or warning __x"cannot remove folder {name} file {file}: {rc}", name => $self->name, file => $filename, rc => $!;
		return $self;
	}

	my $policy = exists $args->{policy} ? $args->{policy} : $self->{MBF_policy};
	$policy  ||= '';

	my $success
	  = ! -e $filename       ? $self->_write_new($args)
	  : $policy eq 'INPLACE' ? $self->_write_inplace($args)
	  : $policy eq 'REPLACE' ? $self->_write_replace($args)
	  : $self->_write_replace($args) ? 1
	  :    $self->_write_inplace($args);

	$success
		or error __x"unable to update folder {name}.", name => $self->name;

#   $self->parser->restart;
	$self;
}

sub _write_new($)
{	my ($self, $args) = @_;

	my $filename = $self->filename;
	open my $new, ">:raw", $filename
		or return 0;

	my $msgs = $args->{messages};
	$_->write($new) for @$msgs;
	$new->close or return 0;

	trace "Wrote new folder $self with ".@$msgs."msgs.";
	1;
}

# First write to a new file, then replace the source folder in one
# move.  This is much slower than inplace update, but it is safer,
# The folder is always in the right shape, even if the program is
# interrupted.

sub _write_replace($)
{	my ($self, $args) = @_;

	my $filename = $self->filename;
	my $tmpnew   = $self->tmpNewFolder($filename);

	open my $new, '>:raw', $tmpnew   or return 0;
	open my $old, '<:raw', $filename or return 0;

	my ($reprint, $kept) = (0,0);

	foreach my $message ( @{$args->{messages}} )
	{
		my $newbegin = $new->tell;
		my $oldbegin = $message->fileLocation;

		if($message->isModified)
		{	$message->write($new);
			$message->moveLocation($newbegin - $oldbegin) if defined $oldbegin;
			$reprint++;
			next;
		}

		my ($begin, $end) = $message->fileLocation;
		my $need = $end-$begin;

		$old->seek($begin, 0);
		my $whole;
		my $size = $old->read($whole, $need);

		$size == $need
			or error __x"file {name} too short to get write message {msgnr} ({size} < {expect})",
				msgnr => $message->seqnr, size => $size, expect => $need;

		$new->print($whole);
		$new->print($Mail::Message::crlf_platform ? "\r\n" : "\n");

		$message->moveLocation($newbegin - $oldbegin);
		$kept++;
	}

	my $ok = $new->close;
	$old->close && $ok
		or return 0;

	if($windows)
	{	# Windows does not like to move to existing filenames
		unlink $filename;

		# Windows cannot move to files which are opened.
		$self->parser->closeFile;
	}

	unless(move $tmpnew, $filename)
	{	unlink $tmpnew;
		fault __x"cannot replace {to} by {from} to update folder {name}", to => $filename, from => $tmpnew, name => $self->name;
	}

	trace "folder $self replaced ($kept, $reprint)";
	1;
}

# Inplace is currently very poorly implemented.  From the first
# location where changes appear, all messages are rewritten.

sub _write_inplace($)
{	my ($self, $args) = @_;

	my @messages = @{$args->{messages}};
	my $last;

	my ($msgnr, $kept) = (0, 0);
	while(@messages)
	{	my $next = $messages[0];
		last if $next->isModified || $next->seqnr!=$msgnr++;
		$last    = shift @messages;
		$kept++;
	}

	if(@messages==0 && $msgnr==$self->messages)
	{	trace "No changes to be written to $self.";
		return 1;
	}

	$_->body->load for @messages;

	my $mode     = $^O eq 'MSWin32' ? '>>:raw' : '+<:raw';
	my $filename = $self->filename;
	open my $old, $mode, $filename or return 0;

	# Chop the folder after the messages which does not have to change.

	my $end = defined $last ? ($last->fileLocation)[1] : 0;

	$end =~ m/(.*)/;  # untaint, only required by perl5.6.1
	$end = $1;

	unless($old->truncate($end))
	{	# truncate impossible: try replace writing
		$old->close;
		return 0;
	}

	unless(@messages)
	{	# All further messages only are flagged to be deleted
		$old->close or return 0;
		trace "Folder $self shortened in-place ($kept kept)";
		return 1;
	}

	# go to the end of the truncated output file.
	$old->seek(0, 2);

	# Print the messages which have to move.
	my $printed = @messages;
	foreach my $message (@messages)
	{	my $oldbegin = $message->fileLocation;
		my $newbegin = $old->tell;
		$message->write($old);
		$message->moveLocation($newbegin - $oldbegin);
	}

	$old->close or return 0;
	trace "Folder $self updated in-place ($kept, $printed)";
	1;
}


sub folderToFilename($$;$)
{	my ($thing, $name, $folderdir) = @_;

	substr $name, 0, 1, $folderdir
		if substr $name, 0, 1 eq '=';

	$name;
}

sub tmpNewFolder($) { $_[0]->filename . '.tmp' }

#--------------------

1;