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
|
|
|
|
|
|
|
|