File Coverage

blib/lib/AnyEvent/XMPP/Util.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package AnyEvent::XMPP::Util;
2 4     4   73366 use strict;
  4         9  
  4         164  
3 4     4   22 no warnings;
  4         9  
  4         124  
4 4     4   5179 use Encode;
  4         56824  
  4         449  
5 4     4   12676 use Net::LibIDN qw/idn_prep_name idn_prep_resource idn_prep_node/;
  0            
  0            
6             use AnyEvent::XMPP::Namespaces qw/xmpp_ns_maybe/;
7             use Time::Local;
8             require Exporter;
9             our @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             /;
19             our @ISA = qw/Exporter/;
20              
21             =head1 NAME
22              
23             AnyEvent::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              
32             These functions can be exported if you want:
33              
34             =over 4
35              
36             =item B
37              
38             This function applies the stringprep profile for resources to C<$string>
39             and returns the result.
40              
41             =cut
42              
43             sub resourceprep {
44             my ($str) = @_;
45             decode_utf8 (idn_prep_resource (encode_utf8 ($str), 'UTF-8'))
46             }
47              
48             =item B
49              
50             This function applies the stringprep profile for nodes to C<$string>
51             and returns the result.
52              
53             =cut
54              
55             sub nodeprep {
56             my ($str) = @_;
57             decode_utf8 (idn_prep_node (encode_utf8 ($str), 'UTF-8'))
58             }
59              
60             =item B
61              
62             This function joins the parts C<$node>, C<$domain> and C<$resource>
63             to a full jid and applies stringprep profiles. If the profiles couldn't
64             be applied undef will be returned.
65              
66             =cut
67              
68             sub 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
91              
92             This is a plain concatenation of C<$user>, C<$domain> and C<$resource>
93             without stringprep.
94              
95             See also L
96              
97             =cut
98              
99             sub 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
109              
110             This function splits up the C<$uri> into service and node
111             part and will return them as list.
112              
113             my ($service, $node) = split_uri ($uri);
114              
115             =cut
116              
117             sub 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
127              
128             This function splits up the C<$jid> into user/node, domain and resource
129             part and will return them as list.
130              
131             my ($user, $host, $res) = split_jid ($jid);
132              
133             =cut
134              
135             sub 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
145              
146             See C below.
147              
148             =item B
149              
150             See C below.
151              
152             =item B
153              
154             See C below.
155              
156             =item B
157              
158             See C below.
159              
160             =item B
161              
162             See C below.
163              
164             =item B
165              
166             These functions return the corresponding parts of a JID.
167             The C prefixed JIDs return the stringprep'ed versions.
168              
169             =cut
170              
171             sub node_jid { (split_jid ($_[0]))[0] }
172             sub domain_jid { (split_jid ($_[0]))[1] }
173             sub res_jid { (split_jid ($_[0]))[2] }
174              
175             sub prep_node_jid { nodeprep (node_jid ($_[0])) }
176             sub prep_domain_jid { (domain_jid ($_[0])) }
177             sub prep_res_jid { resourceprep (res_jid ($_[0])) }
178              
179             =item B
180              
181             This applies stringprep to all parts of the jid according to the RFC 3920.
182             Use this if you want to compare two jids like this:
183              
184             stringprep_jid ($jid_a) eq stringprep_jid ($jid_b)
185              
186             This function returns undef if the C<$jid> couldn't successfully be parsed
187             and the preparations done.
188              
189             =cut
190              
191             sub 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
199              
200             This function compares two jids C<$jid1> and C<$jid2>
201             whether they are equal.
202              
203             =cut
204              
205             sub cmp_jid {
206             my ($jid1, $jid2) = @_;
207             stringprep_jid ($jid1) eq stringprep_jid ($jid2)
208             }
209              
210             =item B
211              
212             This function compares two jids C<$jid1> and C<$jid2> whether their
213             bare part is equal.
214              
215             =cut
216              
217             sub cmp_bare_jid {
218             my ($jid1, $jid2) = @_;
219             cmp_jid (bare_jid ($jid1), bare_jid ($jid2))
220             }
221              
222             =item B
223              
224             This function makes the jid C<$jid> a bare jid, meaning:
225             it will strip off the resource part. With stringprep.
226              
227             =cut
228              
229             sub 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
236              
237             This function makes the jid C<$jid> a bare jid, meaning:
238             it will strip off the resource part. But without stringprep.
239              
240             =cut
241              
242             sub bare_jid {
243             my ($jid) = @_;
244             my ($user, $host, $res) = split_jid ($jid);
245             join_jid ($user, $host)
246             }
247              
248             =item B
249              
250             This method returns a boolean which indicates whether C<$jid> is a
251             bare JID.
252              
253             =cut
254              
255             sub is_bare_jid {
256             my ($jid) = @_;
257             my ($user, $host, $res) = split_jid ($jid);
258             not defined $res
259             }
260              
261             =item B
262              
263             This function removes all characters from C<$string> which
264             are not allowed in XML and returns the new string.
265              
266             =cut
267              
268             sub 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
275              
276             This runs all values of the C<$hashref> through C (see above)
277             and changes them in-place!
278              
279             =cut
280              
281             sub filter_xml_attr_hash_chars {
282             my ($hash) = @_;
283             $hash->{$_} = filter_xml_chars $hash->{$_} for keys %$hash
284             }
285              
286              
287             =item B
288              
289             This function takes a L as first argument (C<$w>) and the
290             rest key value pairs:
291              
292             simxml ($w,
293             defns => '',
294             node => ,
295             prefixes => { prefix => namespace, ... },
296             );
297              
298             Where node is:
299              
300             := {
301             ns => '',
302             name => 'tagname',
303             attrs => [ 'name', 'value', 'name2', 'value2', ... ],
304             childs => [ , ... ]
305             }
306             | {
307             dns => '', # this will set that namespace to
308             # the default namespace before using it.
309             name => 'tagname',
310             attrs => [ 'name', 'value', 'name2', 'value2', ... ],
311             childs => [ , ... ]
312             }
313             | sub { my ($w) = @_; ... } # with $w being a XML::Writer object
314             | "textnode"
315              
316             Please note: C stands for C :-)
317              
318             Also note that if you omit the C key for nodes there is a fall back
319             to the namespace of the parent element or the last default namespace.
320             This 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 in the node.)
328              
329             Please note that all attribute values and character data will be filtered
330             by C.
331              
332             This 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 element in the invite element
348             'name' => 'reason',
349             childs => [ $reason ]
350             }
351             ],
352             }
353             ]
354             }
355             );
356             });
357              
358             =cut
359              
360             sub 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
424              
425             This function transforms a time to the XMPP date time format.
426             The meanings and value ranges of C<$sec>, ..., C<$hour> are explained
427             in the perldoc of Perl's builtin C.
428              
429             C<$tz> has to be either C<"UTC"> or of the form C<[+-]hh:mm>, it can be undefined
430             and wont occur in the time string then.
431              
432             C<$secfrac> are optional and can be the fractions of the second.
433              
434             See also XEP-0082.
435              
436             =cut
437              
438             sub 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
449              
450             This function transforms a time to the XMPP date time format.
451             The meanings of C<$sec>, ..., C<$year> are explained in the perldoc
452             of Perl's C builtin and have the same value ranges.
453              
454             C<$tz> has to be either C<"Z"> (for UTC) or of the form C<[+-]hh:mm> (offset
455             from UTC), if it is undefined "Z" will be used.
456              
457             C<$secfrac> are optional and can be the fractions of the second.
458              
459             See also XEP-0082.
460              
461             =cut
462              
463             sub 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
470              
471             This function transforms the C<$string> which is either a time or datetime in XMPP
472             format. If the string was not in the right format an empty list is returned.
473             Otherwise this is returned:
474              
475             my ($sec, $min, $hour, $mday, $mon, $year, $tz, $secfrac)
476             = from_xmpp_datetime ($string);
477              
478             For the value ranges and semantics of C<$sec>, ..., C<$srcfrac> please look at the
479             documentation for C.
480              
481             C<$tz> and C<$secfrac> might be undefined.
482              
483             If C<$tz> is undefined the timezone is to be assumed to be UTC.
484              
485             If C<$string> contained just a time C<$mday>, C<$mon> and C<$year> will be undefined.
486              
487             See also XEP-0082.
488              
489             =cut
490              
491             sub 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
509              
510             This function takes the same arguments as C, but returns a
511             unix timestamp, like C
512              
513             This function requires the L module.
514              
515             =cut
516              
517             sub 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              
531             sub dump_twig_xml {
532             my $data = shift;
533             require XML::Twig;
534             my $t = XML::Twig->new;
535             if ($t->safe_parse ("$data")) {
536             $t->set_pretty_print ('indented');
537             return ($t->sprint . "\n");
538             } else {
539             return "$data\n";
540             }
541             }
542              
543             sub 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              
561             Robin Redeker, C<< >>, JID: C<< >>
562              
563             =head1 COPYRIGHT & LICENSE
564              
565             Copyright 2007, 2008 Robin Redeker, all rights reserved.
566              
567             This program is free software; you can redistribute it and/or modify it
568             under the same terms as Perl itself.
569              
570             =cut
571              
572             1; # End of AnyEvent::XMPP