Filename | /usr/local/lib/perl5/site_perl/Mail/Field.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | AUTOLOAD | Mail::Field::
0 | 0 | 0 | 0s | 0s | BEGIN@10 | Mail::Field::
0 | 0 | 0 | 0s | 0s | BEGIN@14 | Mail::Field::
0 | 0 | 0 | 0s | 0s | BEGIN@145 | Mail::Field::
0 | 0 | 0 | 0s | 0s | BEGIN@16 | Mail::Field::
0 | 0 | 0 | 0s | 0s | BEGIN@17 | Mail::Field::
0 | 0 | 0 | 0s | 0s | BEGIN@99 | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:closedir (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:ftdir (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:match (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:open_dir (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:readdir (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:subst (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | CORE:substcont (opcode) | Mail::Field::
0 | 0 | 0 | 0s | 0s | DESTROY | Mail::Field::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Mail::Field::
0 | 0 | 0 | 0s | 0s | __ANON__[:104] | Mail::Field::
0 | 0 | 0 | 0s | 0s | __ANON__[:147] | Mail::Field::
0 | 0 | 0 | 0s | 0s | _build | Mail::Field::
0 | 0 | 0 | 0s | 0s | _header_pkg_name | Mail::Field::
0 | 0 | 0 | 0s | 0s | _require_dir | Mail::Field::
0 | 0 | 0 | 0s | 0s | combine | Mail::Field::
0 | 0 | 0 | 0s | 0s | create | Mail::Field::
0 | 0 | 0 | 0s | 0s | extract | Mail::Field::
0 | 0 | 0 | 0s | 0s | import | Mail::Field::
0 | 0 | 0 | 0s | 0s | new | Mail::Field::
0 | 0 | 0 | 0s | 0s | parse | Mail::Field::
0 | 0 | 0 | 0s | 0s | register | Mail::Field::
0 | 0 | 0 | 0s | 0s | set | Mail::Field::
0 | 0 | 0 | 0s | 0s | stringify | Mail::Field::
0 | 0 | 0 | 0s | 0s | tag | Mail::Field::
0 | 0 | 0 | 0s | 0s | text | Mail::Field::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # Copyrights 1995-2019 by [Mark Overmeer <markov@cpan.org>]. | ||||
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 | use vars '$VERSION'; | ||||
11 | $VERSION = '2.21'; | ||||
12 | |||||
13 | |||||
14 | use strict; | ||||
15 | |||||
16 | use Carp; | ||||
17 | use Mail::Field::Generic; | ||||
18 | |||||
19 | |||||
20 | sub _header_pkg_name | ||||
21 | { my $header = lc shift; | ||||
22 | $header =~ s/((\b|_)\w)/\U$1/g; | ||||
23 | |||||
24 | if(length($header) > 8) | ||||
25 | { my @header = split /[-_]+/, $header; | ||||
26 | my $chars = int((7 + @header) / @header) || 1; | ||||
27 | $header = substr join('', map {substr $_,0,$chars} @header), 0, 8; | ||||
28 | } | ||||
29 | else | ||||
30 | { $header =~ s/[-_]+//g; | ||||
31 | } | ||||
32 | |||||
33 | 'Mail::Field::' . $header; | ||||
34 | } | ||||
35 | |||||
36 | sub _require_dir | ||||
37 | { my($class, $dir, $dir_sep) = @_; | ||||
38 | |||||
39 | local *DIR; | ||||
40 | opendir DIR, $dir | ||||
41 | or return; | ||||
42 | |||||
43 | my @inc; | ||||
44 | foreach my $f (readdir DIR) | ||||
45 | { $f =~ /^([\w\-]+)/ or next; | ||||
46 | my $p = $1; | ||||
47 | my $n = "$dir$dir_sep$p"; | ||||
48 | |||||
49 | if(-d $n ) | ||||
50 | { _require_dir("${class}::$f", $n, $dir_sep); | ||||
51 | } | ||||
52 | else | ||||
53 | { $p =~ s/-/_/go; | ||||
54 | eval "require ${class}::$p"; # spent 0s executing statements in 18 string evals (merged)
# spent 0s executing statements in 18 string evals (merged)
# spent 0s executing statements in 18 string evals (merged) | ||||
55 | |||||
56 | # added next warning in 2.14, may be ignored for ancient code | ||||
57 | warn $@ if $@; | ||||
58 | } | ||||
59 | } | ||||
60 | closedir DIR; | ||||
61 | } | ||||
62 | |||||
63 | sub import | ||||
64 | { my $class = shift; | ||||
65 | |||||
66 | if(@_) | ||||
67 | { local $_; | ||||
68 | eval "require " . _header_pkg_name($_) || die $@ | ||||
69 | for @_; | ||||
70 | return; | ||||
71 | } | ||||
72 | |||||
73 | my ($dir, $dir_sep); | ||||
74 | foreach my $f (grep defined $INC{$_}, keys %INC) | ||||
75 | { next if $f !~ /^Mail(\W)Field\W/i; | ||||
76 | $dir_sep = $1; | ||||
77 | # $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep; | ||||
78 | ($dir = $INC{$f}) =~ s/(Mail\W+Field).*/$1$dir_sep/; | ||||
79 | last; | ||||
80 | } | ||||
81 | |||||
82 | _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 | { my $thing = shift; | ||||
89 | my $method = lc shift; | ||||
90 | my $class = shift || ref($thing) || $thing; | ||||
91 | |||||
92 | $method =~ tr/-/_/; | ||||
93 | $class = _header_pkg_name $method | ||||
94 | if $class eq "Mail::Field"; | ||||
95 | |||||
96 | croak "Re-register of $method" | ||||
97 | if Mail::Field->can($method); | ||||
98 | |||||
99 | no strict 'refs'; | ||||
100 | *{$method} = sub { | ||||
101 | shift; | ||||
102 | $class->can('stringify') or eval "require $class" or die $@; | ||||
103 | $class->_build(@_); | ||||
104 | }; | ||||
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 | { my $self = bless {}, shift; | ||||
113 | @_==1 ? $self->parse(@_) : $self->create(@_); | ||||
114 | } | ||||
115 | |||||
116 | #------------- | ||||
117 | |||||
118 | sub new | ||||
119 | { my $class = shift; | ||||
120 | my $field = lc shift; | ||||
121 | $field =~ tr/-/_/; | ||||
122 | $class->$field(@_); | ||||
123 | } | ||||
124 | |||||
125 | |||||
126 | sub combine {confess "Combine not implemented" } | ||||
127 | |||||
128 | our $AUTOLOAD; | ||||
129 | sub AUTOLOAD | ||||
130 | { my $method = $AUTOLOAD; | ||||
131 | $method =~ s/.*:://; | ||||
132 | |||||
133 | $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/ | ||||
134 | or croak "Undefined subroutine &$AUTOLOAD called"; | ||||
135 | |||||
136 | my $class = _header_pkg_name $method; | ||||
137 | |||||
138 | unless(eval "require $class") | ||||
139 | { my $tag = $method; | ||||
140 | $tag =~ s/_/-/g; | ||||
141 | $tag = join '-', | ||||
142 | map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) } | ||||
143 | split /\-/, $tag; | ||||
144 | |||||
145 | no strict; | ||||
146 | @{"${class}::ISA"} = qw(Mail::Field::Generic); | ||||
147 | *{"${class}::tag"} = sub { $tag }; | ||||
148 | } | ||||
149 | |||||
150 | Mail::Field->can($method) | ||||
151 | or $class->register($method); | ||||
152 | |||||
153 | goto &$AUTOLOAD; | ||||
154 | } | ||||
155 | |||||
156 | |||||
157 | # Of course, the functionality should have been in the Mail::Header class | ||||
158 | sub extract | ||||
159 | { my ($class, $tag, $head) = (shift, shift, shift); | ||||
160 | |||||
161 | my $method = lc $tag; | ||||
162 | $method =~ tr/-/_/; | ||||
163 | |||||
164 | if(@_==0 && wantarray) | ||||
165 | { my @ret; | ||||
166 | my $text; # need real copy! | ||||
167 | foreach $text ($head->get($tag)) | ||||
168 | { chomp $text; | ||||
169 | push @ret, $class->$method($text); | ||||
170 | } | ||||
171 | return @ret; | ||||
172 | } | ||||
173 | |||||
174 | my $idx = shift || 0; | ||||
175 | my $text = $head->get($tag,$idx) | ||||
176 | or return undef; | ||||
177 | |||||
178 | chomp $text; | ||||
179 | $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 | { my ($self, %arg) = @_; | ||||
188 | %$self = (); | ||||
189 | $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 | { my $class = ref shift; | ||||
197 | confess "parse() not implemented"; | ||||
198 | } | ||||
199 | |||||
200 | #------------- | ||||
201 | |||||
202 | sub stringify { confess "stringify() not implemented" } | ||||
203 | |||||
204 | |||||
205 | sub tag | ||||
206 | { my $thing = shift; | ||||
207 | my $tag = ref($thing) || $thing; | ||||
208 | $tag =~ s/.*:://; | ||||
209 | $tag =~ s/_/-/g; | ||||
210 | |||||
211 | join '-', | ||||
212 | map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) } | ||||
213 | split /\-/, $tag; | ||||
214 | } | ||||
215 | |||||
216 | |||||
217 | sub set(@) { confess "set() not implemented" } | ||||
218 | |||||
219 | # prevent the calling of AUTOLOAD for DESTROY :-) | ||||
220 | sub DESTROY {} | ||||
221 | |||||
222 | #------------- | ||||
223 | |||||
224 | sub text | ||||
225 | { my $self = shift; | ||||
226 | @_ ? $self->parse(@_) : $self->stringify; | ||||
227 | } | ||||
228 | |||||
229 | #------------- | ||||
230 | |||||
231 | 1; |