lib/Sietima/HeaderURI.pm


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

package Sietima::HeaderURI; 
use Moo;
use Sietima::Policy;
use Sietima::Types qw(Address AddressFromStr is_Address);
use Types::Standard qw(Str ClassName HashRef Optional);
use Type::Params qw(compile);
use Types::URI qw(Uri is_Uri);
use namespace::clean;
 
has uri => (
    is => 'ro',
    isa => Uri,
    required => 1,
    coerce => 1,
);
 
has comment => (
    is => 'ro',
    isa => Str,
);
 
# if it's not an Email::Address obect, we'll just take it as a string: 
# it could be a non-mailto URI, see RFC 2369 "The Use of URLs as 
# Meta-Syntax for Core Mail List Commands and their Transport through 
# Message Header Fields" 
 
around BUILDARGS => sub {
    my ($orig, $class, @args) = @_;
    if (@args != 1 or ref($args[0]) eq 'HASH') {
        return $class->$orig(@args);
    }
 
    my $item = $args[0];
    if (is_Address($item)) {
        return Sietima::HeaderURI->_args_from_address($item);
    }
    elsif (is_Uri($item)) {
        return { uri => $item };
    }
    elsif (my $address = AddressFromStr->coerce($item)) {
        return Sietima::HeaderURI->_args_from_address($address);
    }
    else {
        return { uri => $item };
    };
};
 
sub _args_from_address {
    my ($class, $address, $query) = @_;
    $query ||= {};
 
    my $uri = URI->new($address->address,'mailto');
    $uri->query_form($query->%*);
 
    return {
        uri => $uri,
        comment => $address->comment,
    };
}
 
sub new_from_address {
    state $check = compile(
        ClassName,
        Address->plus_coercions(AddressFromStr),
        Optional[HashRef],
    );
    my ($class, $address, $query) = $check->(@_);
 
    return $class->new($class->_args_from_address($address,$query));
}
 
sub as_header_raw {
    my ($self) = @_;
 
    my $str = sprintf '<%s>',$self->uri;
    if (my $c = $self->comment) {
        $str .= ' '.$c;
    }
 
    return $str;
}
 
1;