File Coverage

blib/lib/Mail/Field.pm
Criterion Covered Total %
statement 18 115 15.6
branch 0 38 0.0
condition 0 18 0.0
subroutine 6 24 25.0
pod 9 10 90.0
total 33 205 16.1


line stmt bran cond sub pod time code
1             # Copyrights 1995-2019 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of the bundle MailTools. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md for Copyright.
7             # Licensed under the same terms as Perl itself.
8              
9             package Mail::Field;
10 1     1   462 use vars '$VERSION';
  1         2  
  1         51  
11             $VERSION = '2.21';
12              
13              
14 1     1   6 use strict;
  1         2  
  1         20  
15              
16 1     1   5 use Carp;
  1         2  
  1         63  
17 1     1   461 use Mail::Field::Generic;
  1         2  
  1         716  
18              
19              
20             sub _header_pkg_name
21 0     0     { my $header = lc shift;
22 0           $header =~ s/((\b|_)\w)/\U$1/g;
23              
24 0 0         if(length($header) > 8)
25 0           { my @header = split /[-_]+/, $header;
26 0   0       my $chars = int((7 + @header) / @header) || 1;
27 0           $header = substr join('', map {substr $_,0,$chars} @header), 0, 8;
  0            
28             }
29             else
30 0           { $header =~ s/[-_]+//g;
31             }
32              
33 0           'Mail::Field::' . $header;
34             }
35              
36             sub _require_dir
37 0     0     { my($class, $dir, $dir_sep) = @_;
38              
39 0           local *DIR;
40 0 0         opendir DIR, $dir
41             or return;
42              
43 0           my @inc;
44 0           foreach my $f (readdir DIR)
45 0 0         { $f =~ /^([\w\-]+)/ or next;
46 0           my $p = $1;
47 0           my $n = "$dir$dir_sep$p";
48              
49 0 0         if(-d $n )
50 0           { _require_dir("${class}::$f", $n, $dir_sep);
51             }
52             else
53 0           { $p =~ s/-/_/go;
54 0           eval "require ${class}::$p";
55              
56             # added next warning in 2.14, may be ignored for ancient code
57 0 0         warn $@ if $@;
58             }
59             }
60 0           closedir DIR;
61             }
62              
63             sub import
64 0     0     { my $class = shift;
65              
66 0 0         if(@_)
67 0           { local $_;
68             eval "require " . _header_pkg_name($_) || die $@
69 0   0       for @_;
70 0           return;
71             }
72              
73 0           my ($dir, $dir_sep);
74 0           foreach my $f (grep defined $INC{$_}, keys %INC)
75 0 0         { next if $f !~ /^Mail(\W)Field\W/i;
76 0           $dir_sep = $1;
77             # $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep;
78 0           ($dir = $INC{$f}) =~ s/(Mail\W+Field).*/$1$dir_sep/;
79 0           last;
80             }
81              
82 0           _require_dir('Mail::Field', $dir, $dir_sep);
83             }
84              
85             # register a header class, this creates a new method in Mail::Field
86             # which will call new on that class
87             sub register
88 0     0 0   { my $thing = shift;
89 0           my $method = lc shift;
90 0   0       my $class = shift || ref($thing) || $thing;
91              
92 0           $method =~ tr/-/_/;
93 0 0         $class = _header_pkg_name $method
94             if $class eq "Mail::Field";
95              
96 0 0         croak "Re-register of $method"
97             if Mail::Field->can($method);
98              
99 1     1   8 no strict 'refs';
  1         2  
  1         492  
100 0           *{$method} = sub {
101 0     0     shift;
102 0 0 0       $class->can('stringify') or eval "require $class" or die $@;
103 0           $class->_build(@_);
104 0           };
105             }
106              
107             # the *real* constructor
108             # if called with one argument then the `parse' method will be called
109             # otherwise the `create' method is called
110              
111             sub _build
112 0     0     { my $self = bless {}, shift;
113 0 0         @_==1 ? $self->parse(@_) : $self->create(@_);
114             }
115              
116             #-------------
117              
118             sub new
119 0     0 1   { my $class = shift;
120 0           my $field = lc shift;
121 0           $field =~ tr/-/_/;
122 0           $class->$field(@_);
123             }
124              
125              
126 0     0 1   sub combine {confess "Combine not implemented" }
127              
128             our $AUTOLOAD;
129             sub AUTOLOAD
130 0     0     { my $method = $AUTOLOAD;
131 0           $method =~ s/.*:://;
132              
133 0 0         $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/
134             or croak "Undefined subroutine &$AUTOLOAD called";
135              
136 0           my $class = _header_pkg_name $method;
137              
138 0 0         unless(eval "require $class")
139 0           { my $tag = $method;
140 0           $tag =~ s/_/-/g;
141             $tag = join '-',
142 0 0         map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
  0            
143             split /\-/, $tag;
144              
145 1     1   8 no strict;
  1         1  
  1         571  
146 0           @{"${class}::ISA"} = qw(Mail::Field::Generic);
  0            
147 0     0     *{"${class}::tag"} = sub { $tag };
  0            
  0            
148             }
149              
150 0 0         Mail::Field->can($method)
151             or $class->register($method);
152              
153 0           goto &$AUTOLOAD;
154             }
155              
156              
157             # Of course, the functionality should have been in the Mail::Header class
158             sub extract
159 0     0 1   { my ($class, $tag, $head) = (shift, shift, shift);
160              
161 0           my $method = lc $tag;
162 0           $method =~ tr/-/_/;
163              
164 0 0 0       if(@_==0 && wantarray)
165 0           { my @ret;
166             my $text; # need real copy!
167 0           foreach $text ($head->get($tag))
168 0           { chomp $text;
169 0           push @ret, $class->$method($text);
170             }
171 0           return @ret;
172             }
173              
174 0   0       my $idx = shift || 0;
175 0 0         my $text = $head->get($tag,$idx)
176             or return undef;
177              
178 0           chomp $text;
179 0           $class->$method($text);
180             }
181              
182             #-------------
183              
184             # before 2.00, this method could be called as class method, however
185             # not all extensions supported that.
186             sub create
187 0     0 1   { my ($self, %arg) = @_;
188 0           %$self = ();
189 0           $self->set(\%arg);
190             }
191              
192              
193             # before 2.00, this method could be called as class method, however
194             # not all extensions supported that.
195             sub parse
196 0     0 1   { my $class = ref shift;
197 0           confess "parse() not implemented";
198             }
199              
200             #-------------
201              
202 0     0 1   sub stringify { confess "stringify() not implemented" }
203              
204              
205             sub tag
206 0     0 1   { my $thing = shift;
207 0   0       my $tag = ref($thing) || $thing;
208 0           $tag =~ s/.*:://;
209 0           $tag =~ s/_/-/g;
210              
211             join '-',
212 0 0         map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
  0            
213             split /\-/, $tag;
214             }
215              
216              
217 0     0 1   sub set(@) { confess "set() not implemented" }
218              
219             # prevent the calling of AUTOLOAD for DESTROY :-)
220       0     sub DESTROY {}
221              
222             #-------------
223              
224             sub text
225 0     0 1   { my $self = shift;
226 0 0         @_ ? $self->parse(@_) : $self->stringify;
227             }
228              
229             #-------------
230              
231             1;