
use strict;
use warnings;

package Mail::Box::IMAP4;
use vars '$VERSION';
$VERSION = '2.055';
use base 'Mail::Box::Net';

use Mail::Box::IMAP4::Message;
use Mail::Box::IMAP4::Head;
use Mail::Transport::IMAP4;

use Mail::Box::Parser::Perl;
use Mail::Message::Head::Complete;
use Mail::Message::Head::Delayed;

use Scalar::Util 'weaken';


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

    # Need some prediction for correct defaults
    my $access    = $args->{access} ||= 'r';
    my $writeable = $access =~ m/w|a/;
    my $ch        = $self->{MBI_c_head}
      = $args->{cache_head} || ($writeable ? 'NO' : 'DELAY');

    $args->{head_type} ||= 'Mail::Box::IMAP4::Head'
       if $ch eq 'NO' || $ch eq 'PARTIAL';

    $args->{body_type}  ||= 'Mail::Message::Body::Lines';

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

    $self->{MBI_domain}   = $args->{domain};
    $self->{MBI_c_labels} = $args->{cache_labels}
                         || ($writeable  ? 'NO' : 'DELAY');
    $self->{MBI_c_body}   = $args->{cache_body}
                         || ($writeable ? 'NO' : 'DELAY');


    my $transport = $args->{transporter} || 'Mail::Transport::IMAP4';
    unless(ref $transport)
    {   eval "require $transport";
        $self->log(ERROR => "Cannot install transporter $transport:\n$@\n"),
           return () if $@;

        $transport = $self->createTransporter($transport, %$args)
	    or return undef;
    }

    $self->transporter($transport);
    $self;
}

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

sub create($@)
{   my ($class, %args) =  @_;
    $class->log(INTERNAL => "Folder creation for IMAP4 not implemented yet");
    undef;
}

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

sub foundIn(@)
{   my $self = shift;
    unshift @_, 'folder' if @_ % 2;
    my %options = @_;

       (exists $options{type}   && $options{type}   =~ m/^imap/i)
    || (exists $options{folder} && $options{folder} =~ m/^imap/);
}

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

sub type() {'imap4'}

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


sub close(@)
{   my $self = shift;
    $self->SUPER::close(@_) or return ();
    $self->transporter(undef);
    $self;
}

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

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

    $self = $thing->new(%args) or return ()  # list toplevel
        unless ref $thing;

    my $imap = $self->transporter;
    defined $imap ? $imap->folders($self) : ();
}

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

sub nameOfSubfolder($)
{   my ($self, $name) = @_;
    $name;
}

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


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

    my $name  = $self->name;
    return $self if $name eq '/';

    my $imap  = $self->transporter;
    my @log   = $self->logSettings;
    my $seqnr = 0;

    my $cl    = $self->{MBI_c_labels} ne 'NO';
    my $wl    = $self->{MBI_c_labels} ne 'DELAY';

    my $ch    = $self->{MBI_c_head};
    my $ht    = $ch eq 'DELAY' ? $args{head_delayed_type} : $args{head_type};
    my @ho    = $ch eq 'PARTIAL' ? (cache_fields => 1) : ();

    foreach my $id ($imap->ids)
    {   my $head    = $ht->new(@log, @ho);
        my $message = $args{message_type}->new
         ( head      => $head
         , unique    => $id
         , folder    => $self
         , seqnr     => $seqnr++

	 , cache_labels => $cl
	 , write_labels => $wl
         , cache_head   => ($ch eq 'DELAY')
         , cache_body   => ($ch ne 'NO')
         );

        my $body    = $args{body_delayed_type}
           ->new(@log, message => $message);

        $message->storeBody($body);

        $self->storeMessage($message);
    }

    $self;
}
 
#-------------------------------------------


sub getHead($)
{   my ($self, $message) = @_;
    my $imap   = $self->transporter or return;

    my $uidl   = $message->unique;
    my @fields = $imap->getFields($uidl, 'ALL');

    unless(@fields)
    {   $self->log(WARNING => "Message $uidl disappeared from $self.");
        return;
    }

    my $head = $self->{MB_head_type}->new;
    $head->addNoRealize($_) for @fields;

    $self->log(PROGRESS => "Loaded head of $uidl.");
    $head;
}

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


sub getHeadAndBody($)
{   my ($self, $message) = @_;
    my $imap  = $self->transporter or return;
    my $uid   = $message->unique;
    my $lines = $imap->getMessageAsString($uid);

    unless(defined $lines)
    {   $self->log(WARNING => "Message $uid disappeared from $self.");
        return ();
     }

    my $parser = Mail::Box::Parser::Perl->new   # not parseable by C parser
     ( filename  => "$imap"
     , file      => Mail::Box::FastScalar->new(\$lines)
     );

    my $head = $message->readHead($parser);
    unless(defined $head)
    {   $self->log(WARNING => "Cannot find head back for $uid in $self.");
        $parser->stop;
        return ();
    }

    my $body = $message->readBody($parser, $head);
    unless(defined $body)
    {   $self->log(WARNING => "Cannot read body for $uid in $self.");
        $parser->stop;
        return ();
    }

    $parser->stop;

    $self->log(PROGRESS => "Loaded message $uid.");
    ($head, $body->contentInfoFrom($head));
}

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


sub body(;$)
{   my $self = shift;
    unless(@_)
    {   my $body = $self->{MBI_cache_body} ? $self->SUPER::body : undef;
    }

    $self->unique();
    $self->SUPER::body(@_);
}

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



sub write(@)
{   my ($self, %args) = @_;
    my $imap  = $self->transporter or return;

    $self->SUPER::write(%args, transporter => $imap) or return;

    if($args{save_deleted})
    {   $self->log(NOTICE => "Impossible to keep deleted messages in IMAP")
    }
    else { $imap->destroyDeleted }

    $self;
}

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


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

    my $imap = $args->{transporter};
    my $fn   = $self->name;

    $_->writeDelayed($fn, $imap) for @{$args->{messages}};

    $self;
}

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


my %transporters;
sub createTransporter($@)
{   my ($self, $class, %args) = @_;

    my $hostname = $self->{MBN_hostname} || 'localhost';
    my $port     = $self->{MBN_port}     || '143';
    my $username = $self->{MBN_username} || $ENV{USER};

    my $join     = exists $args{join_connection} ? $args{join_connection} : 1;

    my $linkid;
    if($join)
    {   $linkid  = "$hostname:$port:$username";
        return $transporters{$linkid} if defined $transporters{$linkid};
    }

    my $transporter = $class->new
     ( %args,
     , hostname => $hostname, port     => $port
     , username => $username, password => $self->{MBN_password}
     , domain   => $self->{MBI_domain}
     ) or return undef;

    if(defined $linkid)
    {   $transporters{$linkid} = $transporter;
        weaken($transporters{$linkid});
    }

    $transporter;
}

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


sub transporter(;$)
{   my $self = shift;
    my $imap = @_ ? ($self->{MBI_transport} = shift) : $self->{MBI_transport};
    return unless defined $imap;

    my $name = $self->name;
    $imap->folder($name) unless $name eq '/';

    $imap;
}

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


sub fetch($@)
{   my ($self, $what, @info) = @_;
    my $imap = $self->transporter or return [];
    $what = $self->messages($what) unless ref $what eq 'ARRAY';
    $imap->fetch($what, @info);
}

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


1;
