File Coverage

blib/lib/MarpaX/ESLIF/URI/tag.pm
Criterion Covered Total %
statement 39 39 100.0
branch 1 2 50.0
condition 4 4 100.0
subroutine 15 15 100.0
pod 10 10 100.0
total 69 70 98.5


line stmt bran cond sub pod time code
1 1     1   650 use strict;
  1         2  
  1         32  
2 1     1   5 use warnings FATAL => 'all';
  1         2  
  1         69  
3              
4             package MarpaX::ESLIF::URI::tag;
5              
6             # ABSTRACT: URI::tag syntax as per RFC4151
7              
8             our $AUTHORITY = 'cpan:JDDPAUSE'; # AUTHORITY
9              
10             our $VERSION = '0.006'; # VERSION
11              
12 1     1   5 use Class::Tiny::Antlers;
  1         2  
  1         29  
13 1     1   155 use MarpaX::ESLIF;
  1         2  
  1         20  
14 1     1   4 use DateTime;
  1         2  
  1         473  
15              
16             extends 'MarpaX::ESLIF::URI::mailto'; # inherit <addr spec> semantic
17              
18             has '_entity' => (is => 'rwp');
19             has '_authority' => (is => 'rwp');
20             has '_date' => (is => 'rwp');
21             has '_year' => (is => 'rwp');
22             has '_month' => (is => 'rwp');
23             has '_day' => (is => 'rwp');
24             has '_dnsname' => (is => 'rwp');
25             has '_email' => (is => 'rwp');
26              
27             #
28             # All attributes starting with an underscore are the result of parsing
29             #
30             __PACKAGE__->_generate_actions(qw/_entity _authority _date _year _month _day _dnsname _email/);
31              
32             #
33             # Constants
34             #
35             my $BNF = do { local $/; <DATA> };
36             my $GRAMMAR = MarpaX::ESLIF::Grammar->new(__PACKAGE__->eslif, __PACKAGE__->bnf);
37              
38              
39             sub bnf {
40 1     1 1 2 my ($class) = @_;
41              
42 1         5 join("\n", $BNF, MarpaX::ESLIF::URI::mailto->bnf) # We merge with mailto: BNF to get the <addr spec> syntax from it
43             };
44              
45              
46             sub grammar {
47 5     5 1 11 my ($class) = @_;
48              
49 5         304 return $GRAMMAR;
50             }
51              
52              
53             sub entity {
54 15     15 1 6393 my ($self, $type) = @_;
55              
56 15         46 return $self->_generic_getter('_entity', $type)
57             }
58              
59              
60             sub authority {
61 15     15 1 7961 my ($self, $type) = @_;
62              
63 15         46 return $self->_generic_getter('_authority', $type)
64             }
65              
66              
67             sub date {
68 15     15 1 12037 my ($self, $type) = @_;
69              
70 15         44 my $year = $self->_generic_getter('_year', $type); # Only year is required
71 15 50       45 return unless defined($year); # Indeed, there is no date
72 15   100     36 my $month = $self->_generic_getter('_month', $type) // '01';
73 15   100     38 my $day = $self->_generic_getter('_day', $type) // '01';
74              
75 15         75 return DateTime->new(year => $year, month => $month, day => $day, time_zone => 'UTC')
76             }
77              
78              
79             sub year {
80 15     15 1 12886 my ($self, $type) = @_;
81              
82 15         55 return $self->_generic_getter('_year', $type)
83             }
84              
85              
86             sub month {
87 15     15 1 5262 my ($self, $type) = @_;
88              
89 15         56 return $self->_generic_getter('_month', $type)
90             }
91              
92              
93             sub day {
94 15     15 1 7324 my ($self, $type) = @_;
95              
96 15         40 return $self->_generic_getter('_day', $type)
97             }
98              
99              
100             sub dnsname {
101 15     15 1 5746 my ($self, $type) = @_;
102              
103 15         48 return $self->_generic_getter('_dnsname', $type)
104             }
105              
106              
107             sub email {
108 15     15 1 5741 my ($self, $type) = @_;
109              
110 15         48 return $self->_generic_getter('_email', $type)
111             }
112              
113             # -------------
114             # Normalization
115             # -------------
116              
117              
118             1;
119              
120             =pod
121              
122             =encoding UTF-8
123              
124             =head1 NAME
125              
126             MarpaX::ESLIF::URI::tag - URI::tag syntax as per RFC4151
127              
128             =head1 VERSION
129              
130             version 0.006
131              
132             =head1 SUBROUTINES/METHODS
133              
134             MarpaX::ESLIF::URI::tag inherits, and eventually overwrites some, methods of MarpaX::ESLIF::URI::_generic.
135              
136             =head2 $class->bnf
137              
138             Overwrites parent's bnf implementation. Returns the BNF used to parse the input.
139              
140             =head2 $class->grammar
141              
142             Overwrite parent's grammar implementation. Returns the compiled BNF used to parse the input as MarpaX::ESLIF::Grammar singleton.
143              
144             =head2 $self->entity($type)
145              
146             Returns the tag entity. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
147              
148             =head2 $self->authority($type)
149              
150             Returns the tag authority. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
151              
152             =head2 $self->date($type)
153              
154             Returns the tag date as a L<DateTime> object. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
155              
156             Note that date in a tag URI is always expressed using UTC timezone.
157              
158             =head2 $self->year($type)
159              
160             Returns the tag date's year. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
161              
162             =head2 $self->month($type)
163              
164             Returns the tag date's month. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
165              
166             =head2 $self->day($type)
167              
168             Returns the tag date's day. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
169              
170             =head2 $self->dnsname($type)
171              
172             Returns the tag's DNS name when entity is made from it. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
173              
174             As per RFC4151: "It is RECOMMENDED that the domain name should be in lowercase form. Alternative formulations of the same authority name will be counted as distinct".
175              
176             =head2 $self->email($type)
177              
178             Returns the tag email when entity is made from it. C<$type> is either 'decoded' (default value), 'origin' or 'normalized'.
179              
180             =head1 NOTES
181              
182             Errata L<1485|https://www.rfc-editor.org/errata/eid1485> has been applied.
183              
184             =head1 SEE ALSO
185              
186             L<RFC4151|https://tools.ietf.org/html/rfc4151>, L<MarpaX::ESLIF::URI::_generic>, L<DateTime>
187              
188             =head1 AUTHOR
189              
190             Jean-Damien Durand <jeandamiendurand@free.fr>
191              
192             =head1 COPYRIGHT AND LICENSE
193              
194             This software is copyright (c) 2017 by Jean-Damien Durand.
195              
196             This is free software; you can redistribute it and/or modify it under
197             the same terms as the Perl 5 programming language system itself.
198              
199             =cut
200              
201             __DATA__
202             #
203             # Reference: https://tools.ietf.org/html/rfc4151#section-2.1
204             #
205             <tag URI> ::= <tag scheme> ":" <tag entity> ":" <tag specific> <tag fragment> action => _action_string
206              
207             <tag scheme> ::= "tag":i action => _action_scheme
208              
209             <tag entity> ::= <tag authority> "," <tag date> action => _action_entity
210             <tag authority> ::= DNSname action => _action_authority
211             | emailAddress action => _action_authority
212             <tag date> ::= year action => _action_date
213             | year "-" month action => _action_date
214             | year "-" month "-" day action => _action_date
215             year ::= DIGIT DIGIT DIGIT DIGIT action => _action_year
216             month ::= DIGIT DIGIT action => _action_month
217             day ::= DIGIT DIGIT action => _action_day
218             DNSname ::= DNScomp+ separator => "." action => _action_dnsname
219             DNScomp ::= alphaNum
220             | alphaNum DNSCompInner alphaNum
221             DNSCompInnerUnit ::= alphaNum
222             | "-"
223             DNSCompInner ::= DNSCompInnerUnit*
224             emailAddress ::= <addr spec> action => _action_email
225             alphaNum ::= DIGIT
226             | ALPHA
227             <tag specific> ::= <hier part> <URI query>
228             <tag fragment> ::= <URI fragment>
229              
230             #
231             # mailto syntax, so <addr spec> and further the generic syntax as well, will be appended here
232             #