Net/XMPP2/Util.pm

package Net::XMPP2::Util;
use strict;
use Encode;
use Net::LibIDN qw/idn_prep_name idn_prep_resource idn_prep_node/;
use Net::XMPP2::Namespaces qw/xmpp_ns_maybe/;
require Exporter;
our @EXPORT_OK = qw/resourceprep nodeprep prep_join_jid join_jid
                    split_jid stringprep_jid prep_bare_jid bare_jid
                    is_bare_jid simxml dump_twig_xml install_default_debug_dump/;
our @ISA = qw/Exporter/;

=head1 NAME

Net::XMPP2::Util - Utility functions for Net::XMPP2

=head1 SYNOPSIS

   use Net::XMPP2::Util qw/split_jid/;
   ...

=head1 FUNCTIONS

These functions can be exported if you want:

=over 4

=item B<resourceprep ($string)>

This function applies the stringprep profile for resources to C<$string>
and returns the result.

=cut

sub resourceprep {
   my ($str) = @_;
   decode_utf8 (idn_prep_resource (encode_utf8 ($str), 'UTF-8'))
}

=item B<nodeprep ($string)>

This function applies the stringprep profile for nodes to C<$string>
and returns the result.

=cut

sub nodeprep {
   my ($str) = @_;
   decode_utf8 (idn_prep_node (encode_utf8 ($str), 'UTF-8'))
}

=item B<prep_join_jid ($node, $domain, $resource)>

This function joins the parts C<$node>, C<$domain> and C<$resource>
to a full jid and applies stringprep profiles. If the profiles couldn't
be applied undef will be returned.

=cut

sub prep_join_jid {
   my ($node, $domain, $resource) = @_;
   my $jid = "";

   if ($node ne '') {
      $node = nodeprep ($node);
      return undef unless defined $node;
      $jid .= "$node\@";
   }

   $domain = $domain; # TODO: apply IDNA!
   $jid .= $domain;

   if ($resource ne '') {
      $resource = resourceprep ($resource);
      return undef unless defined $resource;
      $jid .= "/$resource";
   }

   $jid
}

=item B<join_jid ($user, $domain, $resource)>

This is a plain concatenation of C<$user>, C<$domain> and C<$resource>
without stringprep.

See also L<prep_join_jid>

=cut

sub join_jid {
   my ($node, $domain, $resource) = @_;
   my $jid = "";
   $jid .= "$node\@" if $node ne '';
   $jid .= $domain;
   $jid .= "/$resource" if $resource ne '';
   $jid
}

=item B<split_jid ($jid)>

This function splits up the C<$jid> into user/node, domain and resource
part and will return them as list.

   my ($user, $host, $res) = split_jid ($jid);

=cut

sub split_jid {
   my ($jid) = @_;
   if ($jid =~ /^([^@]*)@?([^\/]+)\/?(.*)$/) {
      return ($1, $2, $3);
   } else {
      return (undef, undef, undef);
   }
}

=item B<stringprep_jid ($jid)>

This applies stringprep to all parts of the jid according to the RFC 3920.
Use this if you want to compare two jids like this:

   stringprep_jid ($jid_a) eq stringprep_jid ($jid_b)

This function returns undef if the C<$jid> couldn't successfully be parsed
and the preparations done.

=cut

sub stringprep_jid {
   my ($jid) = @_;
   my ($user, $host, $res) = split_jid ($jid);
   return undef unless defined ($user) || defined ($host) || defined ($res);
   return prep_join_jid ($user, $host, $res);
}

=item B<prep_bare_jid ($jid)>

This function makes the jid C<$jid> a bare jid, meaning:
it will strip off the resource part. With stringprep.

=cut

sub prep_bare_jid {
   my ($jid) = @_;
   my ($user, $host, $res) = split_jid ($jid);
   prep_join_jid ($user, $host)
}

=item B<bare_jid ($jid)>

This function makes the jid C<$jid> a bare jid, meaning:
it will strip off the resource part. But without stringprep.

=cut

