AnyEvent::XMPP::Util - Utility functions for AnyEvent::XMPP

AnyEvent-XMPP documentation Contained in the AnyEvent-XMPP distribution.

Index

Code Index:

NAME

Top

AnyEvent::XMPP::Util - Utility functions for AnyEvent::XMPP

SYNOPSIS

Top

   use AnyEvent::XMPP::Util qw/split_jid/;
   ...

FUNCTIONS

Top

These functions can be exported if you want:

resourceprep ($string)

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

nodeprep ($string)

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

prep_join_jid ($node, $domain, $resource)

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

join_jid ($user, $domain, $resource)

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

See also prep_join_jid

split_uri ($uri)

This function splits up the $uri into service and node part and will return them as list.

   my ($service, $node) = split_uri ($uri);
split_jid ($jid)

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

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

See prep_res_jid below.

domain_jid ($jid)

See prep_res_jid below.

res_jid ($jid)

See prep_res_jid below.

prep_node_jid ($jid)

See prep_res_jid below.

prep_domain_jid ($jid)

See prep_res_jid below.

prep_res_jid ($jid)

These functions return the corresponding parts of a JID. The prep_ prefixed JIDs return the stringprep'ed versions.

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 $jid couldn't successfully be parsed and the preparations done.

cmp_jid ($jid1, $jid2)

This function compares two jids $jid1 and $jid2 whether they are equal.

cmp_bare_jid ($jid1, $jid2)

This function compares two jids $jid1 and $jid2 whether their bare part is equal.

prep_bare_jid ($jid)

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

bare_jid ($jid)

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

is_bare_jid ($jid)

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

filter_xml_chars ($string)

This function removes all characters from $string which are not allowed in XML and returns the new string.

filter_xml_attr_hash_chars ($hashref)

This runs all values of the $hashref through filter_xml_chars (see above) and changes them in-place!

simxml ($w, %xmlstruct)

This function takes a XML::Writer as first argument ($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', 'name2', 'value2', ... ],
                childs => [ <node>, ... ]
             }
           | {
                dns => '<xmlnamespace>',  # this will set that namespace to
                                          # the default namespace before using it.
                name => 'tagname',
                attrs => [ 'name', 'value', 'name2', 'value2', ... ],
                childs => [ <node>, ... ]
             }
           | sub { my ($w) = @_; ... } # with $w being a XML::Writer object
           | "textnode"

Please note: childs stands for child sequence :-)

Also note that if you omit the ns key for nodes there is a fall back to the namespace of the parent element or the last default namespace. This makes it easier to write things like this:

   {
      defns => 'muc_owner',
      node => { name => 'query' }
   }

(Without having to include ns in the node.)

Please note that all attribute values and character data will be filtered by filter_xml_chars.

This is a bigger example:

   ...

   $msg->append_creation( sub {
      my($w) = @_;
      simxml($w,
         defns => 'muc_user',   # sets the default namepsace for all following elements
         node  => {
            name => 'x',        # element 'x' in namespace 'muc_user'
            childs => [
               {
                  'name' => 'invite', # element 'invite' in namespace 'muc_user'
                  'attrs' => [ 'to', $to_jid ], # to="$to_jid" attribute for 'invite'
                  'childs' => [         
                     { # the <reason>$reason</reason> element in the invite element
                       'name' => 'reason', 
                       childs => [ $reason ]
                     }
                  ],
               }
            ]
         }
      );
   });
to_xmpp_time ($sec, $min, $hour, $tz, $secfrac)

This function transforms a time to the XMPP date time format. The meanings and value ranges of $sec, ..., $hour are explained in the perldoc of Perl's builtin localtime.

$tz has to be either "UTC" or of the form [+-]hh:mm, it can be undefined and wont occur in the time string then.

$secfrac are optional and can be the fractions of the second.

See also XEP-0082.

to_xmpp_datetime ($sec,$min,$hour,$mday,$mon,$year,$tz, $secfrac)

This function transforms a time to the XMPP date time format. The meanings of $sec, ..., $year are explained in the perldoc of Perl's localtime builtin and have the same value ranges.

$tz has to be either "Z" (for UTC) or of the form [+-]hh:mm (offset from UTC), if it is undefined "Z" will be used.

$secfrac are optional and can be the fractions of the second.

See also XEP-0082.

from_xmpp_datetime ($string)

This function transforms the $string which is either a time or datetime in XMPP format. If the string was not in the right format an empty list is returned. Otherwise this is returned:

   my ($sec, $min, $hour, $mday, $mon, $year, $tz, $secfrac)
      = from_xmpp_datetime ($string);

For the value ranges and semantics of $sec, ..., $srcfrac please look at the documentation for to_xmpp_datetime.

$tz and $secfrac might be undefined.

If $tz is undefined the timezone is to be assumed to be UTC.

If $string contained just a time $mday, $mon and $year will be undefined.

See also XEP-0082.

xmpp_datetime_as_timestamp ($string)

This function takes the same arguments as from_xmpp_datetime, but returns a unix timestamp, like time () would.

