summaryrefslogtreecommitdiff
path: root/cpan/lib/Mail/Field.pm
diff options
context:
space:
mode:
Diffstat (limited to 'cpan/lib/Mail/Field.pm')
-rw-r--r--cpan/lib/Mail/Field.pm602
1 files changed, 160 insertions, 442 deletions
diff --git a/cpan/lib/Mail/Field.pm b/cpan/lib/Mail/Field.pm
index 50ba5ad6..6b73823e 100644
--- a/cpan/lib/Mail/Field.pm
+++ b/cpan/lib/Mail/Field.pm
@@ -1,509 +1,227 @@
-# Mail::Field.pm
-#
-# Copyright (c) 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.
-
+# Copyrights 1995-2017 by [Mark Overmeer <perl@overmeer.net>].
+# For other contributors see ChangeLog.
+# See the manual pages for details on the licensing terms.
+# Pod stripped from pm file by OODoc 2.02.
package Mail::Field;
+use vars '$VERSION';
+$VERSION = '2.19';
-# $Id$
-use Carp;
use strict;
-use vars qw($AUTOLOAD $VERSION);
-
-$VERSION = "1.52";
-
-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;
- }
-}
+
+use Carp;
+use Mail::Field::Generic;
+
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;
-}
+{ my $header = lc shift;
+ $header =~ s/((\b|_)\w)/\U$1/g;
-##
-## Use the import method to load the sub-classes
-##
+ 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/[-_]+//g;
+ }
+
+ '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"
- }
+{ my($class, $dir, $dir_sep) = @_;
+
+ local *DIR;
+ opendir DIR, $dir
+ or return;
+
+ my @inc;
+ foreach my $f (readdir DIR)
+ { $f =~ /^([\w\-]+)/ or next;
+ my $p = $1;
+ my $n = "$dir$dir_sep$p";
+
+ if(-d $n )
+ { _require_dir("${class}::$f", $n, $dir_sep);
+ }
+ else
+ { $p =~ s/-/_/go;
+ eval "require ${class}::$p";
+
+ # added next warning in 2.14, may be ignored for ancient code
+ warn $@ if $@;
+ }
}
- closedir(DIR);
- }
+ 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;
- }
+{ my $class = shift;
+
+ if(@_)
+ { local $_;
+ eval "require " . _header_pkg_name($_) || die $@
+ for @_;
+ return;
}
- _require_dir('Mail::Field', $dir, $dir_sep);
- }
-}
+ my ($dir, $dir_sep);
+ foreach my $f (grep defined $INC{$_}, keys %INC)
+ { next if $f !~ /^Mail(\W)Field\W/i;
+ $dir_sep = $1;
+# $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep;
+ ($dir = $INC{$f}) =~ s/(Mail\W+Field).*/$1$dir_sep/;
+ last;
+ }
-##
-## register a header class, this creates a new method in Mail::Field
-## which will call new on that class
-##
+ _require_dir('Mail::Field', $dir, $dir_sep);
+}
+# register a header class, this creates a new method in Mail::Field
+# which will call new on that class
sub register
-{
- my $self = shift;
- my $method = lc shift;
- my $pkg = shift || ref($self) || $self;
+{ my $thing = shift;
+ my $method = lc shift;
+ my $class = shift || ref($thing) || $thing;
- $method =~ tr/-/_/;
+ $method =~ tr/-/_/;
+ $class = _header_pkg_name $method
+ if $class eq "Mail::Field";
- $pkg = _header_pkg_name($method)
- if($pkg eq "Mail::Field");
-
- croak "Re-register of $method"
+ croak "Re-register of $method"
if Mail::Field->can($method);
- no strict 'refs';
- *{$method} = sub {
+ no strict 'refs';
+ *{$method} = sub {
shift;
- unless ($pkg->can('stringify')) {
- eval "require $pkg" || die $@;
- }
- $pkg->_build(@_);
- };
-
+ $class->can('stringify') or eval "require $class" or die $@;
+ $class->_build(@_);
+ };
}
-##
-## the *real* constructor
-## if called with one argument then the `parse' method will be called
-## otherwise the `create' method is called
-##
+# the *real* constructor
+# if called with one argument then the `parse' method will be called
+# otherwise the `create' method is called
sub _build
-{
- my $type = shift;
- my $self = bless {}, $type;
-
- @_ == 1 ? $self->parse(@_)
- : $self->create(@_);
-}
-
-sub new
-{
- my $self = shift; # ignored
- my $field = lc shift;
-
- $field =~ tr/-/_/;
-
- $self->$field(@_);
+{ my $self = bless {}, shift;
+ @_==1 ? $self->parse(@_) : $self->create(@_);
}
-##
-## A default create method. This allows us to do
-## $s = Mail::Field->new('Subject', Text => "joe");
-## $s = Mail::Field->new('Subject', "joe");
-##
-
-sub create
-{
- my $self = shift;
- my %arg = @_;
-
- $self = bless {}, $self
- unless ref($self);
+#-------------
- %$self = ();
-
- $self->set(\%arg);
+sub new
+{ my $class = shift;
+ my $field = lc shift;
+ $field =~ tr/-/_/;
+ $class->$field(@_);
}
-##
-## A default create method. This allows us to do
-## $s = Mail::Field->new('Subject');
-##
-sub parse
-{
- my $self = shift;
- my $type = ref($self) || $self;
+sub combine {confess "Combine not implemented" }
- croak "$type: Cannot parse";
-}
+our $AUTOLOAD;
+sub AUTOLOAD
+{ my $method = $AUTOLOAD;
+ $method =~ s/.*:://;
-##
-## either get the text, or parse a new one
-##
+ $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/
+ or croak "Undefined subroutine &$AUTOLOAD called";
-sub text
-{
- my $self = shift;
- @_ ? $self->parse(@_)
- : $self->stringify;
-}
+ my $class = _header_pkg_name $method;
-##
-## Return the tag (in the correct case) for this item
-##
+ unless(eval "require $class")
+ { my $tag = $method;
+ $tag =~ s/_/-/g;
+ $tag = join '-',
+ map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
+ split /\-/, $tag;
-sub tag
-{
- my $self = shift;
- my $tag = ref($self) || $self;
+ no strict;
+ @{"${class}::ISA"} = qw(Mail::Field::Generic);
+ *{"${class}::tag"} = sub { $tag };
+ }
- $tag =~ s/.*:://o;
- $tag =~ s/_/-/og;
- $tag =~ s/\b([a-z]+)/\L\u$1/gio;
- $tag =~ s/\b([b-df-hj-np-tv-z]+)\b/\U$1/gio;
+ Mail::Field->can($method)
+ or $class->register($method);
- $tag;
+ goto &$AUTOLOAD;
}
-##
-## a constructor
-## create a new object by extracting from a Mail::Header object
-##
+# Of course, the functionality should have been in the Mail::Header class
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));
+{ my ($class, $tag, $head) = (shift, shift, shift);
+
+ my $method = lc $tag;
+ $method =~ tr/-/_/;
+
+ if(@_==0 && wantarray)
+ { my @ret;
+ my $text; # need real copy!
+ foreach $text ($head->get($tag))
+ { chomp $text;
+ push @ret, $class->$method($text);
+ }
+ return @ret;
}
- return @ret;
- }
-
- my $idx = shift || 0;
-
- $text = $head->get($tag,$idx) or
- return undef;
-
- chomp($text);
-
- $self->$method($text);
-}
-
-##
-## Autoload sub-classes, or, if the .pm file cannot be found, create a dummy
-## sub-class based on Mail::Field::Generic
-##
-
-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 =~ s/\b([a-z]+)/\L\u$1/gio;
- $tag =~ s/\b([b-df-hj-np-tv-z]+)\b/\U$1/gio;
-
- no strict;
-
- @{$pkg . "::ISA"} = qw(Mail::Field::Generic);
- *{$pkg . "::tag"} = sub { $tag };
- }
+ my $idx = shift || 0;
+ my $text = $head->get($tag,$idx)
+ or return undef;
- $pkg->register($method)
- unless(Mail::Field->can($method));
-
- goto &$AUTOLOAD;
+ chomp $text;
+ $class->$method($text);
}
-##
-## prevent the calling of AUTOLOAD for DESTROY :-)
-##
-
-sub DESTROY {}
-
-##
-## A generic package for those not defined in thier own package. This is
-## fine for fields like Subject, X-Mailer etc. where the field holds only
-## a string of no particular importance/format.
-##
-
-package Mail::Field::Generic;
-
-use Carp;
-use vars qw(@ISA);
-
-@ISA = qw(Mail::Field);
+#-------------
+# before 2.00, this method could be called as class method, however
+# not all extensions supported that.
sub create
-{
- my $self = shift;
- my %arg = @_;
- my $text = delete $arg{Text} || "";
-
- croak "Unknown options " . join(",", keys %arg)
- if %arg;
-
- $self->{Text} = $text;
-
- $self;
+{ my ($self, %arg) = @_;
+ %$self = ();
+ $self->set(\%arg);
}
-sub parse
-{
- my $self = shift;
-
- $self->{Text} = shift || "";
- $self;
-}
-sub stringify
-{
- my $self = shift;
- $self->{Text};
+# before 2.00, this method could be called as class method, however
+# not all extensions supported that.
+sub parse
+{ my $class = ref shift;
+ confess "parse() not implemented";
}
-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
+sub stringify { confess "stringify() not implemented" }
-=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
+sub tag
+{ my $thing = shift;
+ my $tag = ref($thing) || $thing;
+ $tag =~ s/.*:://;
+ $tag =~ s/_/-/g;
-L<MIME::*>s
+ join '-',
+ map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
+ split /\-/, $tag;
+}
-=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.
+sub set(@) { confess "set() not implemented" }
-=head1 COPYRIGHT
+# prevent the calling of AUTOLOAD for DESTROY :-)
+sub DESTROY {}
-Copyright (c) 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
+sub text
+{ my $self = shift;
+ @_ ? $self->parse(@_) : $self->stringify;
+}
+#-------------
+1;
generated by cgit v1.2.1 (git 2.18.0) at 2026-09-02 16:41:31 +0000