sub bare_jid {
   my ($jid) = @_;
   my ($user, $host, $res) = split_jid ($jid);
   join_jid ($user, $host)
}

=item B<is_bare_jid ($jid)>

This method returns a boolean which indicates whether C<$jid> is a 
bare JID.

=cut

sub is_bare_jid {
   my ($jid) = @_;
   my ($user, $host, $res) = split_jid ($jid);
   defined $res
}

=item B<simxml ($w, %xmlstruct)>

This method takes a L<XML::Writer> as first argument (C<$w>) and the
rest key value pairs:

   simxml ($w,
      defns => '<xmlnamespace>',
      node => <node>,
      prefixes => { prefix => namespace, ... },
      fb_ns => '<fallbackxmlnamespace for all elementes without ns or dns field>',
   );

Where node is:

   <node> := {
                ns => '<xmlnamespace>',
                name => 'tagname',
                attrs => [ ['name', 'value'], ... ],
                childs => [ <node>, ... ]
             }
           | {
                dns => '<xmlnamespace>',  # dns will set that namespace to the default namespace before using it.
                name => 'tagname',
                attrs => [ ['name', 'value'], ... ],
                childs => [ <node>, ... ]
             }
           | "textnode"

Please note: C<childs> stands for C<child sequence> :-)

=back

=cut

sub simxml {
   my ($w, %desc) = @_;

   if (my $n = $desc{defns}) {
      $w->addPrefix (xmpp_ns_maybe ($n), '');
   }

   if (my $p = $desc{prefixes}) {
      for (keys %{$p || {}}) {
         $w->addPrefix (xmpp_ns_maybe ($_), $p->{$_});
      }
   }

   my $node = $desc{node};

   if (not defined $node) {
      return;

   } elsif (ref ($node)) {
      my $ns = $node->{dns} ? $node->{dns} : $node->{ns};
      $ns = $ns ? $ns : $desc{fb_ns};
      $ns = xmpp_ns_maybe ($ns);
      my $tag = $ns ? [$ns, $node->{name}] : $node->{name};

      if (@{$node->{childs} || []}) {

         $w->startTag ($tag, @{$node->{attrs} || []});

            my (@args);
            if ($node->{defns}) { @args = (defns => $node->{defns}) }

            for (@{$node->{childs}}) {
               if (ref ($_) && $_->{dns}) { push @args, (defns => $_->{dns}) }
               if (ref ($_) && $_->{ns})  {
                  push @args, (fb_ns => $_->{ns})
               } else {
                  push @args, (fb_ns => $desc{fb_ns})
               }
               simxml ($w, node => $_, @args)
            }

         $w->endTag;

      } else {
         $w->emptyTag ($tag, @{$node->{attrs} || []});
      }
   } else {
      $w->characters ($node);
   }
}


sub dump_twig_xml {
   my $data = shift;
   require XML::Twig;
   my $t = XML::Twig->new;
   if ($t->safe_parse ("<deb>$data</deb>")) {
      $t->set_pretty_print ('indented');
      return ($t->sprint . "\n");
   } else {
      return "$data\n";
   }
}

