1package AnyEvent::XMPP::Util; 2use strict; 3no warnings; 4use Encode; 5use Net::LibIDN qw/idn_prep_name idn_prep_resource idn_prep_node/; 6use AnyEvent::XMPP::Namespaces qw/xmpp_ns_maybe/; 7use Time::Local; 8require Exporter; 9our @EXPORT_OK = qw/resourceprep nodeprep prep_join_jid join_jid 10 split_jid split_uri stringprep_jid prep_bare_jid bare_jid 11 is_bare_jid simxml dump_twig_xml install_default_debug_dump 12 cmp_jid cmp_bare_jid 13 node_jid domain_jid res_jid 14 prep_node_jid prep_domain_jid prep_res_jid 15 from_xmpp_datetime to_xmpp_datetime to_xmpp_time 16 xmpp_datetime_as_timestamp 17 filter_xml_chars filter_xml_attr_hash_chars 18 /; 19our @ISA = qw/Exporter/; 20 21=head1 NAME 22 23AnyEvent::XMPP::Util - Utility functions for AnyEvent::XMPP 24 25=head1 SYNOPSIS 26 27 use AnyEvent::XMPP::Util qw/split_jid/; 28 ... 29 30=head1 FUNCTIONS 31 32These functions can be exported if you want: 33 34=over 4 35 36=item B<resourceprep ($string)> 37 38This function applies the stringprep profile for resources to C<$string> 39and returns the result. 40 41=cut 42 43sub resourceprep { 44 my ($str) = @_; 45 decode_utf8 (idn_prep_resource (encode_utf8 ($str), 'UTF-8')) 46} 47 48=item B<nodeprep ($string)> 49 50This function applies the stringprep profile for nodes to C<$string> 51and returns the result. 52 53=cut 54 55sub nodeprep { 56 my ($str) = @_; 57 decode_utf8 (idn_prep_node (encode_utf8 ($str), 'UTF-8')) 58} 59 60=item B<prep_join_jid ($node, $domain, $resource)> 61 62This function joins the parts C<$node>, C<$domain> and C<$resource> 63to a full jid and applies stringprep profiles. If the profiles couldn't 64be applied undef will be returned. 65 66=cut 67 68sub prep_join_jid { 69 my ($node, $domain, $resource) = @_; 70 my $jid = ""; 71 72 if ($node ne '') { 73 $node = nodeprep ($node); 74 return undef unless defined $node; 75 $jid .= "$node\@"; 76 } 77 78 $domain = $domain; # TODO: apply IDNA! 79 $jid .= $domain; 80 81 if ($resource ne '') { 82 $resource = resourceprep ($resource); 83 return undef unless defined $resource; 84 $jid .= "/$resource"; 85 } 86 87 $jid 88} 89 90=item B<join_jid ($user, $domain, $resource)> 91 92This is a plain concatenation of C<$user>, C<$domain> and C<$resource> 93without stringprep. 94 95See also L<prep_join_jid> 96 97=cut 98 99sub join_jid { 100 my ($node, $domain, $resource) = @_; 101 my $jid = ""; 102 $jid .= "$node\@" if $node ne ''; 103 $jid .= $domain; 104 $jid .= "/$resource" if $resource ne ''; 105 $jid 106} 107 108=item B<split_uri ($uri)> 109 110This function splits up the C<$uri> into service and node 111part and will return them as list. 112 113 my ($service, $node) = split_uri ($uri); 114 115=cut 116 117sub split_uri { 118 my ($uri) = @_; 119 if ($uri =~ /^xmpp:(\S+)\?\w+;node=(\S+)$/) { 120 return ($1, $2); 121 } else { 122 return (undef, $uri); 123 } 124} 125 126=item B<split_jid ($jid)> 127 128This function splits up the C<$jid> into user/node, domain and resource 129part and will return them as list. 130 131 my ($user, $host, $res) = split_jid ($jid); 132 133=cut 134 135sub split_jid { 136 my ($jid) = @_; 137 if ($jid =~ /^(?:([^@]*)@)?([^\/]+)(?:\/(.*))?$/) { 138 return ($1 eq '' ? undef : $1, $2, $3 eq '' ? undef : $3); 139 } else { 140 return (undef, undef, undef); 141 } 142} 143 144=item B<node_jid ($jid)> 145 146See C<prep_res_jid> below. 147 148=item B<domain_jid ($jid)> 149 150See C<prep_res_jid> below. 151 152=item B<res_jid ($jid)> 153 154See C<prep_res_jid> below. 155 156=item B<prep_node_jid ($jid)> 157 158See C<prep_res_jid> below. 159 160=item B<prep_domain_jid ($jid)> 161 162See C<prep_res_jid> below. 163 164=item B<prep_res_jid ($jid)> 165 166These functions return the corresponding parts of a JID. 167The C<prep_> prefixed JIDs return the stringprep'ed versions. 168 169=cut 170 171sub node_jid { (split_jid ($_[0]))[0] } 172sub domain_jid { (split_jid ($_[0]))[1] } 173sub res_jid { (split_jid ($_[0]))[2] } 174 175sub prep_node_jid { nodeprep (node_jid ($_[0])) } 176sub prep_domain_jid { (domain_jid ($_[0])) } 177sub prep_res_jid { resourceprep (res_jid ($_[0])) } 178 179=item B<stringprep_jid ($jid)> 180 181This applies stringprep to all parts of the jid according to the RFC 3920. 182Use this if you want to compare two jids like this: 183 184 stringprep_jid ($jid_a) eq stringprep_jid ($jid_b) 185 186This function returns undef if the C<$jid> couldn't successfully be parsed 187and the preparations done. 188 189=cut 190 191sub stringprep_jid { 192 my ($jid) = @_; 193 my ($user, $host, $res) = split_jid ($jid); 194 return undef unless defined ($user) || defined ($host) || defined ($res); 195 return prep_join_jid ($user, $host, $res); 196} 197 198=item B<cmp_jid ($jid1, $jid2)> 199 200This function compares two jids C<$jid1> and C<$jid2> 201whether they are equal. 202 203=cut 204 205sub cmp_jid { 206 my ($jid1, $jid2) = @_; 207 stringprep_jid ($jid1) eq stringprep_jid ($jid2) 208} 209 210=item B<cmp_bare_jid ($jid1, $jid2)> 211 212This function compares two jids C<$jid1> and C<$jid2> whether their 213bare part is equal. 214 215=cut 216 217sub cmp_bare_jid { 218 my ($jid1, $jid2) = @_; 219 cmp_jid (bare_jid ($jid1), bare_jid ($jid2)) 220} 221 222=item B<prep_bare_jid ($jid)> 223 224This function makes the jid C<$jid> a bare jid, meaning: 225it will strip off the resource part. With stringprep. 226 227=cut 228 229sub prep_bare_jid { 230 my ($jid) = @_; 231 my ($user, $host, $res) = split_jid ($jid); 232 prep_join_jid ($user, $host) 233} 234 235=item B<bare_jid ($jid)> 236 237This function makes the jid C<$jid> a bare jid, meaning: 238it will strip off the resource part. But without stringprep. 239 240=cut 241 242sub bare_jid { 243 my ($jid) = @_; 244 my ($user, $host, $res) = split_jid ($jid); 245 join_jid ($user, $host) 246} 247 248=item B<is_bare_jid ($jid)> 249 250This method returns a boolean which indicates whether C<$jid> is a 251bare JID. 252 253=cut 254 255sub is_bare_jid { 256 my ($jid) = @_; 257 my ($user, $host, $res) = split_jid ($jid); 258 not defined $res 259} 260 261=item B<filter_xml_chars ($string)> 262 263This function removes all characters from C<$string> which 264are not allowed in XML and returns the new string. 265 266=cut 267 268sub filter_xml_chars($) { 269 my ($string) = @_; 270 $string =~ s/[^\x{9}\x{A}\x{D}\x{20}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFFFF}]+//g; 271 $string 272} 273 274=item B<filter_xml_attr_hash_chars ($hashref)> 275 276This runs all values of the C<$hashref> through C<filter_xml_chars> (see above) 277and changes them in-place! 278 279=cut 280 281sub filter_xml_attr_hash_chars { 282 my ($hash) = @_; 283 $hash->{$_} = filter_xml_chars $hash->{$_} for keys %$hash 284} 285 286 287=item B<simxml ($w, %xmlstruct)> 288 289This function takes a L<XML::Writer> as first argument (C<$w>) and the 290rest key value pairs: 291 292 simxml ($w, 293 defns => '<xmlnamespace>', 294 node => <node>, 295 prefixes => { prefix => namespace, ... }, 296 ); 297 298Where node is: 299 300 <node> := { 301 ns => '<xmlnamespace>', 302 name => 'tagname', 303 attrs => [ 'name', 'value', 'name2', 'value2', ... ], 304 childs => [ <node>, ... ] 305 } 306 | { 307 dns => '<xmlnamespace>', # this will set that namespace to 308 # the default namespace before using it. 309 name => 'tagname', 310 attrs => [ 'name', 'value', 'name2', 'value2', ... ], 311 childs => [ <node>, ... ] 312 } 313 | sub { my ($w) = @_; ... } # with $w being a XML::Writer object 314 | "textnode" 315 316Please note: C<childs> stands for C<child sequence> :-) 317 318Also note that if you omit the C<ns> key for nodes there is a fall back 319to the namespace of the parent element or the last default namespace. 320This makes it easier to write things like this: 321 322 { 323 defns => 'muc_owner', 324 node => { name => 'query' } 325 } 326 327(Without having to include C<ns> in the node.) 328 329Please note that all attribute values and character data will be filtered 330by C<filter_xml_chars>. 331 332This is a bigger example: 333 334 ... 335 336 $msg->append_creation( sub { 337 my($w) = @_; 338 simxml($w, 339 defns => 'muc_user', # sets the default namepsace for all following elements 340 node => { 341 name => 'x', # element 'x' in namespace 'muc_user' 342 childs => [ 343 { 344 'name' => 'invite', # element 'invite' in namespace 'muc_user' 345 'attrs' => [ 'to', $to_jid ], # to="$to_jid" attribute for 'invite' 346 'childs' => [ 347 { # the <reason>$reason</reason> element in the invite element 348 'name' => 'reason', 349 childs => [ $reason ] 350 } 351 ], 352 } 353 ] 354 } 355 ); 356 }); 357 358=cut 359 360sub simxml { 361 my ($w, %desc) = @_; 362 363 if (my $n = $desc{defns}) { 364 $w->addPrefix (xmpp_ns_maybe ($n), ''); 365 } 366 unless (exists $desc{fb_ns}) { 367 $desc{fb_ns} = $desc{defns}; 368 } 369 370 if (my $p = $desc{prefixes}) { 371 for (keys %{$p || {}}) { 372 $w->addPrefix (xmpp_ns_maybe ($_), $p->{$_}); 373 } 374 } 375 376 my $node = $desc{node}; 377 378 if (not defined $node) { 379 return; 380 381 } elsif (ref ($node) eq 'CODE') { 382 $node->($w); 383 384 } elsif (ref ($node)) { 385 my $ns = $node->{dns} ? $node->{dns} : $node->{ns}; 386 $ns = $ns ? $ns : $desc{fb_ns}; 387 $ns = xmpp_ns_maybe ($ns); 388 389 my $tag = $ns ? [$ns, $node->{name}] : $node->{name}; 390 391 my %attrs = @{$node->{attrs} || []}; 392 filter_xml_attr_hash_chars \%attrs; 393 394 if (@{$node->{childs} || []}) { 395 396 $w->startTag ($tag, %attrs); 397 398 my (@args); 399 if ($node->{defns}) { @args = (defns => $node->{defns}) } 400 401 for (@{$node->{childs}}) { 402 if (ref ($_) eq 'HASH' && $_->{dns}) { 403 push @args, (defns => $_->{dns}) 404 } 405 if (ref ($_) eq 'HASH' && $_->{ns}) { 406 push @args, (fb_ns => $_->{ns}) 407 } else { 408 push @args, (fb_ns => $desc{fb_ns}) 409 } 410 simxml ($w, node => $_, @args) 411 } 412 413 $w->endTag; 414 415 } else { 416 $w->emptyTag ($tag, %attrs); 417 } 418 } else { 419 $w->characters (filter_xml_chars $node); 420 } 421} 422 423=item B<to_xmpp_time ($sec, $min, $hour, $tz, $secfrac)> 424 425This function transforms a time to the XMPP date time format. 426The meanings and value ranges of C<$sec>, ..., C<$hour> are explained 427in the perldoc of Perl's builtin C<localtime>. 428 429C<$tz> has to be either C<"UTC"> or of the form C<[+-]hh:mm>, it can be undefined 430and wont occur in the time string then. 431 432C<$secfrac> are optional and can be the fractions of the second. 433 434See also XEP-0082. 435 436=cut 437 438sub to_xmpp_time { 439 my ($sec, $min, $hour, $tz, $secfrac) = @_; 440 my $frac = sprintf "%.3f", $secfrac; 441 substr $frac, 0, 1, ''; 442 sprintf "%02d:%02d:%02d%s%s", 443 $hour, $min, $sec, 444 (defined $secfrac ? $frac : ""), 445 (defined $tz ? $tz : "") 446} 447 448=item B<to_xmpp_datetime ($sec,$min,$hour,$mday,$mon,$year,$tz, $secfrac)> 449 450This function transforms a time to the XMPP date time format. 451The meanings of C<$sec>, ..., C<$year> are explained in the perldoc 452of Perl's C<localtime> builtin and have the same value ranges. 453 454C<$tz> has to be either C<"Z"> (for UTC) or of the form C<[+-]hh:mm> (offset 455from UTC), if it is undefined "Z" will be used. 456 457C<$secfrac> are optional and can be the fractions of the second. 458 459See also XEP-0082. 460 461=cut 462 463sub to_xmpp_datetime { 464 my ($sec, $min, $hour, $mday, $mon, $year, $tz, $secfrac) = @_; 465 my $time = to_xmpp_time ($sec, $min, $hour, (defined $tz ? $tz : 'Z'), $secfrac); 466 sprintf "%04d-%02d-%02dT%s", $year + 1900, $mon + 1, $mday, $time; 467} 468 469=item B<from_xmpp_datetime ($string)> 470 471This function transforms the C<$string> which is either a time or datetime in XMPP 472format. If the string was not in the right format an empty list is returned. 473Otherwise this is returned: 474 475 my ($sec, $min, $hour, $mday, $mon, $year, $tz, $secfrac) 476 = from_xmpp_datetime ($string); 477 478For the value ranges and semantics of C<$sec>, ..., C<$srcfrac> please look at the 479documentation for C<to_xmpp_datetime>. 480 481C<$tz> and C<$secfrac> might be undefined. 482 483If C<$tz> is undefined the timezone is to be assumed to be UTC. 484 485If C<$string> contained just a time C<$mday>, C<$mon> and C<$year> will be undefined. 486 487See also XEP-0082. 488 489=cut 490 491sub from_xmpp_datetime { 492 my ($string) = @_; 493 494 if ($string !~ 495 /^(?:(\d{4})-?(\d{2})-?(\d{2})T)?(\d{2}):(\d{2}):(\d{2})(\.\d{3})?(Z|[+-]\d{2}:\d{2})?/) 496 { 497 return () 498 } 499 500 ($6, $5, $4, 501 ($3 ne '' ? $3 : undef), 502 ($2 ne '' ? $2 - 1 : undef), 503 ($1 ne '' ? $1 - 1900 : undef), 504 ($8 ne '' ? $8 : undef), 505 ($7 ne '' ? $7 : undef)) 506} 507 508=item B<xmpp_datetime_as_timestamp ($string)> 509 510This function takes the same arguments as C<from_xmpp_datetime>, but returns a 511unix timestamp, like C<time ()> would. 512 513This function requires the L<POSIX> module. 514 515=cut 516 517sub xmpp_datetime_as_timestamp { 518 my ($string) = @_; 519 my ($s, $m, $h, $md, $mon, $year, $tz) = from_xmpp_datetime ($string); 520 return 0 unless defined $h; 521 522 my $ts = timegm ($s, $m, $h, $md, $mon, $year); 523 524 if ($tz =~ /^([+-])(\d{2}):(\d{2})$/) { 525 $ts += ($1 eq '-' ? -1 : 1) * ($2 * 3600 + $3 * 60) 526 } 527 528 $ts 529} 530 531sub dump_twig_xml { 532 my $data = shift; 533 require XML::Twig; 534 my $t = XML::Twig->new; 535 if ($t->safe_parse ("<deb>$data</deb>")) { 536 $t->set_pretty_print ('indented'); 537 return ($t->sprint . "\n"); 538 } else { 539 return "$data\n"; 540 } 541} 542 543sub install_default_debug_dump { 544 my ($con) = @_; 545 $con->reg_cb ( 546 debug_recv => sub { 547 my ($con, $data) = @_; 548 printf "recv>> %s:%d\n%s", $con->{host}, $con->{port}, dump_twig_xml ($data) 549 }, 550 debug_send => sub { 551 my ($con, $data) = @_; 552 printf "send<< %s:%d\n%s", $con->{host}, $con->{port}, dump_twig_xml ($data) 553 }, 554 ) 555} 556 557=back 558 559=head1 AUTHOR 560 561Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >> 562 563=head1 COPYRIGHT & LICENSE 564 565Copyright 2007, 2008 Robin Redeker, all rights reserved. 566 567This program is free software; you can redistribute it and/or modify it 568under the same terms as Perl itself. 569 570=cut 571 5721; # End of AnyEvent::XMPP 573