1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
# This code is part of Perl distribution Mail-Message version 4.02.
# The POD got stripped from this file by OODoc version 3.06.
# For contributors see file ChangeLog.
# This software is copyright (c) 2001-2026 by Mark Overmeer.
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
package Mail::Message::Field::URIs;{
our $VERSION = '4.02';
}
use parent 'Mail::Message::Field::Structured';
use warnings;
use strict;
use Log::Report 'mail-message', import => [ qw/__x error/ ];
use URI ();
use Scalar::Util qw/blessed/;
#--------------------
#--------------------
sub init($)
{ my ($self, $args) = @_;
my ($body, @body);
if($body = delete $args->{body})
{ @body = ref $body eq 'ARRAY' ? @$body : ($body);
@body or return ();
}
$self->{MMFU_uris} = [];
if(@body > 1 || blessed $body[0])
{ $self->addURI($_) for @body;
}
elsif(defined $body)
{ $body = "<$body>\n" unless index($body, '<') >= 0;
$args->{body} = $body;
}
$self->SUPER::init($args);
}
sub parse($)
{ my ($self, $string) = @_;
my @raw = $string =~ m/\<([^>]+)\>/g; # simply ignore all but <>
$self->addURI($_) for @raw;
$self;
}
sub produceBody()
{ my @uris = sort map $_->as_string, $_[0]->URIs;
local $" = '>, <';
@uris ? "<@uris>" : undef;
}
#--------------------
sub addURI(@)
{ my $self = shift;
my $uri = blessed $_[0] ? shift : URI->new(@_);
push @{$self->{MMFU_uris}}, $uri->canonical if defined $uri;
delete $self->{MMFF_body};
$uri;
}
sub URIs() { @{ $_[0]->{MMFU_uris}} }
sub addAttribute($;@)
{ my $self = shift;
error __x"no attributes for URI fields.";
}
#--------------------
1;
|