sub install_default_debug_dump {
   my ($con) = @_;
   $con->reg_cb (
      debug_recv => sub {
         my ($con, $data) = @_;
         printf "recv>> %s:%d\n%s", $con->{host}, $con->{port}, dump_twig_xml ($data)
      },
      debug_send => sub {
         my ($con, $data) = @_;
         printf "send<< %s:%d\n%s", $con->{host}, $con->{port}, dump_twig_xml ($data)
      },
   )
}

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Net::XMPP2
Revision:	1.12
Committed:	Fri Jul 20 20:41:48 2007 UTC (19 years, 2 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.11:	+15 -1 lines
Log Message:	lots of changes. added as_string to Net::XMPP2::Node to restore the original xml document part of a stanza or subtree. also implemented the jabber component protocol.
#	User	Rev	Content
1	elmex	1.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	elmex	1.9	use Net::XMPP2::Namespaces qw/xmpp_ns_maybe/;
6	elmex	1.5	require Exporter;
7	elmex	1.7	our @EXPORT_OK = qw/resourceprep nodeprep prep_join_jid join_jid
8			split_jid stringprep_jid prep_bare_jid bare_jid
9	elmex	1.12	is_bare_jid simxml dump_twig_xml install_default_debug_dump/;
10	elmex	1.5	our @ISA = qw/Exporter/;
11	elmex	1.1
12			=head1 NAME
13
14			Net::XMPP2::Util - Utility functions for Net::XMPP2
15
16			=head1 SYNOPSIS
17
18	elmex	1.7	use Net::XMPP2::Util qw/split_jid/;
19	elmex	1.1	...
20
21			=head1 FUNCTIONS
22
23	elmex	1.7	These functions can be exported if you want:
24
25			=over 4
26
27			=item B<resourceprep ($string)>
28	elmex	1.1
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	elmex	1.7	=item B<nodeprep ($string)>
40	elmex	1.1
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	elmex	1.7	=item B<prep_join_jid ($node, $domain, $resource)>
52	elmex	1.1
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	elmex	1.2	sub prep_join_jid {
60	elmex	1.1	my ($node, $domain, $resource) = @_;
61			my $jid = "";
62
63	elmex	1.6	if ($node ne '') {
64	elmex	1.1	$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	elmex	1.6	if ($resource ne '') {
73	elmex	1.1	$resource = resourceprep ($resource);
74			return undef unless defined $resource;
75			$jid .= "/$resource";
76			}
77
78			$jid
79			}
80
81	elmex	1.7	=item B<join_jid ($user, $domain, $resource)>
82	elmex	1.2
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	elmex	1.6	$jid .= "$node\@" if $node ne '';
94	elmex	1.2	$jid .= $domain;
95	elmex	1.6	$jid .= "/$resource" if $resource ne '';
96	elmex	1.2	$jid
97			}
98
99	elmex	1.7	=item B<split_jid ($jid)>
100	elmex	1.2
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	elmex	1.7	=item B<stringprep_jid ($jid)>
118	elmex	1.1
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	elmex	1.2	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	elmex	1.7	=item B<prep_bare_jid ($jid)>
137	elmex	1.2
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	elmex	1.7	=item B<bare_jid ($jid)>
150	elmex	1.2
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	elmex	1.1	}
161
162	elmex	1.7	=item B<is_bare_jid ($jid)>
163	elmex	1.3
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	elmex	1.8	=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	elmex	1.9	prefixes => { prefix => namespace, ... },
184			fb_ns => '<fallbackxmlnamespace for all elementes without ns or dns field>',
185	elmex	1.8	);
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	elmex	1.10	Please note: C<childs> stands for C<child sequence> :-)
204
205	elmex	1.7	=back
206
207	elmex	1.8	=cut
208
209			sub simxml {
210			my ($w, %desc) = @_;
211
212			if (my $n = $desc{defns}) {
213	elmex	1.9	$w->addPrefix (xmpp_ns_maybe ($n), '');
214	elmex	1.8	}
215
216			if (my $p = $desc{prefixes}) {
217			for (keys %{$p \|\| {}}) {
218	elmex	1.9	$w->addPrefix (xmpp_ns_maybe ($_), $p->{$_});
219	elmex	1.8	}
220			}
221
222			my $node = $desc{node};
223
224			if (not defined $node) {
225			return;
226
227			} elsif (ref ($node)) {
228	elmex	1.9	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	elmex	1.8
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	elmex	1.9	if (ref ($_) && $_->{ns}) {
243			push @args, (fb_ns => $_->{ns})
244			} else {
245			push @args, (fb_ns => $desc{fb_ns})
246			}
247	elmex	1.8	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	elmex	1.9
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	elmex	1.11	return "$data\n";
270	elmex	1.9	}
271			}
272
273	elmex	1.12	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	elmex	1.1	=head1 AUTHOR
288
289	elmex	1.7	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
290	elmex	1.1
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