$VERSION
=
'2.071'
;
my
%require_failed
;
my
@basic_folder_types
=
( [
mbox
=>
'Mail::Box::Mbox'
]
, [
mh
=>
'Mail::Box::MH'
]
, [
maildir
=>
'Mail::Box::Maildir'
]
, [
pop
=>
'Mail::Box::POP3'
]
, [
pop3
=>
'Mail::Box::POP3'
]
, [
imap
=>
'Mail::Box::IMAP4'
]
, [
imap4
=>
'Mail::Box::IMAP4'
]
);
my
@managers
;
sub
init($)
{
my
(
$self
,
$args
) =
@_
;
$self
->SUPER::init(
$args
);
my
@new_types
;
if
(
exists
$args
->{folder_types})
{
@new_types
=
ref
$args
->{folder_types}[0]
? @{
$args
->{folder_types}}
:
$args
->{folder_types};
}
my
@basic_types
=
reverse
@basic_folder_types
;
if
(
my
$basic
=
$args
->{autodetect})
{
my
%types
=
map
{ (
$_
=> 1) } (
ref
$basic
?
@$basic
: (
$basic
));
@basic_types
=
grep
{
$types
{
$_
->[0]} }
@basic_types
;
}
$self
->{MBM_folder_types} = [];
$self
->registerType(
@$_
)
foreach
@new_types
,
@basic_types
;
$self
->{MBM_default_type} =
$args
->{default_folder_type} ||
'mbox'
;
$self
->{MBM_folderdirs} = [ ];
if
(
exists
$args
->{folderdir})
{
my
@dirs
=
$args
->{folderdir};
@dirs
= @{
$dirs
[0]}
if
ref
$dirs
[0];
push
@{
$self
->{MBM_folderdirs}},
@dirs
;
}
if
(
exists
$args
->{folderdirs})
{
my
@dirs
=
$args
->{folderdirs};
@dirs
= @{
$dirs
[0]}
if
ref
$dirs
[0];
push
@{
$self
->{MBM_folderdirs}},
@dirs
;
}
push
@{
$self
->{MBM_folderdirs}},
'.'
;
$self
->{MBM_folders} = [];
$self
->{MBM_threads} = [];
push
@managers
,
$self
;
weaken
$managers
[-1];
$self
;
}
sub
registerType($$@)
{
my
(
$self
,
$name
,
$class
,
@options
) =
@_
;
unshift
@{
$self
->{MBM_folder_types}}, [
$name
,
$class
,
@options
];
$self
;
}
sub
folderdir()
{
my
$dirs
=
shift
->{MBM_folderdirs} or
return
();
wantarray
?
@$dirs
:
$dirs
->[0];
}
sub
folderTypes()
{
my
$self
=
shift
;
my
%uniq
;
$uniq
{
$_
->[0]}++
foreach
@{
$self
->{MBM_folder_types}};
sort
keys
%uniq
;
}
sub
defaultFolderType()
{
my
$self
=
shift
;
my
$name
=
$self
->{MBM_default_type};
return
$name
if
$name
=~ m/\:\:/;
foreach
my
$def
(@{
$self
->{MBM_folder_types}})
{
return
$def
->[1]
if
$def
->[0] eq
$name
||
$def
->[1] eq
$name
;
}
undef
;
}
sub
open
(@)
{
my
$self
=
shift
;
my
$name
=
@_
% 2 ?
shift
:
undef
;
my
%args
=
@_
;
$args
{authentication} ||=
'AUTO'
;
$name
=
defined
$args
{folder} ?
$args
{folder} : (
$ENV
{MAIL} ||
''
)
unless
defined
$name
;
if
(
$name
=~ m/^(\w+)\:/ &&
grep
{
$_
eq $1 }
$self
->folderTypes)
{
my
%decoded
=
$self
->decodeFolderURL(
$name
);
if
(
keys
%decoded
)
{
@args
{
keys
%decoded
} =
values
%decoded
;
}
else
{
$self
->
log
(
ERROR
=>
"Illegal folder URL '$name'."
);
return
;
}
}
else
{
$args
{folder} =
$name
;
}
my
$type
=
$args
{type};
if
(
defined
$type
&&
$type
eq
'pop3'
)
{
my
$un
=
$args
{username} ||=
$ENV
{USER} ||
$ENV
{LOGIN};
my
$srv
=
$args
{server_name} ||=
'localhost'
;
my
$port
=
$args
{server_port} ||= 110;
$args
{folder} =
$name
=
"pop3://$un\@$srv:$port"
;
}
unless
(
defined
$name
&&
length
$name
)
{
$self
->
log
(
ERROR
=>
"No foldername specified to open."
);
return
undef
;
}
$args
{folderdir} ||=
$self
->{MBM_folderdirs}->[0]
if
$self
->{MBM_folderdirs};
$args
{access} ||=
'r'
;
if
(
$args
{create} &&
$args
{access} !~ m/w|a/)
{
$self
->
log
(
WARNING
=>
"Will never create a folder $name without having write access."
);
undef
$args
{create};
}
if
(
my
$folder
=
$self
->isOpenFolder(
$name
))
{
$self
->
log
(
ERROR
=>
"Folder $name is already open."
);
return
undef
;
}
my
(
$folder_type
,
$class
,
@defaults
);
if
(
$type
)
{
foreach
(@{
$self
->{MBM_folder_types}})
{ (
my
$abbrev
,
$class
,
@defaults
) =
@$_
;
if
(
$type
eq
$abbrev
||
$type
eq
$class
)
{
$folder_type
=
$abbrev
;
last
;
}
}
$self
->
log
(
ERROR
=>
"Folder type $type is unknown, using autodetect."
)
unless
$folder_type
;
}
unless
(
$folder_type
)
{
foreach
(@{
$self
->{MBM_folder_types}})
{
next
unless
$_
;
(
my
$abbrev
,
$class
,
@defaults
) =
@$_
;
next
if
$require_failed
{
$class
};
eval
"require $class"
;
if
($@)
{
$require_failed
{
$class
}++;
next
;
}
if
(
$class
->foundIn(
$name
,
@defaults
,
%args
))
{
$folder_type
=
$abbrev
;
last
;
}
}
}
unless
(
$folder_type
)
{
if
(
my
$type
=
$self
->{MBM_default_type})
{
foreach
(@{
$self
->{MBM_folder_types}})
{ (
my
$abbrev
,
$class
,
@defaults
) =
@$_
;
if
(
$type
eq
$abbrev
||
$type
eq
$class
)
{
$folder_type
=
$abbrev
;
last
;
}
}
}
}
unless
(
$folder_type
)
{
(
$folder_type
,
$class
,
@defaults
) = @{
$self
->{MBM_folder_types}[0]};
}
return
if
$require_failed
{
$class
};
eval
"require $class"
;
if
($@)
{
$self
->
log
(
ERROR
=>
"Failed for folder default $class: $@"
);
$require_failed
{
$class
}++;
return
();
}
push
@defaults
,
manager
=>
$self
;
my
$folder
=
$class
->new(
@defaults
,
%args
);
unless
(
defined
$folder
)
{
$self
->
log
(
WARNING
=>
"Folder does not exist, failed opening $folder_type folder $name."
)
unless
$args
{access} eq
'd'
;
return
;
}
$self
->
log
(
PROGRESS
=>
"Opened folder $name ($folder_type)."
);
push
@{
$self
->{MBM_folders}},
$folder
;
$folder
;
}
sub
openFolders() { @{
shift
->{MBM_folders}} }
sub
isOpenFolder($)
{
my
(
$self
,
$name
) =
@_
;
first {
$name
eq
$_
->name}
$self
->openFolders;
}
sub
close
($@)
{
my
(
$self
,
$folder
,
%options
) =
@_
;
return
unless
$folder
;
my
$name
=
$folder
->name;
my
@remaining
=
grep
{
$name
ne
$_
->name} @{
$self
->{MBM_folders}};
return
if
@{
$self
->{MBM_folders}} ==
@remaining
;
$self
->{MBM_folders} = [
@remaining
];
$_
->removeFolder(
$folder
)
foreach
@{
$self
->{MBM_threads}};
$folder
->
close
(
close_by_manager
=> 1,
%options
)
unless
$options
{close_by_self};
$self
;
}
sub
closeAllFolders(@)
{
my
(
$self
,
@options
) =
@_
;
$_
->
close
(
@options
)
foreach
$self
->openFolders;
$self
;
}
END {
map
{
defined
$_
&&
$_
->closeAllFolders}
@managers
}
sub
delete
($@)
{
my
(
$self
,
$name
,
%args
) =
@_
;
my
$recurse
=
delete
$args
{recursive};
my
$folder
=
$self
->
open
(
folder
=>
$name
,
access
=>
'd'
,
%args
)
or
return
$self
;
$folder
->
delete
(
recursive
=>
$recurse
);
}
sub
appendMessage(@)
{
my
$self
=
shift
;
my
@appended
=
$self
->appendMessages(
@_
);
wantarray
?
@appended
:
$appended
[0];
}
sub
appendMessages(@)
{
my
$self
=
shift
;
my
$folder
;
$folder
=
shift
if
!
ref
$_
[0] ||
$_
[0]->isa(
'Mail::Box'
);
my
@messages
;
push
@messages
,
shift
while
@_
&&
ref
$_
[0];
my
%options
=
@_
;
$folder
||=
$options
{folder};
$folder
=
$self
->isOpenFolder(
$folder
) ||
$folder
unless
ref
$folder
;
if
(
ref
$folder
)
{
unless
(
$folder
->isa(
'Mail::Box'
))
{
$self
->
log
(
ERROR
=>
"Folder $folder is not a Mail::Box; cannot add a message.\n"
);
return
();
}
foreach
(
@messages
)
{
next
unless
$_
->isa(
'Mail::Box::Message'
) &&
$_
->folder;
$self
->
log
(
WARNING
=>
"Use moveMessage() or copyMessage() to move between open folders."
);
}
return
$folder
->addMessages(
@messages
);
}
my
(
$name
,
$class
,
@gen_options
,
$found
);
foreach
(@{
$self
->{MBM_folder_types}})
{ (
$name
,
$class
,
@gen_options
) =
@$_
;
next
if
$require_failed
{
$class
};
eval
"require $class"
;
if
($@)
{
$require_failed
{
$class
}++;
next
;
}
if
(
$class
->foundIn(
$folder
,
@gen_options
,
access
=>
'a'
))
{
$found
++;
last
;
}
}
my
$type
=
$self
->{MBM_default_type};
if
(!
$found
&&
$type
)
{
foreach
(@{
$self
->{MBM_folder_types}})
{ (
$name
,
$class
,
@gen_options
) =
@$_
;
if
(
$type
eq
$name
||
$type
eq
$class
)
{
$found
++;
last
;
}
}
}
(
$name
,
$class
,
@gen_options
) = @{
$self
->{MBM_folder_types}[0]}
unless
$found
;
$class
->appendMessages
(
type
=>
$name
,
messages
=> \
@messages
,
@gen_options
,
%options
,
folder
=>
$folder
);
}
sub
copyMessage(@)
{
my
$self
=
shift
;
my
$folder
;
$folder
=
shift
if
!
ref
$_
[0] ||
$_
[0]->isa(
'Mail::Box'
);
my
@messages
;
while
(
@_
&&
ref
$_
[0])
{
my
$message
=
shift
;
$self
->
log
(
ERROR
=>
"Use appendMessage() to add messages which are not in a folder."
)
unless
$message
->isa(
'Mail::Box::Message'
);
push
@messages
,
$message
;
}
my
%args
=
@_
;
$folder
||=
$args
{folder};
my
$share
=
exists
$args
{share} ?
$args
{share} :
$args
{_delete};
$folder
=
$self
->isOpenFolder(
$folder
) ||
$folder
unless
ref
$folder
;
my
@coerced
=
ref
$folder
?
map
{
$_
->copyTo(
$folder
,
share
=>
$args
{share})}
@messages
:
$self
->appendMessages(
@messages
,
%args
,
folder
=>
$folder
);
if
(
$args
{_delete})
{
$_
->label(
deleted
=> 1)
foreach
@messages
;
}
@coerced
;
}
sub
moveMessage(@)
{
my
$self
=
shift
;
$self
->copyMessage(
@_
,
_delete
=> 1);
}
sub
threads(@)
{
my
$self
=
shift
;
my
@folders
;
push
@folders
,
shift
while
@_
&&
ref
$_
[0] &&
$_
[0]->isa(
'Mail::Box'
);
my
%args
=
@_
;
my
$base
=
'Mail::Box::Thread::Manager'
;
my
$type
=
$args
{threader_type} ||
$base
;
my
$folders
=
delete
$args
{folder} ||
delete
$args
{folders};
push
@folders
, ( !
$folders
? ()
:
ref
$folders
eq
'ARRAY'
?
@$folders
:
$folders
);
$self
->
log
(
INTERNAL
=>
"No folders specified."
)
unless
@folders
;
my
$threads
;
if
(
ref
$type
)
{
$self
->
log
(
INTERNAL
=>
"You need to pass a $base derived"
)
unless
$type
->isa(
$base
);
$threads
=
$type
;
}
else
{
eval
"require $type"
;
$self
->
log
(
INTERNAL
=>
"Unusable threader $type: $@"
)
if
$@;
$self
->
log
(
INTERNAL
=>
"You need to pass a $base derived"
)
unless
$type
->isa(
$base
);
$threads
=
$type
->new(
manager
=>
$self
,
%args
);
}
$threads
->includeFolder(
$_
)
foreach
@folders
;
push
@{
$self
->{MBM_threads}},
$threads
;
$threads
;
}
sub
toBeThreaded($@)
{
my
$self
=
shift
;
$_
->toBeThreaded(
@_
)
foreach
@{
$self
->{MBM_threads}};
}
sub
toBeUnthreaded($@)
{
my
$self
=
shift
;
$_
->toBeUnthreaded(
@_
)
foreach
@{
$self
->{MBM_threads}};
}
sub
decodeFolderURL($)
{
my
(
$self
,
$name
) =
@_
;
return
unless
my
(
$type
,
$username
,
$password
,
$hostname
,
$port
,
$path
)
=
$name
=~ m!^(\w+)\:
(?://
(?:([^:@./]*)
(?:\:([^@/]*))?
\@)?
([\w.-]+)?
(?:\:(\d+))?
)?
(.*)
!x;
$username
||=
$ENV
{USER} ||
$ENV
{LOGNAME};
$password
||=
''
;
$password
=~ s/\+/ /g;
$password
=~ s/\%([A-Fa-f0-9]{2})/
chr
hex
$1/ge;
$hostname
||=
'localhost'
;
$path
||=
'='
;
(
type
=>
$type
,
folder
=>
$path
,
username
=>
$username
,
password
=>
$password
,
server_name
=>
$hostname
,
server_port
=>
$port
);
}
1;