File Coverage

blib/lib/DJabberd/JID.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package DJabberd::JID;
2 20     20   113 use strict;
  20         38  
  20         831  
3 20     20   115 use DJabberd::Util qw(exml);
  20         35  
  20         882  
4 20     20   22252 use Digest::SHA1;
  0            
  0            
5              
6             # Configurable via 'CaseSensitive' config option
7             our $CASE_SENSITIVE = 0;
8              
9             use overload
10             '""' => \&as_string_exml;
11              
12             use constant NODE => 0;
13             use constant DOMAIN => 1;
14             use constant RES => 2;
15             use constant AS_STRING => 3;
16             use constant AS_BSTRING => 4;
17             use constant AS_STREXML => 5;
18              
19             # Stringprep functions for converting to canonical form
20             use Unicode::Stringprep;
21             use Unicode::Stringprep::Mapping;
22             use Unicode::Stringprep::Prohibited;
23             my $nodeprep = Unicode::Stringprep->new(
24             3.2,
25             [
26             \@Unicode::Stringprep::Mapping::B1,
27             \@Unicode::Stringprep::Mapping::B2,
28             ],
29             'KC',
30             [
31             \@Unicode::Stringprep::Prohibited::C11,
32             \@Unicode::Stringprep::Prohibited::C12,
33             \@Unicode::Stringprep::Prohibited::C21,
34             \@Unicode::Stringprep::Prohibited::C22,
35             \@Unicode::Stringprep::Prohibited::C3,
36             \@Unicode::Stringprep::Prohibited::C4,
37             \@Unicode::Stringprep::Prohibited::C5,
38             \@Unicode::Stringprep::Prohibited::C6,
39             \@Unicode::Stringprep::Prohibited::C7,
40             \@Unicode::Stringprep::Prohibited::C8,
41             \@Unicode::Stringprep::Prohibited::C9,
42             [
43             0x0022, undef, # "
44             0x0026, undef, # &
45             0x0027, undef, # '
46             0x002F, undef, # /
47             0x003A, undef, # :
48             0x003C, undef, # <
49             0x003E, undef, # >
50             0x0040, undef, # @
51             ]
52             ],
53             1,
54             );
55             my $nameprep = Unicode::Stringprep->new(
56             3.2,
57             [
58             \@Unicode::Stringprep::Mapping::B1,
59             \@Unicode::Stringprep::Mapping::B2,
60             ],
61             'KC',
62             [
63             \@Unicode::Stringprep::Prohibited::C12,
64             \@Unicode::Stringprep::Prohibited::C22,
65             \@Unicode::Stringprep::Prohibited::C3,
66             \@Unicode::Stringprep::Prohibited::C4,
67             \@Unicode::Stringprep::Prohibited::C5,
68             \@Unicode::Stringprep::Prohibited::C6,
69             \@Unicode::Stringprep::Prohibited::C7,
70             \@Unicode::Stringprep::Prohibited::C8,
71             \@Unicode::Stringprep::Prohibited::C9,
72             ],
73             1,
74             );
75             my $resourceprep = Unicode::Stringprep->new(
76             3.2,
77             [
78             \@Unicode::Stringprep::Mapping::B1,
79             ],
80             'KC',
81             [
82             \@Unicode::Stringprep::Prohibited::C12,
83             \@Unicode::Stringprep::Prohibited::C21,
84             \@Unicode::Stringprep::Prohibited::C22,
85             \@Unicode::Stringprep::Prohibited::C3,
86             \@Unicode::Stringprep::Prohibited::C4,
87             \@Unicode::Stringprep::Prohibited::C5,
88             \@Unicode::Stringprep::Prohibited::C6,
89             \@Unicode::Stringprep::Prohibited::C7,
90             \@Unicode::Stringprep::Prohibited::C8,
91             \@Unicode::Stringprep::Prohibited::C9,
92             ],
93             1,
94             );
95              
96              
97             # returns DJabberd::JID object, or undef on failure due to invalid format
98             sub new {
99             #my ($class, $jidstring) = @_;
100              
101             # The following regex is loosely based on the EBNF grammar in
102             # JEP-0029. This JEP has actually been retracted, but seems to be
103             # the only reasonable spec for JID syntax.
104              
105             # NOTE: Currently this only supports US-ASCII characters.
106              
107             return undef unless $_[1] && $_[1] =~
108             m!^(?: ([\x29\x23-\x25\x28-\x2E\x30-\x39\x3B\x3D\x3F\x41-\x7E]{1,1023}) \@)? # $1: optional node
109             ([a-zA-Z0-9\.\-]{1,1023}) # $2: domain
110             (?: /(.{1,1023}) )? # $3: optional resource
111             $!x;
112              
113             # If we're in case-sensitive mode, for backwards-compatibility,
114             # then skip stringprep
115             return bless [ $1, $2, $3 ], $_[0] if $DJabberd::JID::CASE_SENSITIVE;
116              
117             # Stringprep uses regexes, so store these away first
118             my ($node, $host, $res) = ($1, $2, $3);
119              
120             return eval {
121             bless [
122             defined $node ? $nodeprep->($node) : undef,
123             $nameprep->($host),
124             defined $res ? $resourceprep->($res) : undef,
125             ], $_[0]
126             };
127             }
128              
129             sub is_bare {
130             return $_[0]->[RES] ? 0 : 1;
131             }
132              
133             sub node {
134             return $_[0]->[NODE];
135             }
136              
137             sub domain {
138             return $_[0]->[DOMAIN];
139             }
140              
141             sub resource {
142             return $_[0]->[RES];
143             }
144              
145             sub eq {
146             my ($self, $jid) = @_;
147             return $jid && $self->as_string eq $jid->as_string;
148             }
149              
150             sub as_string {
151             my $self = $_[0];
152             return $self->[AS_STRING] ||=
153             join('',
154             ($self->[NODE] ? ($self->[NODE], '@') : ()),
155             $self->[DOMAIN],
156             ($self->[RES] ? ('/', $self->[RES]) : ()));
157             }
158              
159             sub as_string_exml {
160             my $self = $_[0];
161             return $self->[AS_STREXML] ||=
162             exml($self->as_string);
163             }
164              
165             sub as_bare_string {
166             my $self = $_[0];
167             return $self->[AS_BSTRING] ||=
168             join('',
169             ($self->[NODE] ? ($self->[NODE], '@') : ()),
170             $self->[DOMAIN]);
171             }
172              
173             sub rand_resource {
174             Digest::SHA1::sha1_hex(rand() . rand() . rand());
175             }
176              
177             1;
178