This function requires the POSIX module.

AUTHOR

Top

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

COPYRIGHT & LICENSE

Top

Copyright 2007, 2008 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.

AnyEvent-XMPP documentation Contained in the AnyEvent-XMPP distribution. 
package AnyEvent::XMPP::Util;
use strict;
no warnings;
use Encode;
use Net::LibIDN qw/idn_prep_name idn_prep_resource idn_prep_node/;
use AnyEvent::XMPP::Namespaces qw/xmpp_ns_maybe/;
require Exporter;
our @EXPORT_OK = qw/resourceprep nodeprep prep_join_jid join_jid
                    split_jid split_uri stringprep_jid prep_bare_jid bare_jid
                    is_bare_jid simxml dump_twig_xml install_default_debug_dump
                    cmp_jid cmp_bare_jid
                    node_jid domain_jid res_jid
                    prep_node_jid prep_domain_jid prep_res_jid
                    from_xmpp_datetime to_xmpp_datetime to_xmpp_time
                    xmpp_datetime_as_timestamp
                    filter_xml_chars filter_xml_attr_hash_chars
                    /;
our @ISA = qw/Exporter/;


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


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


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
}


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


sub split_uri {
    my ($uri) = @_;
    if ($uri =~ /^xmpp:(\S+)\?\w+;node=(\S+)$/) {
        return ($1, $2);
    } else {
        return (undef, $uri);
    }
}


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


sub node_jid   { (split_jid ($_[0]))[0] }
sub domain_jid { (split_jid ($_[0]))[1] }
sub res_jid    { (split_jid ($_[0]))[2] }

sub prep_node_jid   { nodeprep     (node_jid   ($_[0])) }
sub prep_domain_jid {              (domain_jid ($_[0])) }
sub prep_res_jid    { resourceprep (res_jid    ($_[0])) }


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


sub cmp_jid {
   my ($jid1, $jid2) = @_;
   stringprep_jid ($jid1) eq stringprep_jid ($jid2)
}


sub cmp_bare_jid {
   my ($jid1, $jid2) = @_;
   cmp_jid (bare_jid ($jid1), bare_jid ($jid2))
}


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


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


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


sub filter_xml_chars($) {
   my ($string) = @_;
   $string =~ s/[^\x{9}\x{A}\x{D}\x{20}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFFFF}]+//g;
   $string
}


sub filter_xml_attr_hash_chars {
   my ($hash) = @_;
   $hash->{$_} = filter_xml_chars $hash->{$_} for keys %$hash
}



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

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

   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) eq 'CODE') {
      $node->($w);

   } 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};

      my %attrs = @{$node->{attrs} || []};
      filter_xml_attr_hash_chars \%attrs;

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

         $w->startTag ($tag, %attrs);

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

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

         $w->endTag;

      } else {
         $w->emptyTag ($tag, %attrs);
      }
   } else {
      $w->characters (filter_xml_chars $node);
   }
}


sub to_xmpp_time {
   my ($sec, $min, $hour, $tz, $secfrac) = @_;
   my $frac = sprintf "%.3f", $secfrac;
   substr $frac, 0, 1, '';
   sprintf "%02d:%02d:%02d%s%s",
      $hour, $min, $sec,
      (defined $secfrac ? $frac : ""),
      (defined $tz ? $tz : "")
}


sub to_xmpp_datetime {
   my ($sec, $min, $hour, $mday, $mon, $year, $tz, $secfrac) = @_;
   my $time = to_xmpp_time ($sec, $min, $hour, (defined $tz ? $tz : 'Z'), $secfrac);
   sprintf "%04d-%02d-%02dT%s", $year + 1900, $mon + 1, $mday, $time;
}


sub from_xmpp_datetime {
   my ($string) = @_;

   if ($string !~
      /^(?:(\d{4})-?(\d{2})-?(\d{2})T)?(\d{2}):(\d{2}):(\d{2})(\.\d{3})?(Z|[+-]\d{2}:\d{2})?/)
   {
      return ()
   }

   ($6, $5, $4,
      ($3 ne '' ? $3        : undef),
      ($2 ne '' ? $2 - 1    : undef),
      ($1 ne '' ? $1 - 1900 : undef),
      ($8 ne '' ? $8        : undef),
      ($7 ne '' ? $7        : undef))
}


sub xmpp_datetime_as_timestamp {
   my ($string) = @_;
   require POSIX;
   my ($s, $m, $h, $md, $mon, $year, $tz) = from_xmpp_datetime ($string);

   my $otz = $ENV{TZ};
   $ENV{TZ} = ($tz =~ /^([+-])(\d{2}):(\d{2})$/ ? "UTC $tz" : "");
   POSIX::tzset ();

   my $ts = POSIX::mktime ($s, $m, $h, $md, $mon, $year);

   if (defined $otz) {
      $ENV{TZ} = $otz;
   } else {
      delete $ENV{TZ};
   }

   POSIX::tzset ();

   $ts
}

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


1; # End of AnyEvent::XMPP