Mail-Box-IMAP4-3.009/0000755000175000001440000000000015000516376014466 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/t/0000755000175000001440000000000015000516376014731 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/t/20server-fetch.t0000644000175000001440000001410015000515707017646 0ustar00markovusers00000000000000#!/usr/bin/env perl # # Test body-structure capturing for IMAP servers use strict; use warnings; use Mail::Box::Test; use Mail::Message; use Mail::Message::Body::Lines; use Mail::Server::IMAP4::Fetch; use Test::More tests => 44; my $msif = 'Mail::Server::IMAP4::Fetch'; my $msg = Mail::Message->build ( From => 'I myself and me ' , To => 'you@example.com' , Date => 'now' , Subject => 'Life of Brian' , 'Message-ID' => 'unique' , data => [ "two\n", "lines\n" ] ); ok($msg, "First, simple message built"); my $f = $msif->new($msg); isa_ok($f, $msif); ok($f->part() == $f); ok(!defined $f->part('1')); #use Data::Dumper; #print Dumper $f; is($f->fetchBody(0)."\n", <<__BODY, '...body'); ("TEXT" "PLAIN" ("charset" "us-ascii") "" NIL "8BIT" 10 2) __BODY is($f->fetchBody(1)."\n", <<__BODYSTRUCT, '...bodystruct'); ("TEXT" "PLAIN" ("charset" "us-ascii") "" NIL "8BIT" 10 2 NIL ("inline") NIL) __BODYSTRUCT is($f->fetchEnvelope."\n", <<__ENVELOPE, '...envelope'); ("now" "Life of Brian" ("I myself and me" NIL "me" "localhost") NIL NIL (NIL NIL "you" "example.com") NIL NIL NIL "") __ENVELOPE # # Simple multipart # my $data = Mail::Message::Body::Lines->new ( mime_type => 'audio/mpeg3' , transfer_encoding => 'base64' , charset => 'utf8' , data => "ABBA\n" ); my $mp = Mail::Message->build ( From => 'me' , Date => 'now' , Subject => 'multi' , 'Message-ID' => 'unique' , data => [ "two\n", "lines\n" ] , attach => $data ); ok(defined $mp, "Simple multipart"); $f = $msif->new($mp); isa_ok($f, $msif); ok($f->part() == $f); is($f->fetchBody(0)."\n", <<__BODY, '...body'); (("TEXT" "PLAIN" ("charset" "us-ascii") NIL NIL "8BIT" 10 2)("AUDIO" "MPEG3" () NIL NIL "BASE64" 5 1) "MIXED") __BODY is($f->fetchBody(1)."\n", <<__BODYSTRUCT, '...bodystruct'); (("TEXT" "PLAIN" ("charset" "us-ascii") NIL NIL "8BIT" 10 2 NIL ("inline") NIL)("AUDIO" "MPEG3" () NIL NIL "BASE64" 5 1 NIL ("attachment") NIL) "MIXED") __BODYSTRUCT is($f->fetchEnvelope."\n", <<__ENVELOPE, '...envelope'); ("now" "multi" NIL NIL NIL NIL NIL NIL NIL "") __ENVELOPE ok($f->part('1'), "Has two parts"); ok($f->part('2')); ok(!$f->part('3')); ok(!$f->part('1.1')); my $g = $f->part('2'); isa_ok($g, $msif); is($g->fetchBody(0)."\n", <<__BODY, '...body'); ("AUDIO" "MPEG3" () NIL NIL "BASE64" 5 1) __BODY is($g->fetchBody(1)."\n", <<__BODYSTRUCT, '...bodystruct'); ("AUDIO" "MPEG3" () NIL NIL "BASE64" 5 1 NIL ("attachment") NIL) __BODYSTRUCT is($g->fetchEnvelope."\n", <<__ENVELOPE, '...envelope'); (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) __ENVELOPE # # All fields in an envelope # my $a = Mail::Message->build ( From => 'FROM ' , To => 'TO ' , Cc => 'CC ' , Bcc => 'BCC ' , Sender => 'SENDER ' , 'Reply-To' => 'RT ' , Date => 'today' , Subject => 'subject' , 'Content-Type' => 'video/vhs' , 'Content-Disposition' => 'attachment; filename="private-video.ras"; size=100' , 'Content-Language' => 'nl-NL, nl-BE' , 'Content-Description' => 'blue movie' , 'Message-ID' => 'unique-id-123' , data => "BINARY data for video" ); ok(defined $a, "Full envelope"); #$a->print(\*STDERR); ##### get should become study ## my $s = $a->study('Content-Disposition'); ## isa_ok($s, 'Mail::Message::Field::Structured'); my $s = $a->head->get('Content-Disposition'); isa_ok($s, 'Mail::Message::Field'); is($s->attribute('filename'), 'private-video.ras', '...one attr'); my %attrs = $s->attributes; cmp_ok(keys %attrs, '==', 2, '...nr attrs'); is($attrs{filename}, 'private-video.ras', '...filename'); is($attrs{size}, 100, '...size'); $f = $msif->new($a); isa_ok($f, $msif); is($f->fetchBody(0)."\n", <<__BODY, "...body"); ("VIDEO" "VHS" () "" "blue movie" "BASE64" 29 1) __BODY is($f->fetchBody(1)."\n", <<__BODYSTRUCT, "...bodystruct"); ("VIDEO" "VHS" () "" "blue movie" "BASE64" 29 1 NIL ("attachment" "filename" "private-video.ras" "size" "100") "nl-NL, nl-BE") __BODYSTRUCT is($f->fetchEnvelope."\n", <<__ENVELOPE, "...envelope"); ("today" "subject" ("FROM" NIL "from" "from.home") ("SENDER" NIL "sender" "sender.home") ("RT" NIL "replyto" "rt.home") ("TO" NIL "to" "to.home") ("CC" NIL "cc" "cc.home") ("BCC" NIL "bcc" "bcc.home") NIL "") __ENVELOPE # # Nested # my $b = Mail::Message->build ( To => 'someelse@somewhere.aq' , 'Message-Id' => 'newid' , Date => 'tomorrow' , attach => $msg ); ok(defined $b, "Constructed nested message"); isa_ok($b, 'Mail::Message'); ok($b->isNested, 'check structure'); $f = $msif->new($b); isa_ok($f, $msif); #$b->print(\*STDERR); is($f->fetchBody(0)."\n", <<__BODY, "...body"); ("MESSAGE" "RFC822" () "" NIL "8BIT" 215 ("now" "Life of Brian" ("I myself and me" NIL "me" "localhost") NIL NIL (NIL NIL "you" "example.com") NIL NIL NIL "") ("TEXT" "PLAIN" ("charset" "us-ascii") "" NIL "8BIT" 10 2) 11) __BODY is($f->fetchBody(1)."\n", <<__BODYSTRUCT, "...bodystruct"); ("MESSAGE" "RFC822" () "" NIL "8BIT" 215 ("now" "Life of Brian" ("I myself and me" NIL "me" "localhost") NIL NIL (NIL NIL "you" "example.com") NIL NIL NIL "") ("TEXT" "PLAIN" ("charset" "us-ascii") "" NIL "8BIT" 10 2 NIL ("inline") NIL) 11 NIL ("inline") NIL) __BODYSTRUCT is($f->fetchEnvelope."\n", <<__ENVELOPE, "...envelope"); ("tomorrow" NIL NIL NIL NIL (NIL NIL "someelse" "somewhere.aq") NIL NIL NIL "") __ENVELOPE #$b->print(\*STDERR); $g = $f->part('1'); ok(defined $g, "nested info"); isa_ok($g, $msif); ok($f != $g); is($g->fetchBody(0)."\n", <<__BODY, "...body"); ("TEXT" "PLAIN" ("charset" "us-ascii") "" NIL "8BIT" 10 2) __BODY is($g->fetchBody(1)."\n", <<__BODYSTRUCT, "...bodystruct"); ("TEXT" "PLAIN" ("charset" "us-ascii") "" NIL "8BIT" 10 2 NIL ("inline") NIL) __BODYSTRUCT is($g->fetchEnvelope."\n", <<__ENVELOPE, "...envelope"); ("now" "Life of Brian" ("I myself and me" NIL "me" "localhost") NIL NIL (NIL NIL "you" "example.com") NIL NIL NIL "") __ENVELOPE Mail-Box-IMAP4-3.009/t/11client-write.t0000644000175000001440000000531715000515707017671 0ustar00markovusers00000000000000#!/usr/bin/env perl # # Test reading of IMAP4 folders. # The environment has some requirements: # On Debian: # adduser -d /tmp/imaptest imaptest # /etc/cram-md5.pwd: # imaptesttestje # touch /var/mail/imaptest # chown $USER /var/mail/imaptest # user running the tests # .... and a running imapd # # On SuSE 8.2 # useradd -d /tmp/imaptest imaptest # /etc/cram-md5.pwd: # imaptesttestje # touch /var/spool/mail/imaptest # chown $USER /var/spool/mail/imaptest # user running the tests # .... and a running imapd, which requires the start of xinetd and # enabling the imap service via YaST2 use strict; use warnings; use Mail::Box::Test; use Mail::Box::IMAP4; use Test::More; use File::Compare; use File::Copy; use File::Spec::Functions; BEGIN { unless($ENV{MARKOV_DEVEL}) { plan skip_all => 'Only tested on markov\'s platform'; } plan tests => 18; } my $user = 'imaptest'; my $password = 'testje'; my $server = 'localhost'; my $port = 143; my @connect = ( username => $user, password => $password , server_name => $server, server_port => $port ); my $home = "/tmp/$user"; my $inbox = "/var/mail/$user"; # Prepare home directory -d $home or mkdir $home or die "Cannot create $home: $!\n"; # Prepare INBOX copy $unixsrc, $inbox or die "Cannot create $inbox: $!\n"; # # The folder is read. # my $folder = Mail::Box::IMAP4->new ( @connect , folder => 'INBOX' , lock_type => 'NONE' , access => 'rw' ); ok(defined $folder, 'check success open folder'); exit 1 unless defined $folder; ok($folder->writeable); cmp_ok($folder->messages , "==", 45, 'found all messages'); my $msg = Mail::Message->build(From => 'me', data => "Hi\n"); ok(defined $msg, 'build new message to append'); isa_ok($msg, 'Mail::Message'); my $m = $folder->addMessage($msg); isa_ok($m, 'Mail::Box::IMAP4::Message', 'coercion successful'); isa_ok($msg, 'Mail::Box::IMAP4::Message'); ok(!defined $m->unique, 'ids only for "native" messages'); cmp_ok($folder->messages , "==", 46, 'found the new message'); # # Play around with the message, and see nothing breaks # ok($m->label('reply' => 1)); ok($m->label('reply')); ok($m->label('reply' => 0)); ok(!$m->label('reply')); is($m->get('From'), 'me'); is($m->body->string, "Hi\n"); # Now try to save it, and reopen ok($folder->close, 'closing folder'); $folder = Mail::Box::IMAP4->new ( @connect , folder => 'INBOX' , lock_type => 'NONE' , access => 'r' ); ok(defined $folder, 'check success re-open folder'); cmp_ok($folder->messages , "==", 46, 'found one more messages'); Mail-Box-IMAP4-3.009/t/21server-list.t0000644000175000001440000001327415000515707017544 0ustar00markovusers00000000000000#!/usr/bin/env perl # Test list command for IMAP servers # # A lot of the basic administration handling is tested in 52manager/30collect.t use strict; use warnings; use File::Temp (); use Mail::Box::MH; use Mail::Box::Identity; use Mail::Server::IMAP4::List; use Test::More tests => 41; my $msil = 'Mail::Server::IMAP4::List'; my $mbi = 'Mail::Box::Identity'; my @boxes = qw( a1 a1/b1 a1/b2 a1/b2/c1 a1/b2/c2 a1/b2/c3 a1/b2/c3/d1 a1/b2/c3/d2 a1/b3 a2 a3 ); # Create the directory hierarchy my $top = File::Temp->newdir; foreach my $box (@boxes) { my $dir = "$top/$box"; mkdir $dir or die "$dir: $!"; } # Create the top object my $folders = $mbi->new ( name => '=' , folder_type => 'Mail::Box::MH' , only_subs => 1 ); ok(defined $folders, "Created the top folder"); isa_ok($folders, $mbi); # Load the structure my $count = 0; sub setloc($) { my $node = shift; my $full = $node->fullname; $full =~ s/^\=/$top/; $node->location($full); $count++; } $folders->foreach(\&setloc); cmp_ok($count, '==', @boxes+1, "Succesfully expanded"); ok($folders->onlySubfolders, "top without msgs"); my $a1 = $folders->folder('a1'); ok(defined $a1, "found $a1"); ok(!$a1->onlySubfolders, "other with msgs"); # # Let's do the simple LIST check. # sub str(@) { return '' unless @_; my @lines; foreach my $record (@_) { my($flags, $delim, $rest) = @$record; $rest = '""' unless length $rest; push @lines, "$flags \"$delim\" $rest\n"; } join '', @lines; } my $imap = $msil->new(folders => $folders, delimiter => '#'); isa_ok($imap, $msil); is(str($imap->list('', '')), <<'__DELIM', 'as for delim'); (\Noselect) "#" "" __DELIM is(str($imap->list('#', 'a1')), <<'__DELIM'); () "#" #a1 __DELIM $folders->folder('a1')->deleted(1); is(str($imap->list('#', 'a1')), <<'__DELIM'); (\Noselect) "#" #a1 __DELIM $folders->folder('a1')->deleted(0); is(str($imap->list('#', 'a1')), <<'__DELIM'); () "#" #a1 __DELIM $folders->folder('a1')->onlySubfolders(1); is(str($imap->list('#', 'a1')), <<'__DELIM'); (\Noselect) "#" #a1 __DELIM $folders->folder('a1')->marked(1); is(str($imap->list('#', 'a1')), <<'__DELIM', 'marked'); (\Noselect \Marked) "#" #a1 __DELIM $folders->folder('a1')->marked(0); is(str($imap->list('#', 'a1')), <<'__DELIM', 'unmarked'); (\Noselect \Unmarked) "#" #a1 __DELIM $folders->folder('a1')->marked(undef); is(str($imap->list('#', 'a1')), <<'__DELIM', 'not marked'); (\Noselect) "#" #a1 __DELIM is(str($imap->list('a1', 'b1')), <<'__DELIM', 'straight forward'); () "#" #a1#b1 __DELIM is(str($imap->list('a1', 'none')), <<'__DELIM', 'missing'); __DELIM is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'stacking'); () "#" #a1#b2#c3 __DELIM # # Flags # my $abc = $folders->folder('a1', 'b2', 'c3'); ok(defined $abc, 'got abc'); $abc->marked(1); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc marked'); (\Marked) "#" #a1#b2#c3 __DELIM $abc->marked(0); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc unmarked'); (\Unmarked) "#" #a1#b2#c3 __DELIM $abc->marked(undef); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc undef marked'); () "#" #a1#b2#c3 __DELIM $abc->inferiors(0); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc no inferiors'); (\Noinferiors) "#" #a1#b2#c3 __DELIM $abc->inferiors(1); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc inferiors'); () "#" #a1#b2#c3 __DELIM $abc->inferiors(0); $abc->marked(1); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc inferiors'); (\Noinferiors \Marked) "#" #a1#b2#c3 __DELIM $abc->inferiors(1); $abc->marked(1); is(str($imap->list('a1#b2', 'c3')), <<'__DELIM', 'abc inferiors'); (\Marked) "#" #a1#b2#c3 __DELIM # # Now for some real searching # is(str($imap->list('a1#none', '%')), <<'__DELIM', 'find none %'); __DELIM is(str($imap->list('a1#none', '*')), <<'__DELIM', 'find none *'); __DELIM is(str($imap->list('a1#b1', '%')), <<'__DELIM', 'find here %'); () "#" #a1#b1 __DELIM is(str($imap->list('a1#b1', '*')), <<'__DELIM', 'find here *'); () "#" #a1#b1 __DELIM is(str($imap->list('a1#b2', '%')), <<'__DELIM', 'find none %'); () "#" #a1#b2#c1 () "#" #a1#b2#c2 (\Marked) "#" #a1#b2#c3 __DELIM is(str($imap->list('a1#b2', '*')), <<'__DELIM', 'find none *'); () "#" #a1#b2 () "#" #a1#b2#c1 () "#" #a1#b2#c2 (\Marked) "#" #a1#b2#c3 () "#" #a1#b2#c3#d1 () "#" #a1#b2#c3#d2 __DELIM is(str($imap->list('a1', '%#b3')), <<'__DELIM', 'find inside %'); __DELIM is(str($imap->list('a1', '*#b3')), <<'__DELIM', 'find inside *'); () "#" #a1#b3 __DELIM is(str($imap->list('a1', 'b2#*')), <<'__DELIM', 'find inside *'); () "#" #a1#b2 () "#" #a1#b2#c1 () "#" #a1#b2#c2 (\Marked) "#" #a1#b2#c3 () "#" #a1#b2#c3#d1 () "#" #a1#b2#c3#d2 __DELIM is(str($imap->list('a1', '*#c2')), <<'__DELIM', 'find inside *'); () "#" #a1#b2#c2 __DELIM is(str($imap->list('a1', '*#d2')), <<'__DELIM', 'find inside *'); () "#" #a1#b2#c3#d2 __DELIM # # Complicated delimiter, as defined by the RFC. Examples in 6.3.8 # sub combi_delim($) { my $path = shift; my ($delim, $root) = $path =~ m/^(#news\.)/ ? ('.', $1) : $path =~ m!^/! ? ('/', '/') : ('/', ''); wantarray ? ($delim, $root) : $delim; } $folders->onlySubfolders(0); ok(! $folders->onlySubfolders); $imap = $msil->new(folders => $folders, delimiter => \&combi_delim); is(str($imap->list('', '')), <<'__DELIM', 'combi delim'); (\Noselect) "/" "" __DELIM is(str($imap->list('#news.comp.mail.misc', '')), <<'__DELIM'); (\Noselect) "." #news. __DELIM is(str($imap->list('/usr/staff/jones', '')), <<'__DELIM'); (\Noselect) "/" / __DELIM Mail-Box-IMAP4-3.009/t/10client-read.t0000644000175000001440000001105315000515707017443 0ustar00markovusers00000000000000#!/usr/bin/env perl # # Test reading of IMAP4 folders. # The environment has some requirements: # On Debian: # adduser -d /tmp/imaptest imaptest # /etc/cram-md5.pwd: # imaptesttestje # touch /var/mail/imaptest # chown imaptest.users /var/mail/imaptest # chmod 0664 /var/mail/imaptest # user running the tests # .... and a running imapd # # On SuSE 8.2 # useradd -d /tmp/imaptest imaptest # /etc/cram-md5.pwd: # imaptesttestje # touch /var/spool/mail/imaptest # chown imaptest.users /var/mail/imaptest # chmod 0664 /var/mail/imaptest # user running the tests # .... and a running imapd, which requires the start of xinetd and # enabling the imap service via YaST2 use strict; use warnings; use Mail::Box::Test; use Mail::Box::IMAP4; use Test::More; use File::Compare; use File::Copy; use File::Spec::Functions; BEGIN { $ENV{MARKOV_DEVEL} or plan skip_all => 'Only tested on markov\'s platform'; plan tests => 40; } my $user = 'imaptest'; my $password = 'testje'; my $server = 'localhost'; my $port = 143; my @connect = ( username => $user, password => $password , server_name => $server, server_port => $port ); my $home = "/tmp/$user"; my $inbox = "/var/mail/$user"; # Prepare home directory -d $home or mkdir $home or die "Cannot create $home: $!\n"; # Prepare INBOX my $src = "../Mail-Box/$unixsrc"; copy $src, $inbox or die "Cannot create $inbox: $!\n"; ok(Mail::Box::IMAP4->foundIn(folder => 'imap://'), 'check foundIn'); # # The folder is read. # my $folder = Mail::Box::IMAP4->new ( @connect , folder => 'INBOX' , lock_type => 'NONE' , cache_labels => 'YES' ); ok(defined $folder, 'check success open folder'); exit 1 unless defined $folder; isa_ok($folder, 'Mail::Box::IMAP4'); cmp_ok($folder->messages , "==", 45, 'found all messages'); is($folder->organization, 'REMOTE', 'folder organization NET'); # # Take one message. # my $message = $folder->message(2); ok(defined $message, 'take one message'); isa_ok($message, 'Mail::Box::Message'); isa_ok($message, 'Mail::Box::IMAP4::Message'); ok($message->head->isDelayed); cmp_ok($message->recvstamp, '==', 950134500, 'try recvstamp'); cmp_ok($message->size, '==', 3931, 'try fetch size'); ok($message->head->isDelayed, 'still delayed'); # # Take a few messages. # my @some = $folder->messages(3,7); cmp_ok(@some, "==", 5, 'take range of messages'); isa_ok($some[0], 'Mail::Box::Message'); isa_ok($some[0], 'Mail::Box::IMAP4::Message'); # # None of the messages is parsed, yet # my $parsed = 0; $parsed ||= $_->isParsed foreach $folder->messages; cmp_ok($parsed, '==', 0, 'no messages parsed'); # # Load a message # my $m34 = $folder->message(34); ok($m34->isDelayed, 'msg 34 delayed'); ok($m34->head->isDelayed, 'head delayed'); ok($m34->body->isDelayed, 'body delayed'); isa_ok($m34->head, 'Mail::Message::Head::Delayed'); isa_ok($m34->body, 'Mail::Message::Body::Delayed'); my $s = $m34->body->string; $s =~ s/\r\n/\n/g; is($s, "subscribe magick-developer\n", 'simple body'); # # Try to delete a message # ok(!$folder->message(2)->deleted, 'msg 2 not yet deleted'); $folder->message(2)->delete; ok($folder->message(2)->deleted, 'msg 2 flagged for deletion'); cmp_ok($folder->messages , "==", 45, 'deletion not performed yet'); cmp_ok($folder->messages('ACTIVE') , "==", 44, 'less messages ACTIVE'); cmp_ok($folder->messages('DELETED') , "==", 1, 'more messages DELETED'); my $replied = 0; $_->label('replied') && $replied++ for $folder->messages; cmp_ok($replied, '==', 12, 'read replied flags'); $folder->message(0)->label(replied => 1); $replied = 0; $_->label('replied') && $replied++ for $folder->messages; cmp_ok($replied, '==', 13, 'set replied flag'); # # Take a message # my $m = $folder->message(8); ok(defined $m, 'take message 8'); ok($m->isDelayed); ok($m->head->isDelayed); ok($m->body->isDelayed); my $subject = $m->subject; is($subject, 'Resize with Transparency', 'realized 8'); isa_ok($m->head, 'Mail::Message::Head::Complete'); ok($m->body->isDelayed); my $body = $m->body; ok($body->isDelayed, 'got some body'); $s = $body->string; ok(defined $s, 'got a string'); $s =~ s/\r//g; is(substr($s, 0, 19), "\nHi,\n\nMaybe someone"); isa_ok($body, 'Mail::Message::Body'); $folder->close(write => 'NEVER'); exit 0; Mail-Box-IMAP4-3.009/t/12client-flags.t0000644000175000001440000000576615000515707017644 0ustar00markovusers00000000000000#!/usr/bin/env perl # # Test flags conversion of IMAP4 folders. use strict; use warnings; use Mail::Box::Test; use Mail::Transport::IMAP4; use Test::More tests => 65; my $mti = 'Mail::Transport::IMAP4'; ### ### Checking labels2flags ### sub expect_flags($$$) { my ($got, $expect, $text) = @_; my $errors = 0; my %got; $got{$_}++ for split " ", $got; if(grep {$_ > 1} values %got) { $errors++; ok(0, "found double, $text"); } else { ok(1, $text); } foreach my $e (split " ", $expect) { if(delete $got{$e}) { ok(1, "found $e") } else { $errors++; ok(0, "missing $e") } } if(keys %got) { ok(0, "got too much: ".join(" ", keys %got)); $errors++; } else { ok(1, "exact match"); } if($errors) { warn "$errors errors, expected '$expect' got '$got'\n"; } } my $flags = $mti->labelsToFlags(); expect_flags($flags, '', "Empty set"); $flags = $mti->labelsToFlags(seen => 1, flagged => 1, old => 1); expect_flags($flags, '\Seen \Flagged', "No old"); $flags = $mti->labelsToFlags( {seen => 1, flagged => 1, old => 1} ); expect_flags($flags, '\Seen \Flagged', "No old as hash"); $flags = $mti->labelsToFlags(seen => 1, flagged => 1, old => 0); expect_flags($flags, '\Seen \Flagged \Recent', "No old"); $flags = $mti->labelsToFlags( {seen => 1, flagged => 1, old => 0} ); expect_flags($flags, '\Seen \Flagged \Recent', "No old as hash"); $flags = $mti->labelsToFlags(seen => 1, replied => 1, flagged => 1, deleted => 1, draft => 1, old => 0, spam => 1); expect_flags($flags, '\Seen \Answered \Flagged \Deleted \Draft \Recent \Spam', "show all flags"); $flags = $mti->labelsToFlags(seen => 0, replied => 0, flagged => 0, deleted => 0, draft => 0, old => 1, spam => 0); expect_flags($flags, '', "show no flags"); ### ### Checking flagsToLabels ### sub expect_labels($$$) { my ($got, $expect, $text) = @_; my $gotkeys = join " ", %$got; my $expkeys = join " ", %$expect; # warn "expected '$expkeys' got '$gotkeys'\n"; # depends on predefined labels cmp_ok(scalar keys %$got, '==', 7, "$text; nr fields"); foreach my $k (keys %$got) { my $g = $got->{$k} || 0; my $e = $expect->{$k} || 0; cmp_ok($g, '==', $e, "got $k"); } foreach my $k (keys %$expect) { my $g = $got->{$k} || 0; my $e = $expect->{$k} || 0; cmp_ok($g, '==', $e, "expect $k"); } } my $labels = $mti->flagsToLabels('REPLACE'); expect_labels $labels, {old => 1}, "flagsToLabels: Empty set"; $labels = $mti->flagsToLabels(REPLACE => qw[\Seen \Flagged] ); expect_labels $labels , {old => 1, seen => 1, flagged => 1} , "flagsToLabels: Empty set"; $labels = $mti->flagsToLabels(REPLACE => qw[\Seen \Answered \Flagged \Deleted \Draft \Recent \Spam] ); expect_labels $labels , { seen => 1, replied => 1, flagged => 1, deleted => 1 , draft => 1, spam => 1 } , "show all labels"; exit 0; Mail-Box-IMAP4-3.009/lib/0000755000175000001440000000000015000516376015234 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/lib/Mail/0000755000175000001440000000000015000516376016116 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/lib/Mail/Transport/0000755000175000001440000000000015000516376020112 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/lib/Mail/Transport/IMAP4.pod0000644000175000001440000003416215000516374021434 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME Mail::Transport::IMAP4 - proxy to Mail::IMAPClient =head1 INHERITANCE Mail::Transport::IMAP4 is a Mail::Transport::Receive is a Mail::Transport is a Mail::Reporter =head1 SYNOPSIS my $imap = Mail::Transport::IMAP4->new(...); my $message = $imap->receive($id); $imap->send($message); my Mail::Box::Manager $mgr = Mail::Box::Manager->new; $mgr->open( # Generic folder options folder => 'imaps://...', access => 'rw', extract => 'ALWAYS', # Mail::IMAPClient options start with [A-Z] IgnoreSizeErrors => 1, Ssl => 1, ); =head1 DESCRIPTION The IMAP4 protocol is quite complicated: it is feature rich and allows various asynchronous actions. The main document describing IMAP is rfc3501 (which obsoleted the original specification of protocol 4r1 in rfc2060 in March 2003). This package, as part of MailBox, does not implement the actual protocol itself but uses Mail::IMAPClient to do the work. The task for this package is to hide as many differences between that module's interface and the common MailBox folder types. Multiple L folders can share one L connection. The Mail::IMAPClient module is the best IMAP4 implementation for Perl5, but is not maintained. There are many known problems with the module, and solving those is outside the scope of MailBox. See F for all the reported bugs. Extends L<"DESCRIPTION" in Mail::Transport::Receive|Mail::Transport::Receive/"DESCRIPTION">. =head1 METHODS Extends L<"METHODS" in Mail::Transport::Receive|Mail::Transport::Receive/"METHODS">. =head2 Constructors Extends L<"Constructors" in Mail::Transport::Receive|Mail::Transport::Receive/"Constructors">. =over 4 =item Mail::Transport::IMAP4-EB(%options) Create the IMAP connection to the server. IMAP servers can handle multiple folders for a single user, which means that connections may get shared. This is sharing is hidden for the user. When an C is specified, then the options C, C, C, and C are extracted from it. All %options which start with a capital are passed as initiation to Mail::IMAPClient. See that manual about the huge pile of parameters. When talking to Microsoft Exchange, you probabaly need the C. Probably, you need C or C as well. As feature, you may also pass a HASH to Ssl, where C only accepts an ARRAY. For backwards compatibility, C is an alternative for C, and C for C. -Option --Defined in --Default authenticate 'AUTO' domain executable Mail::Transport undef hostname Mail::Transport 'localhost' imap_client Mail::IMAPClient interval Mail::Transport 30 log Mail::Reporter 'WARNINGS' password Mail::Transport undef port Mail::Transport 143 proxy Mail::Transport undef retry Mail::Transport timeout Mail::Transport 120 trace Mail::Reporter 'WARNINGS' username Mail::Transport undef via Mail::Transport 'imap' =over 2 =item authenticate => TYPE|ARRAY Authenthication method to L, which will be passed to Mail::IMAPClient subroutine authenticate. See the latter method for the available types. You may provide an ARRAY of types. =item domain => WINDOWS_DOMAIN Used for NTLM authentication. =item executable => FILENAME =item hostname => HOSTNAME|ARRAY =item imap_client => OBJECT|CLASS When an OBJECT is supplied, that client will be used for the implementation of the IMAP4 protocol. Information about server and such are extracted from the OBJECT to have the accessors to produce correct results. The OBJECT shall be a L. When a CLASS is given, an object of that type is created for you. The created object can be retrieved via L, and than configured as defined by L. =item interval => SECONDS =item log => LEVEL =item password => STRING =item port => INTEGER =item proxy => PATH =item retry => NUMBER|undef =item timeout => SECONDS =item trace => LEVEL =item username => STRING =item via => CLASS|NAME =back =back =head2 Receiving mail Extends L<"Receiving mail" in Mail::Transport::Receive|Mail::Transport::Receive/"Receiving mail">. =over 4 =item $obj-EB( [$unique_message_id] ) Inherited, see L =back =head2 Server connection Extends L<"Server connection" in Mail::Transport::Receive|Mail::Transport::Receive/"Server connection">. =over 4 =item $obj-EB( $name, [@directories] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =back =head2 Attributes =over 4 =item $obj-EB( ['AUTO'|$type|$types] ) Returns a LIST of ARRAYS, each describing one possible way to contact the server. Each pair contains a mechanism name and a challenge callback (which may be C). The settings are used by L to get server access. The initial value origins from L, but may be changed later. Available basic $types are C, C, and C. With C, all available types will be tried. When the Authen::NTLM is not installed, the C option will silently be skipped. Be warned that, because of C, erroneous username/password combinations will be passed readible as last attempt! The C authentication requires Authen::NTLM to be installed. Other methods may be added later. Besides, you may also specify a CODE reference which implements some authentication. An ARRAY as $type can be used to specify both mechanism as callback. When no array is used, callback of the pair is set to C. See L for the gory details. example: $transporter->authentication('CRAM-MD5', [MY_AUTH => \&c], 'PLAIN'); foreach my $pair ($transporter->authentication) { my ($mechanism, $challenge) = @$pair; ... } =item $obj-EB( [$domain] ) Used in NTLM authentication to define the Windows domain which is accessed. Initially set by L and defaults to the server's name. =item $obj-EB() Returns a boolean. =back =head2 Exchanging Information =head2 Protocol [internals] The follow methods handle protocol internals, and should not be used by a normal user of this class. =over 4 =item $obj-EB( $message, $foldername, [$date] ) Write the message to the server. The optional DATA can be a RFC-822 date or a timestamp. =item $obj-EB($name) Add a folder. =item $obj-EB($class, %options) Create an object of $class, which extends L. All %options will be passed to the constructor (new) of $class. =item $obj-EB( [$foldername] ) Be sure that the specific FOLDER is the current one selected. If the folder is already selected, no IMAP traffic will be produced. The boolean return value indicates whether the folder is selectable. It will return undef if it does not exist. =item $obj-EB($name) Remove one folder. =item $obj-EB($folder) Command the server to delete for real all messages which are flagged to be deleted. =item $obj-EB(ARRAY-$of-$messages, $info) Get some $info about the $messages from the server. The specified messages shall extend L, Returned is a list of hashes, each info about one result. The contents of the hash differs per $info, but at least a C field will be present, to relate to the message in question. The right folder should be selected before this method is called. When the connection was lost, C is returned. Without any messages, and empty array is returned. The retrieval is done by L method C, which is then parsed. =item $obj-EB($what, @flags) =item Mail::Transport::IMAP4-EB($what, @flags) In SCALAR context, a hash with labels is returned. In LIST context, pairs are returned. The $what parameter can be C<'SET'>, C<'CLEAR'>, or C<'REPLACE'>. With the latter, all standard imap flags which do not appear in the list will be ignored: their value may either by set or cleared. See L Unknown flags in C<@flags> are stripped from their backslash and lower-cased. For instance, '\SomeWeirdFlag' will become `someweirdflag =E 1'. It will be set to '1' for C, and '0' in case of C. example: translating IMAP4 flags into MailBox flags my @flags = ('\Seen', '\Flagged'); my $labels = Mail::Transport::IMAP4->flags2labels(SET => @flags); =item $obj-EB( [$foldername] ) Returns a list of folder names which are sub-folders of the specified $foldername. Without $foldername, the top-level foldernames are returned. =item $obj-EB( $uid, $name, [$name, ...] ) Get the records with the specified NAMES from the header. The header fields are returned as list of L objects. When the name is C, the whole header is returned. =item $obj-EB($folder, $id) Returns the values of all flags which are related to the message with the specified $id. These flags are translated into the names which are standard for the MailBox suite. A HASH is returned. Names which do not appear will also provide a value in the returned: the negative for the value is it was present. =item $obj-EB($message|$uid) Returns the whole text of the specified message: the head and the body. =item $obj-EB() Returns a list of UIDs which are defined by the IMAP server. =item $obj-EB() Returns the object which implements the IMAP4 protocol, an instance of a Mail::IMAPClient, which is logged-in and ready to use. If the contact to the server was still present or could be established, an Mail::IMAPClient object is returned. Else, C is returned and no further actions should be tried on the object. =item $obj-EB(HASH|PAIRS) =item Mail::Transport::IMAP4-EB(HASH|PAIRS) Convert MailBox labels into IMAP flags. Returned is a string. Unsupported labels are ignored. =item $obj-EB() Returns all predefined flags as list. =item $obj-EB() Establish a new connection to the IMAP4 server, using username and password. =item $obj-EB($id, $label, $value, [$label, $value], ...) Change the flags on the message which are represented by the label. The value which can be related to the label will be lost, because IMAP only defines a boolean value, where MailBox labels can contain strings. Returned is a list of $label=>$value pairs which could not be send to the IMAP server. These values may be cached in a different way. =back =head2 Error handling Extends L<"Error handling" in Mail::Transport::Receive|Mail::Transport::Receive/"Error handling">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB($object) Inherited, see L =item $obj-EB( [$level]|[$loglevel, $tracelevel]|[$level, $callback] ) =item Mail::Transport::IMAP4-EB( [$level]|[$loglevel, $tracelevel]|[$level, $callback] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$level, [$strings]] ) =item Mail::Transport::IMAP4-EB( [$level, [$strings]] ) Inherited, see L =item $obj-EB($level) =item Mail::Transport::IMAP4-EB($level) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$level] ) Inherited, see L =item $obj-EB( [$level] ) Inherited, see L =item $obj-EB( [$level] ) Inherited, see L =item $obj-EB() Inherited, see L =back =head2 Cleanup Extends L<"Cleanup" in Mail::Transport::Receive|Mail::Transport::Receive/"Cleanup">. =over 4 =item $obj-EB() The connection is cleanly terminated when the program is terminated. =back =head1 DIAGNOSTICS =over 4 =item Error: Cannot connect to $host:$port for IMAP4: $! =item Error: IMAP cannot connect to $host: $@ =item Notice: IMAP4 authenication $mechanism to $host:$port successful =item Error: IMAP4 requires a username and password =item Error: IMAP4 username $username requires a password =item Error: Package $package does not implement $method. Fatal error: the specific package (or one of its superclasses) does not implement this method where it should. This message means that some other related classes do implement this method however the class at hand does not. Probably you should investigate this and probably inform the author of the package. =back =head1 SEE ALSO This module is part of Mail-Box-IMAP4 distribution version 3.009, built on April 18, 2025. Website: F =head1 LICENSE Copyrights 2001-2025 by [Mark Overmeer]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F Mail-Box-IMAP4-3.009/lib/Mail/Transport/IMAP4.pm0000644000175000001440000003410415000516373021261 0ustar00markovusers00000000000000# Copyrights 2001-2025 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.03. # This code is part of distribution Mail-Box-IMAP4. Meta-POD processed with # OODoc into POD and HTML manual-pages. See README.md # Copyright Mark Overmeer. Licensed under the same terms as Perl itself. package Mail::Transport::IMAP4;{ our $VERSION = '3.009'; } use base 'Mail::Transport::Receive'; use strict; use warnings; use Digest::HMAC_MD5; # only availability check for CRAM_MD5 use Mail::IMAPClient (); use List::Util qw/first/; sub init($) { my ($self, $args) = @_; my $imap = $args->{imap_client} || 'Mail::IMAPClient'; if(ref $imap) { $args->{port} = $imap->Port; $args->{hostname} = $imap->Server; $args->{username} = $imap->User; $args->{password} = $imap->Password; } else { $args->{port} ||= $args->{ssl} ? 993 : 143; } $args->{via} ||= 'imap4'; $self->SUPER::init($args) or return; $self->authentication($args->{authenticate} || 'AUTO'); $self->{MTI_domain} = $args->{domain}; unless(ref $imap) { # Create the IMAP transporter my %opts; $opts{ucfirst lc} = delete $args->{$_} for grep /^[A-Z]/, keys %$args; # backwards compatibility $opts{Starttls} ||= $args->{starttls}; my $ssl = $opts{Ssl} ||= $args->{ssl}; $opts{Ssl} = [ %$ssl ] if ref $ssl eq 'HASH'; $imap = $self->createImapClient($imap, %opts) or return undef; } $self->imapClient($imap) or return undef; $self->login or return undef; $self; } sub url() { my $self = shift; my ($host, $port, $user, $pwd) = $self->remoteHost; my $name = $self->folderName; my $proto = $self->usesSSL ? 'imap4s' : 'imap4'; "$proto://$user:$pwd\@$host:$port$name"; } #------------------------------------------ sub usesSSL() { shift->imapClient->Ssl } sub authentication(@) { my ($self, @types) = @_; # What the client wants to use to login @types or @types = exists $self->{MTI_auth} ? @{$self->{MTI_auth}} : 'AUTO'; @types = qw/CRAM-MD5 DIGEST-MD5 PLAIN NTLM LOGIN/ if @types == 1 && $types[0] eq 'AUTO'; $self->{MTI_auth} = \@types; my @clientside; foreach my $auth (@types) { push @clientside , ref $auth eq 'ARRAY' ? $auth : $auth eq 'NTLM' ? [ NTLM => \&Authen::NTLM::ntlm ] : [ $auth => undef ]; } my %clientside = map +($_->[0] => $_), @clientside; # What does the server support? in its order of preference. my $imap = $self->imapClient or return (); my @serverside = map { m/^AUTH=(\S+)/ ? uc($1) : () } $imap->capability; my @auth; if(@serverside) # server list auth capabilities { @auth = map { $clientside{$_} ? delete $clientside{$_} : () } @serverside; } @auth = @clientside unless @auth; # fallback to client's preference @auth; } sub domain(;$) { my $self = shift; return $self->{MTI_domain} = shift if @_; $self->{MTI_domain} || ($self->remoteHost)[0]; } #------------------------------------------ sub imapClient(;$) { my $self = shift; @_ ? ($self->{MTI_client} = shift) : $self->{MTI_client}; } sub createImapClient($@) { my ($self, $class, @args) = @_; my ($host, $port) = $self->remoteHost; my $debug_level = $self->logPriority('DEBUG')+0; if($self->log <= $debug_level || $self->trace <= $debug_level) { tie *dh, 'Mail::IMAPClient::Debug', $self; push @args, Debug => 1, Debug_fh => \*dh; } my $client = $class->new ( Server => $host, Port => $port , User => undef, Password => undef # disable auto-login , Uid => 1 # Safer , Peek => 1 # Don't set \Seen automaticly , @args ); $self->log(ERROR => $@), return undef if $@; $client; } sub login(;$) { my $self = shift; my $imap = $self->imapClient; return $self if $imap->IsAuthenticated; my ($interval, $retries, $timeout) = $self->retry; my ($host, $port, $username, $password) = $self->remoteHost; unless(defined $username) { $self->log(ERROR => "IMAP4 requires a username and password"); return; } unless(defined $password) { $self->log(ERROR => "IMAP4 username $username requires a password"); return; } my $warn_fail; while(1) { foreach my $auth ($self->authentication) { my ($mechanism, $challenge) = @$auth; $imap->User(undef); $imap->Password(undef); $imap->Authmechanism(undef); # disable auto-login $imap->Authcallback(undef); unless($imap->connect) { $self->log(ERROR => "IMAP cannot connect to $host: " , $imap->LastError); return undef; } $imap->User($username); $imap->Password($password); $imap->Authmechanism($mechanism); $imap->Authcallback($challenge) if defined $challenge; if($imap->login) { $self->log(NOTICE => "IMAP4 authenication $mechanism to " . "$username\@$host:$port successful"); return $self; } } $self->log(ERROR => "Couldn't contact to $username\@$host:$port") , return undef if $retries > 0 && --$retries == 0; $warn_fail++ or $self->log(WARNING => "Failed attempt to login $username\@$host" . ", retrying ".($retries+1)." times"); sleep $interval if $interval; } undef; } sub currentFolder(;$) { my $self = shift; return $self->{MTI_folder} unless @_; my $name = shift; if(defined $self->{MTI_folder} && $name eq $self->{MTI_folder}) { $self->log(DEBUG => "Folder $name already selected."); return $name; } # imap first deselects the old folder so if the next call # fails the server will not have anything selected. $self->{MTI_folder} = undef; my $imap = $self->imapClient or return; if($name eq '/' || $imap->select($name)) { $self->{MTI_folder} = $name; $self->log(NOTICE => "Selected folder $name"); return 1; } # Just because we couldn't select the folder that doesn't mean it doesn't # exist. It just means that this particular imap client is warning us # that it can't contain messages. So we'll verify that it does exist # and, if so, we'll pretend like we could have selected it as if it were # a regular folder. # IMAPClient::exists() only works reliably for leaf folders so we need # to grep for it ourselves. if(first { $_ eq $name } $self->folders) { $self->{MTI_folder} = $name; $self->log(NOTICE => "Couldn't select $name but it does exist."); return 0; } $self->log(NOTICE => "Folder $name does not exist!"); undef; } sub folders(;$) { my $self = shift; my $top = shift; my $imap = $self->imapClient or return (); $top = undef if defined $top && $top eq '/'; # We need to force the remote IMAP client to only return folders # *underneath* the folder we specify. By default they want to return # all folders. # Alas IMAPClient always appends the separator so, despite what it says # in its own docs, there's purpose to doing this. We just need # to get whatever we get and postprocess it. ???Still true??? my @folders = $imap->folders($top); # We need to post-process the list returned by IMAPClient. # This selects out the level of directories we're interested in. my $sep = $imap->separator; my $level = 1 + (defined $top ? () = $top =~ m/\Q$sep\E/g : -1); # There may be duplications, thanks to subdirs so we uniq it my %uniq; $uniq{(split /\Q$sep\E/, $_)[$level] || ''}++ for @folders; delete $uniq{''}; keys %uniq; } sub ids($) { my $self = shift; my $imap = $self->imapClient or return (); $imap->messages; } # Explanation in Mail::Box::IMAP4::Message chapter DETAILS my %flags2labels = ( # Standard IMAP4 labels '\Seen' => [seen => 1] , '\Answered' => [replied => 1] , '\Flagged' => [flagged => 1] , '\Deleted' => [deleted => 1] , '\Draft' => [draft => 1] , '\Recent' => [old => 0] # For the Netzwert extension (Mail::Box::Netzwert), some labels were # added. You'r free to support them as well. , '\Spam' => [spam => 1] ); my %labels2flags; while(my ($k, $v) = each %flags2labels) { $labels2flags{$v->[0]} = [ $k => $v->[1] ]; } # where IMAP4 supports requests for multiple flags at once, we here only # request one set of flags a time (which will be slower) sub getFlags($$) { my ($self, $id) = @_; my $imap = $self->imapClient or return (); my $labels = $self->flagsToLabels(SET => $imap->flags($id)); # Add default values for missing flags foreach my $s (values %flags2labels) { $labels->{$s->[0]} = not $s->[1] unless exists $labels->{$s->[0]}; } $labels; } sub listFlags() { keys %flags2labels } # Mail::IMAPClient can only set one value a time, however we do more... sub setFlags($@) { my ($self, $id) = (shift, shift); my $imap = $self->imapClient or return (); my (@set, @unset, @nonstandard); while(@_) { my ($label, $value) = (shift, shift); if(my $r = $labels2flags{$label}) { my $flag = $r->[0]; $value = $value ? $r->[1] : !$r->[1]; # exor can not be used, because value may be string $value ? (push @set, $flag) : (push @unset, $flag); } else { push @nonstandard, ($label => $value); } } $imap->set_flag($_, $id) foreach @set; $imap->unset_flag($_, $id) foreach @unset; @nonstandard; } sub labelsToFlags(@) { my $thing = shift; my @set; if(@_==1) { my $labels = shift; while(my ($label, $value) = each %$labels) { if(my $r = $labels2flags{$label}) { push @set, $r->[0] if ($value ? $r->[1] : !$r->[1]); } } } else { while(@_) { my ($label, $value) = (shift, shift); if(my $r = $labels2flags{$label}) { push @set, $r->[0] if ($value ? $r->[1] : !$r->[1]); } } } join " ", sort @set; } sub flagsToLabels($@) { my ($thing, $what) = (shift, shift); my %labels; my $clear = $what eq 'CLEAR'; foreach my $f (@_) { if(my $lab = $flags2labels{$f}) { $labels{$lab->[0]} = $clear ? not($lab->[1]) : $lab->[1]; } else { (my $lab = $f) =~ s,^\\,,; $labels{$lab}++; } } if($what eq 'REPLACE') { my %found = map { ($_ => 1) } @_; foreach my $f (keys %flags2labels) { next if $found{$f}; my $lab = $flags2labels{$f}; $labels{$lab->[0]} = not $lab->[1]; } } wantarray ? %labels : \%labels; } sub getFields($@) { my ($self, $id) = (shift, shift); my $imap = $self->imapClient or return (); my $parsed = $imap->parse_headers($id, @_) or return (); my @fields; while(my($n,$c) = each %$parsed) { push @fields, map { Mail::Message::Field::Fast->new($n, $_) } @$c; } @fields; } sub getMessageAsString($) { my $imap = shift->imapClient or return; my $uid = ref $_[0] ? shift->unique : shift; $imap->message_string($uid); } sub fetch($@) { my ($self, $msgs, @info) = @_; return () unless @$msgs; my $imap = $self->imapClient or return (); my %msgs = map { ($_->unique => {message => $_} ) } @$msgs; my $lines = $imap->fetch( [keys %msgs], @info ); # It's a pity that Mail::IMAPClient::fetch_hash cannot be used for # single messages... now I had to reimplement the decoding... while(@$lines) { my $line = shift @$lines; next unless $line =~ /\(.*?UID\s+(\d+)/i; my $id = $+; my $info = $msgs{$id} or next; # wrong uid if($line =~ s/^[^(]* \( \s* //x ) { while($line =~ s/(\S+) # field \s+ (?: # value \" ( (?:\\.|[^"])+ ) \" | \( ( (?:\\.|[^)])+ ) \) | (\w+) )//xi) { $info->{uc $1} = $+; } if( $line =~ m/^\s* (\S+) [ ]*$/x ) { # Text block expected my ($key, $value) = (uc $1, ''); while(@$lines) { my $extra = shift @$lines; $extra =~ s/\r\n$/\n/; last if $extra eq ")\n"; $value .= $extra; } $info->{$key} = $value; } } } values %msgs; } sub appendMessage($$) { my ($self, $message, $foldername, $date) = @_; my $imap = $self->imapClient or return (); $date = $imap->Rfc_822($date) if $date && $date !~ m/\D/; $imap->append_string ( $foldername, $message->string , $self->labelsToFlags($message->labels) , $date ); } sub destroyDeleted($) { my ($self, $folder) = @_; defined $folder or return; my $imap = shift->imapClient or return; $imap->expunge($folder); } sub createFolder($) { my $imap = shift->imapClient or return (); $imap->create(shift); } sub deleteFolder($) { my $imap = shift->imapClient or return (); $imap->delete(shift); } #------------------------------------------ sub DESTROY() { my $self = shift; my $imap = $self->imapClient; $self->SUPER::DESTROY; $imap->logout if defined $imap; } #------------------------------------------ # Tied filehandle translates IMAP's debug system into Mail::Reporter # calls. sub Mail::IMAPClient::Debug::TIEHANDLE($) { my ($class, $logger) = @_; bless \$logger, $class; } sub Mail::IMAPClient::Debug::PRINT(@) { my $logger = ${ (shift) }; $logger->log(DEBUG => @_); } 1; Mail-Box-IMAP4-3.009/lib/Mail/Box/0000755000175000001440000000000015000516376016646 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/lib/Mail/Box/IMAP4/0000755000175000001440000000000015000516376017460 5ustar00markovusers00000000000000Mail-Box-IMAP4-3.009/lib/Mail/Box/IMAP4/Message.pm0000644000175000001440000001006715000516373021403 0ustar00markovusers00000000000000# Copyrights 2001-2025 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.03. # This code is part of distribution Mail-Box-IMAP4. Meta-POD processed with # OODoc into POD and HTML manual-pages. See README.md # Copyright Mark Overmeer. Licensed under the same terms as Perl itself. package Mail::Box::IMAP4::Message;{ our $VERSION = '3.009'; } use base 'Mail::Box::Net::Message'; use strict; use warnings; use Date::Parse 'str2time'; sub init($) { my ($self, $args) = @_; $self->SUPER::init($args); $self->{MBIM_write_labels} = exists $args->{write_labels} ? $args->{write_labels} : 1; $self->{MBIM_cache_labels} = $args->{cache_labels}; $self->{MBIM_cache_head} = $args->{cache_head}; $self->{MBIM_cache_body} = $args->{cache_body}; $self; } sub size($) { my $self = shift; return $self->SUPER::size unless $self->isDelayed; $self->fetch('RFC822.SIZE'); } sub recvstamp() { my $date = shift->fetch('INTERNALDATE'); defined $date ? str2time($date) : undef; } sub label(@) { my $self = shift; my $imap = $self->folder->transporter or return; my $id = $self->unique or return; if(@_ == 1) { # get one value only my $label = shift; my $labels = $self->{MM_labels}; return $labels->{$label} if exists $labels->{$label} || exists $labels->{seen}; my $flags = $imap->getFlags($id); if($self->{MBIM_cache_labels}) { # the program may have added own labels @{$labels}{keys %$flags} = values %$flags; delete $self->{MBIM_labels_changed}; } return $flags->{$label}; } my @private; if($self->{MBIM_write_labels}) { @private = $imap->setFlags($id, @_); delete $self->{MBIM_labels_changed}; } else { @private = @_; } my $labels = $self->{MM_labels}; my @keep = $self->{MBIM_cache_labels} ? @_ : @private; while(@keep) { my ($k, $v) = (shift @keep, shift @keep); next if defined $labels->{$k} && $labels->{$k} eq $v; $self->{MBIM_labels_changed}++; $labels->{$k} = $v; } $self->modified(1) if @private && $self->{MBIM_labels_changed}; $self; } sub labels() { my $self = shift; my $id = $self->unique; my $labels = $self->SUPER::labels; $labels = { %$labels } unless $self->{MBIM_cache_labels}; if($id && !exists $labels->{seen}) { my $imap = $self->folder->transporter or return; my $flags = $imap->getFlags($id); @{$labels}{keys %$flags} = values %$flags; } $labels; } #------------------------------------------- sub loadHead() { my $self = shift; my $head = $self->head; return $head unless $head->isDelayed; $head = $self->folder->getHead($self); $self->head($head) if $self->{MBIM_cache_head}; $head; } sub loadBody() { my $self = shift; my $body = $self->body; return $body unless $body->isDelayed; (my $head, $body) = $self->folder->getHeadAndBody($self); return undef unless defined $head; $self->head($head) if $self->{MBIM_cache_head} && $head->isDelayed; $self->storeBody($body) if $self->{MBIM_cache_body}; $body; } sub fetch(@) { my ($self, @info) = @_; my $folder = $self->folder; my $answer = ($folder->fetch( [$self], @info))[0]; @info==1 ? $answer->{$info[0]} : @{$answer}{@info}; } sub writeDelayed($$) { my ($self, $foldername, $imap) = @_; my $id = $self->unique; my $labels = $self->labels; if($self->head->modified || $self->body->modified || !$id) { $imap->appendMessage($self, $foldername); if($id) { $self->delete; $self->unique(undef); } } elsif($self->{MBIM_labels_changed}) { $imap->setFlags($id, %$labels); # non-IMAP4 labels disappear delete $self->{MBIM_labels_changed}; } $self; } #------------------------------------------- 1; Mail-Box-IMAP4-3.009/lib/Mail/Box/IMAP4/Head.pod0000644000175000001440000001537615000516374021037 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME Mail::Box::IMAP4::Head - header fields related IMAP interface =head1 INHERITANCE Mail::Box::IMAP4::Head is a Mail::Message::Head is a Mail::Reporter =head1 SYNOPSIS =head1 DESCRIPTION This class implements a pure IMAP4 protocol interface, where as little data is retrieved from the header as possible. This may look nice to you, but is not sufficient for many tasks. For instance, you cannot removed or modify fields this way. Change L to C or C, to get a message header which is capable of performing all possible games with headers. On the other hand: the other settings are not 100% safe... Extends L<"DESCRIPTION" in Mail::Message::Head|Mail::Message::Head/"DESCRIPTION">. =head1 OVERLOADED Extends L<"OVERLOADED" in Mail::Message::Head|Mail::Message::Head/"OVERLOADED">. =over 4 =item overload: B<""> Inherited, see L =item overload: B Inherited, see L =back =head1 METHODS Extends L<"METHODS" in Mail::Message::Head|Mail::Message::Head/"METHODS">. =head2 Constructors Extends L<"Constructors" in Mail::Message::Head|Mail::Message::Head/"Constructors">. =over 4 =item Mail::Box::IMAP4::Head-EB( [PAIR|$field]-LIST ) Inherited, see L =item Mail::Box::IMAP4::Head-EB(%options) -Option --Defined in --Default cache_fields false field_type Mail::Message::Head Mail::Message::Field::Fast log Mail::Reporter 'WARNINGS' message Mail::Message::Head undef modified Mail::Message::Head trace Mail::Reporter 'WARNINGS' =over 2 =item cache_fields => BOOLEAN This is only a read-cache on fields, because this kind of header does not allow writing of fields. See L, this value is set to C for C and C for C.. =item field_type => CLASS =item log => LEVEL =item message => MESSAGE =item modified => BOOLEAN =item trace => LEVEL =back =back =head2 The header Extends L<"The header" in Mail::Message::Head|Mail::Message::Head/"The header">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$message] ) Inherited, see L =item $obj-EB( [BOOLEAN] ) Inherited, see L =item $obj-EB() Inherited, see L =back =head2 Access to the header Extends L<"Access to the header" in Mail::Message::Head|Mail::Message::Head/"Access to the header">. =over 4 =item $obj-EB( $name, [$index] ) Get the information about the header line $name. Realization will take place. =item $obj-EB( $name, [$index] ) Inherited, see L =back =head2 About the body Extends L<"About the body" in Mail::Message::Head|Mail::Message::Head/"About the body">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =back =head2 Internals Extends L<"Internals" in Mail::Message::Head|Mail::Message::Head/"Internals">. =over 4 =item $obj-EB($field) Inherited, see L =item $obj-EB($fields) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB($distance) Inherited, see L =item $obj-EB($parser) Inherited, see L =item $obj-EB($field) Inherited, see L =back =head2 Error handling Extends L<"Error handling" in Mail::Message::Head|Mail::Message::Head/"Error handling">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB($object) Inherited, see L =item $obj-EB( [$level]|[$loglevel, $tracelevel]|[$level, $callback] ) =item Mail::Box::IMAP4::Head-EB( [$level]|[$loglevel, $tracelevel]|[$level, $callback] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$level, [$strings]] ) =item Mail::Box::IMAP4::Head-EB( [$level, [$strings]] ) Inherited, see L =item $obj-EB($level) =item Mail::Box::IMAP4::Head-EB($level) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$level] ) Inherited, see L =item $obj-EB( [$level] ) Inherited, see L =item $obj-EB( [$level] ) Inherited, see L =item $obj-EB() Inherited, see L =back =head2 Cleanup Extends L<"Cleanup" in Mail::Message::Head|Mail::Message::Head/"Cleanup">. =over 4 =item $obj-EB() Inherited, see L =back =head1 DETAILS Extends L<"DETAILS" in Mail::Message::Head|Mail::Message::Head/"DETAILS">. =head1 DIAGNOSTICS =over 4 =item Error: Package $package does not implement $method. Fatal error: the specific package (or one of its superclasses) does not implement this method where it should. This message means that some other related classes do implement this method however the class at hand does not. Probably you should investigate this and probably inform the author of the package. =back =head1 SEE ALSO This module is part of Mail-Box-IMAP4 distribution version 3.009, built on April 18, 2025. Website: F =head1 LICENSE Copyrights 2001-2025 by [Mark Overmeer]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F Mail-Box-IMAP4-3.009/lib/Mail/Box/IMAP4/Message.pod0000644000175000001440000005104215000516374021550 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME Mail::Box::IMAP4::Message - one message on a IMAP4 server =head1 INHERITANCE Mail::Box::IMAP4::Message is a Mail::Box::Net::Message is a Mail::Box::Message is a Mail::Message is a Mail::Reporter =head1 SYNOPSIS my $folder = new Mail::Box::IMAP4 ... my $message = $folder->message(10); =head1 DESCRIPTION A C represents one message on a IMAP4 server, maintained by a L folder. Each message is stored as separate entity on the server, and maybe temporarily in your program as well. Extends L<"DESCRIPTION" in Mail::Box::Net::Message|Mail::Box::Net::Message/"DESCRIPTION">. =head1 METHODS Extends L<"METHODS" in Mail::Box::Net::Message|Mail::Box::Net::Message/"METHODS">. =head2 Constructors Extends L<"Constructors" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Constructors">. =over 4 =item $obj-EB(%options) Inherited, see L =item Mail::Box::IMAP4::Message-EB(%options) -Option --Defined in --Default body Mail::Message undef body_type Mail::Box::Message Mail::Message::Body::Lines cache_body cache_head cache_labels deleted Mail::Message field_type Mail::Message undef folder Mail::Box::Message head Mail::Message undef head_type Mail::Message Mail::Message::Head::Complete labels Mail::Message {} log Mail::Reporter 'WARNINGS' messageId Mail::Message undef modified Mail::Message size Mail::Box::Message undef trace Mail::Reporter 'WARNINGS' trusted Mail::Message unique Mail::Box::Net::Message write_labels =over 2 =item body => OBJECT =item body_type => CODE|CLASS =item cache_body => BOOLEAN =item cache_head => BOOLEAN =item cache_labels => BOOLEAN All standard IMAP labels can be cached on the local server to improve speed. This has the same dangers as setting C to false. The caching starts when the first label of the message was read. =item deleted => BOOLEAN =item field_type => CLASS =item folder => FOLDER =item head => OBJECT =item head_type => CLASS =item labels => ARRAY|HASH =item log => LEVEL =item messageId => STRING =item modified => BOOLEAN =item size => INTEGER =item trace => LEVEL =item trusted => BOOLEAN =item unique => STRING =item write_labels => BOOLEAN When a label is changed or its value read, using L, that info should be sent to the IMAP server. But, this action could be superfluous, for instance because the label was already set or clear, and communication is expensive. On the other hand, someone else may use IMAP to make changes in the same folder, and will get the updates too late or never... =back =back =head2 Constructing a message Extends L<"Constructing a message" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Constructing a message">. =over 4 =item $obj-EB( [<$rg_object|%options>] ) Inherited, see L =item Mail::Box::IMAP4::Message-EB( [$message|$part|$body], $content ) Inherited, see L =item Mail::Box::IMAP4::Message-EB($body, [$head], $headers) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB(STRING) Inherited, see L =item Mail::Box::IMAP4::Message-EB($fh|STRING|SCALAR|ARRAY, %options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB( [STRING|$field|$address|ARRAY-$of-$things] ) Inherited, see L =item $obj-EB(STRING) =item Mail::Box::IMAP4::Message-EB(STRING) Inherited, see L =back =head2 The message Extends L<"The message" in Mail::Box::Net::Message|Mail::Box::Net::Message/"The message">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB($folder, %options) Inherited, see L =item $obj-EB( [$folder] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB($folder, %options) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$fh] ) Inherited, see L =item $obj-EB( [$mailer], %options ) Inherited, see L =item $obj-EB( [$integer] ) Inherited, see L =item $obj-EB() Returns the size of this message. If the message is still on the remote server, IMAP is used to ask for the size. When the message is already loaded onto the local system, the size of the parsed message is taken. These sizes can differ because the difference in line-ending representation. =item $obj-EB() Inherited, see L =item $obj-EB( [STRING|undef] ) Inherited, see L =item $obj-EB( [$fh] ) Inherited, see L =back =head2 The header Extends L<"The header" in Mail::Box::Net::Message|Mail::Box::Net::Message/"The header">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB($fieldname) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [$head] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB($fieldname) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =back =head2 The body Extends L<"The body" in Mail::Box::Net::Message|Mail::Box::Net::Message/"The body">. =over 4 =item $obj-EB( [$body] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB(%options) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB( [<'ALL'|'ACTIVE'|'DELETED'|'RECURSE'|$filter>] ) Inherited, see L =back =head2 Flags Extends L<"Flags" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Flags">. =over 4 =item $obj-EB() Inherited, see L =item $obj-EB( [BOOLEAN] ) Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB() Inherited, see L =item $obj-EB