package Mail::Field;
use Carp;
use strict;
use vars qw($AUTOLOAD $VERSION);
$VERSION = "1.62";
unless(defined &UNIVERSAL::can) {
*UNIVERSAL::can = sub {
my($obj,$meth) = @_;
my $pkg = ref($obj) || $obj;
my @pkg = ($pkg);
my %done;
while(@pkg) {
$pkg = shift @pkg;
next if exists $done{$pkg};
$done{$pkg} = 1;
no strict 'refs';
unshift @pkg,@{$pkg . "::ISA"}
if(@{$pkg . "::ISA"});
return \&{$pkg . "::" . $meth}
if defined(&{$pkg . "::" . $meth});
}
undef;
}
}
sub _header_pkg_name
{
my($header) = lc shift;
$header =~ s/((\b|_)\w)/\U$1/gio;
if (length($header) > 8)
{
my @header = split /[-_]+/, $header;
my $chars = int((7 + @header) / @header) || 1;
$header = substr(join('', map { substr($_,0,$chars) } @header),0,8);
}
else
{
$header =~ s/[-_]+//go;
}
'Mail::Field::' . $header;
}
sub _require_dir
{
my($pkg,$dir,$dir_sep) = @_;
if(opendir(DIR,$dir))
{
my @inc = ();
my $f;
foreach $f (readdir(DIR))
{
next
unless $f =~ /^([\w\-]+)/;
my $p = $1;
my $n = $dir . $dir_sep . $p;
if(-d $n )
{
_require_dir( $pkg . "::" . $f, $n, $dir_sep);
}
else
{
$p =~ s/-/_/go;
eval "require ${pkg}::$p"
}
}
closedir(DIR);
}
}
sub import
{
my $pkg = shift;
if(@_)
{
local $_;
map {
eval "require " . _header_pkg_name($_) || die $@;
} @_;
}
else
{
my($f,$dir,$dir_sep);
foreach $f (keys %INC)
{
if($f =~ /^Mail(\W)Field\W/i)
{
$dir_sep = $1;
$dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep;
last;
}
}
_require_dir('Mail::Field', $dir, $dir_sep);
}
}
sub register
{
my $self = shift;
my $method = lc shift;
my $pkg = shift || ref($self) || $self;
$method =~ tr/-/_/;
$pkg = _header_pkg_name($method)
if($pkg eq "Mail::Field");
croak "Re-register of $method"
if Mail::Field->can($method);
no strict 'refs';
*{$method} = sub {
shift;
unless ($pkg->can('stringify')) {
eval "require $pkg" || die $@;
}
$pkg->_build(@_);
};
}
sub _build
{
my $type = shift;
my $self = bless {}, $type;
@_ == 1 ? $self->parse(@_)
: $self->create(@_);
}
sub new
{
my $self = shift; my $field = lc shift;
$field =~ tr/-/_/;
$self->$field(@_);
}
sub create
{
my $self = shift;
my %arg = @_;
$self = bless {}, $self
unless ref($self);
%$self = ();
$self->set(\%arg);
}
sub parse
{
my $self = shift;
my $type = ref($self) || $self;
croak "$type: Cannot parse";
}
sub text
{
my $self = shift;
@_ ? $self->parse(@_)
: $self->stringify;
}
sub tag
{
my $self = shift;
my $tag = ref($self) || $self;
$tag =~ s/.*:://o;
$tag =~ s/_/-/og;
join('-',
map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc($_)) }
split('-', $tag)
);
}
sub extract
{
my $self = shift;
my $tag = shift;
my $head = shift;
my $method = lc $tag;
$method =~ tr/-/_/;
my $text;
if(@_ == 0 && wantarray)
{
my @ret = ();
foreach $text ($head->get($tag))
{
chomp($text);
push(@ret, $self->$method($text));
}
return @ret;
}
my $idx = shift || 0;
$text = $head->get($tag,$idx) or
return undef;
chomp($text);
$self->$method($text);
}
sub AUTOLOAD
{
my $method = $AUTOLOAD;
$method =~ s/.*:://o;
croak "Undefined subroutine &$AUTOLOAD called"
unless $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/o;
my $pkg = _header_pkg_name($method);
unless(eval "require " . $pkg)
{
my $tag = $method;
$tag =~ s/_/-/og;
$tag = join('-',
map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc($_)) }
split('-', $tag));
no strict;
@{$pkg . "::ISA"} = qw(Mail::Field::Generic);
*{$pkg . "::tag"} = sub { $tag };
}
$pkg->register($method)
unless(Mail::Field->can($method));
goto &$AUTOLOAD;
}
sub DESTROY {}
package Mail::Field::Generic;
use Carp;
use vars qw(@ISA);
@ISA = qw(Mail::Field);
sub create
{
my $self = shift;
my %arg = @_;
my $text = delete $arg{Text} || "";
croak "Unknown options " . join(",", keys %arg)
if %arg;
$self->{Text} = $text;
$self;
}
sub parse
{
my $self = shift;
$self->{Text} = shift || "";
$self;
}
sub stringify
{
my $self = shift;
$self->{Text};
}
1;
__END__
=head1 NAME
Mail::Field - Base class for manipulation of mail header fields
=head1 SYNOPSIS
use Mail::Field;
$field = Mail::Field->new('Subject', 'some subject text');
print $field->tag,": ",$field->stringify,"\n";
$field = Mail::Field->subject('some subject text');
=head1 DESCRIPTION
C<Mail::Field> is a base class for packages that create and manipulate
fields from Email (and MIME) headers. Each different field will have its
own sub-class, defining its own interface.
This document describes the minimum interface that each sub-class should
provide, and also guidlines on how the field specific interface should be
defined.
=head1 CONSTRUCTOR
Mail::Field, and it's sub-classes define several methods which return
new objects. These can all be termed to be constructors.
=over 4
=item new ( TAG [, STRING | OPTIONS ] )
The new constructor will create an object in the class which defines
the field specified by the tag argument.
After creation of the object :-
If the tag argument is followed by a single string then the C<parse> method
will be called with this string.
If the tag argument is followed by more than one arguments then the C<create>
method will be called with these arguments.
=item extract ( TAG, HEAD [, INDEX ] )
This constuctor takes as arguments the tag name, a C<Mail::Head> object
and optionally an index.
If the index argument is given then C<extract> will retrieve the given tag
from the C<Mail::Head> object and create a new C<Mail::Field> based object.
I<undef> will be returned in the field does not exist.
If the index argument is not given the the result depends on the context
in which C<extract> is called. If called in a scalar context the result
will be as if C<extract> was called with an index value of zero. If called
in an array context then all tags will be retrieved and a list of
C<Mail::Field> objects will be returned.
=item combine ( FIELD_LIST )
This constructor takes as arguments a list of C<Mail::Field> objects, which
should all be of the same sub-class, and creates a new object in that same
class.
This constructor is nor defined in C<Mail::Field> as there is no generic
way to combine the various field types. Each sub-class should define
its own combine constructor, if combining is possible/allowed.
=back
=head1 METHODS
=over 4
=item parse
=item set
=item tag
=item stringify
=back
=head1 SUB-CLASS PACKAGE NAMES
All sub-classes should be called Mail::Field::I<name> where I<name> is
derived from the tag using these rules.
=over 4
=item *
Consider a tag as being made up of elements separated by '-'
=item *
Convert all characters to lowercase except the first in each element, which
should be uppercase.
=item *
I<name> is then created from these elements by using the first
N characters from each element.
=item *
N is calculated by using the formula :-
int((7 + #elements) / #elements)
=item *
I<name> is then limited to a maximum of 8 characters, keeping the first 8
characters
=back
For an example of this take a look at the definition of the
C<_header_pkg_name> subroutine in C<Mail::Field>
=head1 AUTHOR
Graham Barr.
Maintained by Mark Overmeer <mailtools@overmeer.net>
=head1 SEE ALSO
L<MIME::*>s
=head1 CREDITS
Eryq <eryq@rhine.gsfc.nasa.gov> - for all the help in defining this package
so that C<Mail::*> and C<MIME::*> can be integrated together.
=head1 COPYRIGHT
Copyright (c) 2002-2003 Mark Overmeer, 1995-2001 Graham Barr. All rights
reserved. This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut