| 1 |
package Net::XMPP2::Util; |
| 2 |
use strict; |
| 3 |
use Encode; |
| 4 |
use Net::LibIDN qw/idn_prep_name idn_prep_resource idn_prep_node/; |
| 5 |
use Net::XMPP2::Namespaces qw/xmpp_ns_maybe/; |
| 6 |
require Exporter; |
| 7 |
our @EXPORT_OK = qw/resourceprep nodeprep prep_join_jid join_jid |
| 8 |
split_jid stringprep_jid prep_bare_jid bare_jid |
| 9 |
is_bare_jid simxml dump_twig_xml install_default_debug_dump/; |
| 10 |
our @ISA = qw/Exporter/; |
| 11 |
|
| 12 |
=head1 NAME |
| 13 |
|
| 14 |
Net::XMPP2::Util - Utility functions for Net::XMPP2 |
| 15 |
|
| 16 |
=head1 SYNOPSIS |
| 17 |
|
| 18 |
use Net::XMPP2::Util qw/split_jid/; |
| 19 |
... |
| 20 |
|
| 21 |
=head1 FUNCTIONS |
| 22 |
|
| 23 |
These functions can be exported if you want: |
| 24 |
|
| 25 |
=over 4 |
| 26 |
|
| 27 |
=item B<resourceprep ($string)> |
| 28 |
|
| 29 |
This function applies the stringprep profile for resources to C<$string> |
| 30 |
and returns the result. |
| 31 |
|
| 32 |
=cut |
| 33 |
|
| 34 |
sub resourceprep { |
| 35 |
my ($str) = @_; |
| 36 |
decode_utf8 (idn_prep_resource (encode_utf8 ($str), 'UTF-8')) |
| 37 |
} |
| 38 |
|
| 39 |
=item B<nodeprep ($string)> |
| 40 |
|
| 41 |
This function applies the stringprep profile for nodes to C<$string> |
| 42 |
and returns the result. |
| 43 |
|
| 44 |
=cut |
| 45 |
|
| 46 |
sub nodeprep { |
| 47 |
my ($str) = @_; |
| 48 |
decode_utf8 (idn_prep_node (encode_utf8 ($str), 'UTF-8')) |
| 49 |
} |
| 50 |
|
| 51 |
=item B<prep_join_jid ($node, $domain, $resource)> |
| 52 |
|
| 53 |
This function joins the parts C<$node>, C<$domain> and C<$resource> |
| 54 |
to a full jid and applies stringprep profiles. If the profiles couldn't |
| 55 |
be applied undef will be returned. |
| 56 |
|
| 57 |
=cut |
| 58 |
|
| 59 |
sub prep_join_jid { |
| 60 |
my ($node, $domain, $resource) = @_; |
| 61 |
my $jid = ""; |
| 62 |
|
| 63 |
if ($node ne '') { |
| 64 |
$node = nodeprep ($node); |
| 65 |
return undef unless defined $node; |
| 66 |
$jid .= "$node\@"; |
| 67 |
} |
| 68 |
|
| 69 |
$domain = $domain; # TODO: apply IDNA! |
| 70 |
$jid .= $domain; |
| 71 |
|
| 72 |
if ($resource ne '') { |
| 73 |
$resource = resourceprep ($resource); |
| 74 |
return undef unless defined $resource; |
| 75 |
$jid .= "/$resource"; |
| 76 |
} |
| 77 |
|
| 78 |
$jid |
| 79 |
} |
| 80 |
|
| 81 |
=item B<join_jid ($user, $domain, $resource)> |
| 82 |
|
| 83 |
This is a plain concatenation of C<$user>, C<$domain> and C<$resource> |
| 84 |
without stringprep. |
| 85 |
|
| 86 |
See also L<prep_join_jid> |
| 87 |
|
| 88 |
=cut |
| 89 |
|
| 90 |
sub join_jid { |
| 91 |
my ($node, $domain, $resource) = @_; |
| 92 |
my $jid = ""; |
| 93 |
$jid .= "$node\@" if $node ne ''; |
| 94 |
$jid .= $domain; |
| 95 |
$jid .= "/$resource" if $resource ne ''; |
| 96 |
$jid |
| 97 |
} |
| 98 |
|
| 99 |
=item B<split_jid ($jid)> |
| 100 |
|
| 101 |
This function splits up the C<$jid> into user/node, domain and resource |
| 102 |
part and will return them as list. |
| 103 |
|
| 104 |
my ($user, $host, $res) = split_jid ($jid); |
| 105 |
|
| 106 |
=cut |
| 107 |
|
| 108 |
sub split_jid { |
| 109 |
my ($jid) = @_; |
| 110 |
if ($jid =~ /^([^@]*)@?([^\/]+)\/?(.*)$/) { |
| 111 |
return ($1, $2, $3); |
| 112 |
} else { |
| 113 |
return (undef, undef, undef); |
| 114 |
} |
| 115 |
} |
| 116 |
|
| 117 |
=item B<stringprep_jid ($jid)> |
| 118 |
|
| 119 |
This applies stringprep to all parts of the jid according to the RFC 3920. |
| 120 |
Use this if you want to compare two jids like this: |
| 121 |
|
| 122 |
stringprep_jid ($jid_a) eq stringprep_jid ($jid_b) |
| 123 |
|
| 124 |
This function returns undef if the C<$jid> couldn't successfully be parsed |
| 125 |
and the preparations done. |
| 126 |
|
| 127 |
=cut |
| 128 |
|
| 129 |
sub stringprep_jid { |
| 130 |
my ($jid) = @_; |
| 131 |
my ($user, $host, $res) = split_jid ($jid); |
| 132 |
return undef unless defined ($user) || defined ($host) || defined ($res); |
| 133 |
return prep_join_jid ($user, $host, $res); |
| 134 |
} |
| 135 |
|
| 136 |
=item B<prep_bare_jid ($jid)> |
| 137 |
|
| 138 |
This function makes the jid C<$jid> a bare jid, meaning: |
| 139 |
it will strip off the resource part. With stringprep. |
| 140 |
|
| 141 |
=cut |
| 142 |
|
| 143 |
sub prep_bare_jid { |
| 144 |
my ($jid) = @_; |
| 145 |
my ($user, $host, $res) = split_jid ($jid); |
| 146 |
prep_join_jid ($user, $host) |
| 147 |
} |
| 148 |
|
| 149 |
=item B<bare_jid ($jid)> |
| 150 |
|
| 151 |
This function makes the jid C<$jid> a bare jid, meaning: |
| 152 |
it will strip off the resource part. But without stringprep. |
| 153 |
|
| 154 |
=cut |
| 155 |
|
| 156 |
sub bare_jid { |
| 157 |
my ($jid) = @_; |
| 158 |
my ($user, $host, $res) = split_jid ($jid); |
| 159 |
join_jid ($user, $host) |
| 160 |
} |
| 161 |
|
| 162 |
=item B<is_bare_jid ($jid)> |
| 163 |
|
| 164 |
This method returns a boolean which indicates whether C<$jid> is a |
| 165 |
bare JID. |
| 166 |
|
| 167 |
=cut |
| 168 |
|
| 169 |
sub is_bare_jid { |
| 170 |
my ($jid) = @_; |
| 171 |
my ($user, $host, $res) = split_jid ($jid); |
| 172 |
defined $res |
| 173 |
} |
| 174 |
|
| 175 |
=item B<simxml ($w, %xmlstruct)> |
| 176 |
|
| 177 |
This method takes a L<XML::Writer> as first argument (C<$w>) and the |
| 178 |
rest key value pairs: |
| 179 |
|
| 180 |
simxml ($w, |
| 181 |
defns => '<xmlnamespace>', |
| 182 |
node => <node>, |
| 183 |
prefixes => { prefix => namespace, ... }, |
| 184 |
fb_ns => '<fallbackxmlnamespace for all elementes without ns or dns field>', |
| 185 |
); |
| 186 |
|
| 187 |
Where node is: |
| 188 |
|
| 189 |
<node> := { |
| 190 |
ns => '<xmlnamespace>', |
| 191 |
name => 'tagname', |
| 192 |
attrs => [ ['name', 'value'], ... ], |
| 193 |
childs => [ <node>, ... ] |
| 194 |
} |
| 195 |
| { |
| 196 |
dns => '<xmlnamespace>', # dns will set that namespace to the default namespace before using it. |
| 197 |
name => 'tagname', |
| 198 |
attrs => [ ['name', 'value'], ... ], |
| 199 |
childs => [ <node>, ... ] |
| 200 |
} |
| 201 |
| "textnode" |
| 202 |
|
| 203 |
Please note: C<childs> stands for C<child sequence> :-) |
| 204 |
|
| 205 |
=back |
| 206 |
|
| 207 |
=cut |
| 208 |
|
| 209 |
sub simxml { |
| 210 |
my ($w, %desc) = @_; |
| 211 |
|
| 212 |
if (my $n = $desc{defns}) { |
| 213 |
$w->addPrefix (xmpp_ns_maybe ($n), ''); |
| 214 |
} |
| 215 |
|
| 216 |
if (my $p = $desc{prefixes}) { |
| 217 |
for (keys %{$p || {}}) { |
| 218 |
$w->addPrefix (xmpp_ns_maybe ($_), $p->{$_}); |
| 219 |
} |
| 220 |
} |
| 221 |
|
| 222 |
my $node = $desc{node}; |
| 223 |
|
| 224 |
if (not defined $node) { |
| 225 |
return; |
| 226 |
|
| 227 |
} elsif (ref ($node)) { |
| 228 |
my $ns = $node->{dns} ? $node->{dns} : $node->{ns}; |
| 229 |
$ns = $ns ? $ns : $desc{fb_ns}; |
| 230 |
$ns = xmpp_ns_maybe ($ns); |
| 231 |
my $tag = $ns ? [$ns, $node->{name}] : $node->{name}; |
| 232 |
|
| 233 |
if (@{$node->{childs} || []}) { |
| 234 |
|
| 235 |
$w->startTag ($tag, @{$node->{attrs} || []}); |
| 236 |
|
| 237 |
my (@args); |
| 238 |
if ($node->{defns}) { @args = (defns => $node->{defns}) } |
| 239 |
|
| 240 |
for (@{$node->{childs}}) { |
| 241 |
if (ref ($_) && $_->{dns}) { push @args, (defns => $_->{dns}) } |
| 242 |
if (ref ($_) && $_->{ns}) { |
| 243 |
push @args, (fb_ns => $_->{ns}) |
| 244 |
} else { |
| 245 |
push @args, (fb_ns => $desc{fb_ns}) |
| 246 |
} |
| 247 |
simxml ($w, node => $_, @args) |
| 248 |
} |
| 249 |
|
| 250 |
$w->endTag; |
| 251 |
|
| 252 |
} else { |
| 253 |
$w->emptyTag ($tag, @{$node->{attrs} || []}); |
| 254 |
} |
| 255 |
} else { |
| 256 |
$w->characters ($node); |
| 257 |
} |
| 258 |
} |
| 259 |
|
| 260 |
|
| 261 |
sub dump_twig_xml { |
| 262 |
my $data = shift; |
| 263 |
require XML::Twig; |
| 264 |
my $t = XML::Twig->new; |
| 265 |
if ($t->safe_parse ("<deb>$data</deb>")) { |
| 266 |
$t->set_pretty_print ('indented'); |
| 267 |
return ($t->sprint . "\n"); |
| 268 |
} else { |
| 269 |
return "$data\n"; |
| 270 |
} |
| 271 |
} |
| 272 |
|
| 273 |
sub install_default_debug_dump { |
| 274 |
my ($con) = @_; |
| 275 |
$con->reg_cb ( |
| 276 |
debug_recv => sub { |
| 277 |
my ($con, $data) = @_; |
| 278 |
printf "recv>> %s:%d\n%s", $con->{host}, $con->{port}, dump_twig_xml ($data) |
| 279 |
}, |
| 280 |
debug_send => sub { |
| 281 |
my ($con, $data) = @_; |
| 282 |
printf "send<< %s:%d\n%s", $con->{host}, $con->{port}, dump_twig_xml ($data) |
| 283 |
}, |
| 284 |
) |
| 285 |
} |
| 286 |
|
| 287 |
=head1 AUTHOR |
| 288 |
|
| 289 |
Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >> |
| 290 |
|
| 291 |
=head1 COPYRIGHT & LICENSE |
| 292 |
|
| 293 |
Copyright 2007 Robin Redeker, all rights reserved. |
| 294 |
|
| 295 |
This program is free software; you can redistribute it and/or modify it |
| 296 |
under the same terms as Perl itself. |
| 297 |
|
| 298 |
=cut |
| 299 |
|
| 300 |
1; # End of Net::XMPP2 |
