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/;
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/;
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 },
   );

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"

=back

=cut

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

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

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

   my $node = $desc{node};

   if (not defined $node) {
      return;

   } elsif (ref ($node)) {
      my $ns  = $node->{dns} ? $node->{dns}         : $node->{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}) }
               simxml ($w, node => $_, @args)
            }

         $w->endTag;

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

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