libmail-box-perl 2.117-1 / usr / share / perl5 / Mail / Box / Dbx.pm

# Copyrights 2001-2014 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.01.

use strict;
package Mail::Box::Dbx;
use vars '$VERSION';
$VERSION = '2.117';

use base 'Mail::Box::File';

use Mail::Box::Dbx::Message;
use Mail::Message::Head::Delayed;
use Mail::Message::Body::Delayed;

use Mail::Transport::Dbx 0.04;
use File::Basename 'dirname';


my $default_folder_dir    = '.';

sub init($)
{   my ($self, $args) = @_;
    $args->{folder}     ||= '=Folders.dbx';
    $args->{folderdir}  ||= $default_folder_dir;
    $args->{lock_type}  ||= 'NONE';

    $self->SUPER::init($args) or return;

    $self->log(WARNING => "Dbx folders are read-only.")
        if $self->writable;

    $self;
}


sub create($@) {  shift->notImplemented }


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

    $name   ||= $args{folder} or return;
    $name =~ m/\.dbx$/i;
}

sub writeMessages($) { shift->notImplemented }
sub appendMessages($) { shift->notImplemented }
sub type() { 'dbx' }

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

    my @log      =  $self->logSettings;
    my @msgopts  =
     ( @log
     , folder     => $self
     , head_type  => $args{head_type}
     , field_type => $args{field_type}
     , trusted    => $args{trusted}
     );

    my $parser    = $self->parser
        or return;

    my $head_type = $self->{MB_head_delayed_type};
    my $body_type = $self->{MB_body_delayed_type};

    foreach my $record ($parser->emails)
    {   my $head    = $head_type->new(@log);

        my $message = $args{message_type}->new
          ( @msgopts
          , dbx_record => $record
          , head       => $head_type->new(@log)
          ) or next;

        $message->storeBody($body_type->new(@log, message => $message));
        $self->storeMessage($message);
    }

    $self;
}

sub updateMessages() { shift }

sub nameOfSubFolder($;$)
{   my $thing  = shift;
    my $name   = (shift). '.dbx';
    my $parent = @_ ? shift : ref $thing ? $thing->filename : undef;
    defined $parent ?  File::Spec->catfile(dirname($parent), $name) : $name;
}


sub listSubFolders(@)
{   my ($thingy, %args)  = @_;
    my $self       = ref $thingy ? $thingy : $thingy->new;
    my $skip_empty = $args{skip_empty} || 0;
    my $check      = $args{check}      || 0;

    my $parser     = $self->parser
       or return;

    my @subs       = map { $_->name } $parser->subfolders;

    if($args{check})
    {    my $dir   = dirname $self->filename;
         @subs     = grep { -f File::Spec->catfile($dir, $_.'.dbx') } @subs;
    }

    return @subs unless $skip_empty;

    my @filled;
    foreach my $sub (@subs)
    {   my $f = $self->openSubFolder($sub, lock_type => 'NONE');
        push @filled, $f if defined $f && scalar($f->messages);
    }
    @filled;
}

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


sub folderToFilename($$)
{   my ($thingy, $name, $folderdir) = @_;
    return $name if File::Spec->file_name_is_absolute($name);
    $name     =~ s#^=#$folderdir/#;
    $name;
}


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

    my $filename = $self->filename;
    my $parser   = eval { Mail::Transport::Dbx->new($filename) };

    unless(defined $parser)
    {   $self->log(ERROR => "Cannot read dbx folder file $filename.");
        return undef;
    }

    $self->{MBD_parser} = $parser;
}

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


1;