use
vars
qw($VERSION $useCache)
;
$VERSION
=
"1.70"
;
sub
Version {
$VERSION
; }
$useCache
= 1;
my
@path
;
if
($^O eq
"MacOS"
) {
@path
=
split
(/,/,
$ENV
{MAILCAPS} ||
"$ENV{HOME}mailcap"
);
}
else
{
@path
=
split
(/:/,
$ENV
{MAILCAPS} ||
(
defined
(
$ENV
{HOME})
?
"$ENV{HOME}/.mailcap:/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap"
:
"/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap"
));
}
sub
new
{
my
$class
=
shift
;
if
(
@_
% 2 == 1) {
unshift
@_
,
'filename'
}
my
%args
=
@_
;
my
$take_all
=
$args
{take} &&
uc
$args
{take} eq
'ALL'
;
my
$self
=
bless
{},
$class
;
$self
->{_count} = 0;
if
(
defined
(
$args
{filename}) && -r
$args
{filename}) {
$self
->_process_file(
$args
{filename});
}
if
( !
defined
(
$args
{filename}) ||
$take_all
)
{
my
$fname
;
foreach
$fname
(
@path
) {
if
(-r
$fname
) {
$self
->_process_file(
$fname
);
last
unless
$take_all
;
}
}
}
unless
(
$self
->{_count}) {
$self
->{
'audio/*'
} = [{
'view'
=>
"showaudio %s"
}];
$self
->{
'image/*'
} = [{
'view'
=>
"xv %s"
}];
$self
->{
'message/rfc822'
} = [{
'view'
=>
"xterm -e metamail %s"
}];
}
$self
;
}
sub
_process_file
{
my
$self
=
shift
;
my
$file
=
shift
;
unless
(
$file
) {
return
;}
local
*MAILCAP
;
if
(
open
(MAILCAP,
$file
)) {
$self
->{
'_file'
} =
$file
;
local
(
$_
);
while
(<MAILCAP>) {
next
if
/^\s*
next
if
/^\s*$/;
while
(s/\\\s*$//) {
$_
.= <MAILCAP>;
}
chomp
;
s/\0//g;
s/([^\\]);/$1\0/g;
my
@parts
=
split
(/\s*\0\s*/,
$_
);
my
$type
=
shift
(
@parts
);
$type
.=
"/*"
unless
$type
=~ m,/,;
my
$view
=
shift
(
@parts
);
$view
=~ s/\\;/;/g;
my
%field
= (
'view'
=>
$view
);
for
(
@parts
) {
my
(
$key
,
$val
) =
split
(/\s*=\s*/,
$_
, 2);
if
(
defined
$val
) {
$val
=~ s/\\;/;/g;
}
else
{
$val
= 1;
}
$field
{
$key
} =
$val
;
}
if
(
$field
{
'test'
}) {
my
$test
=
$field
{
'test'
};
unless
(
$test
=~ /%/) {
system
$test
;
next
if
$?;
}
}
unless
(
exists
$self
->{
$type
}) {
$self
->{
$type
} = [];
$self
->{_count}++;
}
push
(@{
$self
->{
$type
}}, \
%field
);
}
close
(MAILCAP);
}
}
sub
view {
my
$self
=
shift
;
$self
->_run(
$self
->viewCmd(
@_
)); }
sub
compose {
my
$self
=
shift
;
$self
->_run(
$self
->composeCmd(
@_
)); }
sub
edit {
my
$self
=
shift
;
$self
->_run(
$self
->editCmd(
@_
)); }
sub
print
{
my
$self
=
shift
;
$self
->_run(
$self
->printCmd(
@_
)); }
sub
viewCmd {
shift
->_createCommand(
'view'
,
@_
); }
sub
composeCmd {
shift
->_createCommand(
'compose'
,
@_
); }
sub
editCmd {
shift
->_createCommand(
'edit'
,
@_
); }
sub
printCmd {
shift
->_createCommand(
'print'
,
@_
); }
sub
_createCommand
{
my
(
$self
,
$method
,
$type
,
$file
) =
@_
;
my
$entry
=
$self
->getEntry(
$type
,
$file
);
return
undef
unless
$entry
;
if
(
exists
$entry
->{
$method
}) {
return
$self
->expandPercentMacros(
$entry
->{
$method
},
$type
,
$file
);
}
else
{
return
undef
;
}
}
sub
_run
{
my
(
$self
,
$cmd
) =
@_
;
if
(
defined
$cmd
) {
system
$cmd
;
return
1;
}
0;
}
sub
makeName
{
my
(
$self
,
$type
,
$basename
) =
@_
;
my
$template
=
$self
->nametemplate(
$type
);
return
$basename
unless
$template
;
$template
=~ s/
%s
/
$basename
/g;
$template
;
}
sub
field
{
my
(
$self
,
$type
,
$field
) =
@_
;
my
$entry
=
$self
->getEntry(
$type
);
$entry
->{
$field
};
}
sub
description {
shift
->field(
shift
,
'description'
); }
sub
textualnewlines {
shift
->field(
shift
,
'textualnewlines'
); }
sub
x11_bitmap {
shift
->field(
shift
,
'x11-bitmap'
); }
sub
nametemplate {
shift
->field(
shift
,
'nametemplate'
); }
sub
getEntry
{
my
(
$self
,
$origtype
,
$file
) =
@_
;
if
(
$useCache
) {
if
(
exists
$self
->{
'_cache'
}{
$origtype
}) {
return
$self
->{
'_cache'
}{
$origtype
};
}
}
my
(
$fulltype
,
@params
) =
split
(/\s*;\s*/,
$origtype
);
my
(
$type
,
$subtype
) =
split
(/\//,
$fulltype
, 2);
$subtype
=
""
unless
defined
$subtype
;
my
$entry
;
for
(@{
$self
->{
"$type/$subtype"
}}, @{
$self
->{
"$type/*"
}}) {
if
(
exists
$_
->{
'test'
}) {
my
$test
=
$self
->expandPercentMacros(
$_
->{
'test'
},
$origtype
,
$file
);
system
$test
;
next
if
$?;
}
$entry
= {
%$_
};
last
;
}
$self
->{
'_cache'
}{
$origtype
} =
$entry
if
$useCache
;
$entry
;
}
sub
expandPercentMacros
{
my
(
$self
,
$text
,
$type
,
$file
) =
@_
;
return
$text
unless
defined
$type
;
$file
=
""
unless
defined
$file
;
my
(
$fulltype
,
@params
) =
split
(/\s*;\s*/,
$type
);
my
$subtype
;
(
$type
,
$subtype
) =
split
(/\//,
$fulltype
, 2);
my
%params
;
for
(
@params
) {
my
(
$key
,
$val
) =
split
(/\s*=\s*/,
$_
, 2);
$params
{
$key
} =
$val
;
}
$text
=~ s/\\%/\0/g;
$text
=~ s/
%t
/
$fulltype
/g;
$text
=~ s/
%s
/
$file
/g;
{
local
($^W) = 0;
$text
=~ s/%\{\s*(.*?)\s*\}/
$params
{$1}/g;
}
$text
=~ s/\0/%/g;
$text
;
}
sub
dumpEntry
{
my
(
$hash
,
$prefix
) =
@_
;
$prefix
=
""
unless
defined
$prefix
;
for
(
sort
keys
%$hash
) {
print
"$prefix$_ = $hash->{$_}\n"
;
}
}
sub
dump
{
my
(
$self
) =
@_
;
for
(
keys
%$self
) {
next
if
/^_/;
print
"$_\n"
;
for
(@{
$self
->{
$_
}}) {
dumpEntry(
$_
,
"\t"
);
print
"\n"
;
}
}
if
(
exists
$self
->{
'_cache'
}) {
print
"Cached types\n"
;
for
(
keys
%{
$self
->{
'_cache'
}}) {
print
"\t$_\n"
;
}
}
}
1;