AnyEvent-XMPP-0.54/0000755000000000000000000000000012057744573012471 5ustar rootrootAnyEvent-XMPP-0.54/CONTRIBUTORS0000644000175000000620000000106512035245233015120 0ustar michaelstaffThese people have helped to work on AnyEvent::XMPP: * melo - minor fixes on AnyEvent::XMPP::Connection. * Chris Miceli - additional work on the pubsub extension. * Johansson Olle E - pointing out documentation errors and typos all over the module and missing from attribute for messages. * Ky6uk - adding MUC history support. * J. Cameijo Cerdeira - Pointing out bugs and making suggestions. * Carlo von Loesch (aka lynX) - Pointing out typos. * mons@cpan.org - some maintenance patches. AnyEvent-XMPP-0.54/lib/0000755000000000000000000000000012057744573013237 5ustar rootrootAnyEvent-XMPP-0.54/lib/AnyEvent/0000755000000000000000000000000012057744573014770 5ustar rootrootAnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/0000755000000000000000000000000012057744573015554 5ustar rootrootAnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error.pm0000644000175000000620000000300212035245233017743 0ustar michaelstaffpackage AnyEvent::XMPP::Error; use strict; use AnyEvent::XMPP::Util qw/stringprep_jid prep_bare_jid/; use AnyEvent::XMPP::Error; use AnyEvent::XMPP::Error::SASL; use AnyEvent::XMPP::Error::IQ; use AnyEvent::XMPP::Error::Register; use AnyEvent::XMPP::Error::Stanza; use AnyEvent::XMPP::Error::Stream; use AnyEvent::XMPP::Error::Presence; use AnyEvent::XMPP::Error::Message; use AnyEvent::XMPP::Error::Parser; use AnyEvent::XMPP::Error::Exception; use AnyEvent::XMPP::Error::IQAuth; =head1 NAME AnyEvent::XMPP::Error - Error class hierarchy for error reporting =head1 SYNOPSIS die $error->string; =head1 DESCRIPTION This module is a helper class for abstracting any kind of error that occurs in AnyEvent::XMPP. You receive instances of these objects by various events. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { } =head1 SUPER CLASS AnyEvent::XMPP::Error - The super class of all errors =head2 METHODS These methods are implemented by all subclasses. =over 4 =item B Returns a humand readable string for this error. =cut sub string { my ($self) = @_; $self->{text} } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Ext.pm0000644000175000000620000001234712035245233017426 0ustar michaelstaffpackage AnyEvent::XMPP::Ext; no warnings; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use base qw/Object::Event/; =head1 NAME AnyEvent::XMPP::Ext - Extension baseclass and documentation =head1 DESCRIPTION This module also has documentation about the supported extensions and also is a base class for all extensions that can be added via the C method of the classes that derive from L. (That are: L, L and L) =head1 Methods =over 4 =item B This method can be overwritten by the extension and should return a list of namespace URIs of the features that the extension enables. =cut sub disco_feature { } sub disco_feature_standard { ( xmpp_ns ('data_form'), ) } =back =head1 Supportet extensions This is the list of supported XMPP extensions: =over 4 =item XEP-0004 - Data Forms (Version 2.8) This extension handles data forms as described in XEP-0004. L allows you to construct, receive and answer data forms. This is neccessary for all sorts of things in XMPP. For example XEP-0055 (Jabber Search) or also In-band registration. =item XEP-0030 - Service Discovery (Version 2.3) This extension allows you to send service discovery requests and define a set of discoverable information. See also L. =item XEP-0054 - vcard-temp (Version 1.1) This extension allows the retrieval and storage of XMPP vcards as defined in XEP-0054. It is implemented by L. =item XEP-0066 - Out of Band Data (Version 1.5) This extension allows to receive and send out of band data URLs and provides helper functions to handle jabber:x:oob data. See also L. =item XEP-0077 - In-Band Registration (Version 2.2) This extension lets you register new accounts "in-band". For details please take a look at L. =item XEP-0078 - Non-SASL Authentication (Version 2.3) After lots of sweat and curses I implemented finally iq auth. Unfortunately the XEP-0078 specifies things that are not implemented, in fact the only server that worked was openfire and psyced.org. So I de-analyzed the iq auth and now it just barfs the IQ set out on the stream with the username and the password. If you insist on XEP-0078 behaviour enable the C option when creating the stream. You can also completely disable iq auth, well, just see the documentation of L =item XEP-0082 - XMPP Date and Time Profiles (Version 1.0) Implemented some functions to deal with XMPP timestamps, see L C, C, C. They are meant as simple formatters for you, you will still need to handle timezone stuff and such yourself. =item XEP-0086 - Error Condition Mappings (Version 1.0) "A mapping to enable legacy entities to correctly handle errors from XMPP-aware entities." This extension will enable sending of the old error codes when generating a stanza error with for example the C method of L. Also if only the old numeric codes are supplied the L class tries to map the numeric codes to the new error conditions if possible. =item XEP-0091 - Delayed Delivery (Version 1.3) See also XEP-0203 below. =item XEP-0092 - Software Version (Version 1.1) The ability to answer to software version, name and operating system requests and being able to send such requests is implemented in L. =item XEP-0114 - Jabber Component Protocol (Version 1.5) This extension allows you to connect to a server as a component and makes it possible to implement services like pubsub, muc, or whatever you can imagine (even gateways). See documentation of L and the example C. =item XEP-0153 - vCard-Based Avatars (Version 1.0) This extension allows to store and retrive avatars from vcards. On top of that it will also signal others that you support avatars and that they might have changed. See L. =item XEP-0199 - XMPP Ping (Version 1.0) You can send ping requests to other entities and also are able to reply to them. On top of that the L extension implements a connection timeout mechanism based on this. =item XEP-0203 - Delayed Delivery (Version 1.0) Both delayed delivery XEPs are supported and are implemented by L which is a super class of L and L. If you need to fetch delay from stanzas you caught yourself in an event you can use a L object to parse/fetch the delay out of the L. Use the functions described above in the XEP-0082 item to decode the timestamps of delays. =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Namespaces.pm0000644000175000000620000001046112035245233020740 0ustar michaelstaffpackage AnyEvent::XMPP::Namespaces; no warnings; use strict; require Exporter; our @EXPORT_OK = qw/xmpp_ns set_xmpp_ns_alias xmpp_ns_maybe/; our @ISA = qw/Exporter/; our %NAMESPACES = ( client => 'jabber:client', component => 'jabber:component:accept', stream => 'http://etherx.jabber.org/streams', streams => 'urn:ietf:params:xml:ns:xmpp-streams', stanzas => 'urn:ietf:params:xml:ns:xmpp-stanzas', sasl => 'urn:ietf:params:xml:ns:xmpp-sasl', bind => 'urn:ietf:params:xml:ns:xmpp-bind', tls => 'urn:ietf:params:xml:ns:xmpp-tls', roster => 'jabber:iq:roster', register => 'jabber:iq:register', version => 'jabber:iq:version', auth => 'jabber:iq:auth', session => 'urn:ietf:params:xml:ns:xmpp-session', xml => 'http://www.w3.org/XML/1998/namespace', disco_info => 'http://jabber.org/protocol/disco#info', disco_items => 'http://jabber.org/protocol/disco#items', register_f => 'http://jabber.org/features/iq-register', iqauth => 'http://jabber.org/features/iq-auth', data_form => 'jabber:x:data', iq_oob => 'jabber:iq:oob', x_oob => 'jabber:x:oob', muc => 'http://jabber.org/protocol/muc', muc_user => 'http://jabber.org/protocol/muc#user', muc_owner => 'http://jabber.org/protocol/muc#owner', search => 'jabber:iq:search', x_delay => 'jabber:x:delay', delay => 'urn:xmpp:delay', ping => 'urn:xmpp:ping', vcard => 'vcard-temp', vcard_upd => 'vcard-temp:x:update', pubsub => 'http://jabber.org/protocol/pubsub', pubsub_own => 'http://jabber.org/protocol/pubsub#owner', pubsub_ev => 'http://jabber.org/protocol/pubsub#event', ); =head1 NAME AnyEvent::XMPP::Namespaces - XMPP namespace collection and aliasing class =head1 SYNOPSIS use AnyEvent::XMPP::Namespaces qw/xmpp_ns set_xmpp_ns_alias/; set_xmpp_ns_alias (stanzas => 'urn:ietf:params:xml:ns:xmpp-stanzas'); =head1 DESCRIPTION This module represents a simple namespaces aliasing mechanism to ease handling of namespaces when traversing AnyEvent::XMPP::Node objects and writing XML with AnyEvent::XMPP::Writer. =head1 XMPP NAMESPACES There are already some aliases defined for the XMPP XML namespaces which make handling of namepsaces a bit easier: stream => http://etherx.jabber.org/streams xml => http://www.w3.org/XML/1998/namespace streams => urn:ietf:params:xml:ns:xmpp-streams session => urn:ietf:params:xml:ns:xmpp-session stanzas => urn:ietf:params:xml:ns:xmpp-stanzas sasl => urn:ietf:params:xml:ns:xmpp-sasl bind => urn:ietf:params:xml:ns:xmpp-bind tls => urn:ietf:params:xml:ns:xmpp-tls client => jabber:client roster => jabber:iq:roster version => jabber:iq:version auth => jabber:iq:auth iq_oob => jabber:iq:oob x_oob => jabber:x:oob disco_info => http://jabber.org/protocol/disco#info disco_items => http://jabber.org/protocol/disco#items register => http://jabber.org/features/iq-register iqauth => http://jabber.org/features/iq-auth data_form => jabber:x:data ping => urn:xmpp:ping vcard => vcard-temp pubsub => http://jabber.org/protocol/pubsub pubsub_own => http://jabber.org/protocol/pubsub#owner pubsub_ev => http://jabber.org/protocol/pubsub#event =head1 FUNCTIONS =over 4 =item B Returns am uri for the registered C<$alias> or undef if none exists. =cut sub xmpp_ns { return $NAMESPACES{$_[0]} } =item B This method tries to find whether there is a alias C<$alias_or_namespace_uri> registered and if not it returns C<$alias_or_namespace_uri>. =cut sub xmpp_ns_maybe { my ($alias) = @_; return unless defined $alias; my $n = xmpp_ns ($alias); $n ? $n : $alias } =item B Sets an C<$alias> for the C<$namespace_uri>. =cut sub set_xmpp_ns_alias { $NAMESPACES{$_[0]} = $_[1] } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/TestClient.pm0000644000175000000620000002107712035245233020744 0ustar michaelstaffpackage AnyEvent::XMPP::TestClient; use strict; no warnings; use AnyEvent; use AnyEvent::XMPP::Client; use AnyEvent::XMPP::Util qw/stringprep_jid prep_bare_jid dump_twig_xml/; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use Test::More; =head1 NAME AnyEvent::XMPP::TestClient - XMPP Test Client for tests =head1 SYNOPSIS =head1 DESCRIPTION This module is a helper module to ease the task of testing. If you want to run the developer test suite you have to set the environment variable C to something like this: NET_XMPP2_TEST="test_me@your_xmpp_server.tld:secret_password" Most tests will try to connect two accounts, so please take a server that allows two connections from the same IP. If you also want to run the MUC tests (see L) you also need to setup the environment variable C to contain the domain of a MUC service: NET_XMPP2_TEST_MUC="conference.your_xmpp_server.tld" If you see some tests fail and want to know more about the protocol flow you can enable the protocol debugging output by setting C to '1': NET_XMPP2_TEST_DEBUG=1 (NOTE: You will only see the output of this by running a single test) If one of the tests takes longer than the preconfigured 20 seconds default timeout in your setup you can set C: NET_XMPP2_TEST_TIMEOUT=60 # for a 1 minute timeout =head1 CLEANING UP If the tests went wrong somewhere or you interrupted the tests you might want to delete the accounts from the server manually, then run: perl t/z_*_unregister.t =head1 MANUAL TESTING If you just want to run a single test yourself, just execute the register test before doing so: perl t/z_00_register.t And then you could eg. run: perl t/z_03_iq_auth.t =head1 METHODS =head2 new (%args) Following arguments can be passed in C<%args>: =over 4 =back =cut sub new_or_exit { my $this = shift; my $class = ref($this) || $this; my $self = { timeout => 20, finish_count => 1, @_ }; if ($ENV{NET_XMPP2_TEST_DEBUG}) { $self->{debug} = 1; } if ($ENV{NET_XMPP2_TEST_TIMEOUT}) { $self->{timeout} = $ENV{NET_XMPP2_TEST_TIMEOUT}; } $self->{tests}; if ($self->{muc_test} && not $ENV{NET_XMPP2_TEST_MUC}) { plan skip_all => "environment var NET_XMPP2_TEST_MUC not set! Set it to a conference!"; exit; } if ($ENV{NET_XMPP2_TEST}) { plan tests => $self->{tests} + 1 } else { plan skip_all => "environment var NET_XMPP2_TEST not set! (see also AnyEvent::XMPP::TestClient)!"; exit; } bless $self, $class; $self->init; $self } sub init { my ($self) = @_; $self->{condvar} = AnyEvent->condvar; $self->{timeout} = AnyEvent->timer ( after => $self->{timeout}, cb => sub { $self->{error} .= "Error: Test Timeout\n"; $self->{condvar}->broadcast; } ); my $cl = $self->{client} = AnyEvent::XMPP::Client->new (debug => $self->{debug} || 0); my ($jid, $password) = split /:/, $ENV{NET_XMPP2_TEST}, 2; $self->{jid} = $jid; $self->{jid2} = "2nd_" . $jid; $self->{password} = $password; $cl->add_account ($jid, $password, undef, undef, $self->{connection_args}); if ($self->{two_accounts}) { my $cnt = 0; $cl->reg_cb (session_ready => sub { my ($cl, $acc) = @_; if (++$cnt > 1) { $self->{acc} = $cl->get_account ($self->{jid}); $self->{acc2} = $cl->get_account ($self->{jid2}); $cl->event ('two_accounts_ready', $acc); $self->state_done ('two_accounts_ready'); } }); $cl->add_account ("2nd_".$jid, $password, undef, undef, $self->{connection_args}); } else { $cl->reg_cb (before_session_ready => sub { my ($cl, $acc) = @_; $self->{acc} = $acc; $self->state_done ('one_account_ready'); }); } if ($self->{muc_test} && $ENV{NET_XMPP2_TEST_MUC}) { $self->{muc_room} = "test_nxmpp2@" . $ENV{NET_XMPP2_TEST_MUC}; my $disco = $self->{disco} = $self->instance_ext ('AnyEvent::XMPP::Ext::Disco'); my $muc = $self->{muc} = $self->instance_ext ('AnyEvent::XMPP::Ext::MUC', disco => $disco); $cl->reg_cb ( two_accounts_ready => sub { my ($cl, $acc) = @_; my $cnt = 0; my ($room1, $room2); $muc->join_room ($self->{acc}->connection, $self->{muc_room}, "test1"); my $rid; $rid = $muc->reg_cb ( join_error => sub { my ($muc, $room, $error) = @_; $self->{error} .= "Error: Couldn't join $self->{muc_room}: ".$error->string."\n"; $self->{condvar}->broadcast; }, enter => sub { my ($muc, $room, $user) = @_; if ($room->get_me->nick eq 'test1') { $self->{user} = $user; $self->{room} = $room; $muc->join_room ($self->{acc2}->connection, $self->{muc_room}, "test2"); } else { $self->{user2} = $user; $self->{room2} = $room; $muc->unreg_cb ($rid); $cl->event ('two_rooms_joined', $acc); $self->state_done ('two_rooms_joined'); } } ); } ); } $cl->reg_cb (error => sub { my ($cl, $acc, $error) = @_; $self->{error} .= "Error: " . $error->string . "\n"; $self->finish unless $self->{continue_on_error}; }); $cl->start; } sub checkpoint { my ($self, $name, $cnt, $cb) = @_; $self->{checkpoints}->{$name} = [$cnt, $cb]; } sub reached_checkpoint { my ($self, $name) = @_; my $chp = $self->{checkpoints}->{$name} or die "no such checkpoint defined: $name"; $chp->[0]--; if ($chp->[0] <= 0) { $chp->[1]->(); delete $self->{checkpoints}->{$name}; } } sub main_account { ($_[0]->{jid}, $_[0]->{password}) } sub client { $_[0]->{client} } sub tests { $_[0]->{tests} } sub instance_ext { my ($self, $ext, @args) = @_; eval "require $ext; 1"; if ($@) { die "Couldn't load '$ext': $@" } my $eo = $ext->new (@args); $self->{client}->add_extension ($eo); $eo } sub finish { my ($self) = @_; $self->{_cur_finish_cnt}++; if ($self->{finish_count} <= $self->{_cur_finish_cnt}) { $self->{condvar}->broadcast; } } sub wait { my ($self) = @_; $self->{condvar}->wait; if ($self->error) { fail ("error free"); diag ($self->error); } else { pass ("error free"); } } sub error { $_[0]->{error} } my %STATE; sub state { my $self = shift; my $prec = []; if (ref $_[0] eq 'ARRAY') { $prec = shift; } my ($state, $args, $cond, $cb) = @_; $STATE{$state} = { name => $state, args => $args, cond => $cond, cb => $cb, done => 0, prec => $prec }; $self->state_check (); } sub state_done { my ($self, $state) = @_; $STATE{$state} ||= { name => $state, args => undef, cond => undef, cb => undef, done => 0 }; $STATE{$state}->{done} = 1; if ($ENV{ANYEVENT_XMPP_MAINTAINER_TEST_DEBUG}) { warn "STATE '$state' DONE\n"; } $self->state_check (); } sub state_check { my ($self, $state, $cb) = @_; if (defined $state && $STATE{$state} && !$STATE{$state}->{done}) { $cb->($STATE{$state}->{args}); } RESTART: { for my $s (grep { !$_->{done} } values %STATE) { if (@{$s->{prec} || []} && grep { !$STATE{$_} || !$STATE{$_}->{done} } @{$s->{prec} || []}) { next; } if (!defined ($s->{cond}) || $s->{cond}->($s->{args})) { if ($ENV{ANYEVENT_XMPP_MAINTAINER_TEST_DEBUG}) { print "STATE '$s->{name}' OK (".join (',', @{$s->{prec} || []}).")\n"; } $s->{cb}->($s->{args}) if defined $s->{cb}; $s->{done} = 1; goto RESTART; } } } if ($ENV{ANYEVENT_XMPP_MAINTAINER_TEST_DEBUG}) { warn "STATE STATUS:\n"; for my $s (keys %STATE) { warn "\t$s => $STATE{$s}->{done}\t" . join (',', map { "$_:$STATE{$s}->{args}->{$_}" } keys %{$STATE{$s}->{args}} )."\n"; } } } =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP::TestClient AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Extendable.pm0000644000175000000620000000255512035245233020741 0ustar michaelstaffpackage AnyEvent::XMPP::Extendable; no warnings; use strict; =head1 NAME AnyEvent::XMPP::Extendable - Extendable baseclass =head1 DESCRIPTION This class provides a mechanism to add extensions. Please note that the class that derives from this must also derive from L! Please see L for more information about this mechanism. =over 4 =item B This method extends the current object with a L object. C<$ext> must be an instance of L. Basically C makes the extension an event receiver for all events that the extended object receives. =cut sub add_extension { my ($self, $ext) = @_; $self->add_forward ($ext, sub { my ($self, $ext, $ev, @args) = @_; return if $ext->{inhibit_forward}->{$ev}; $ext->_event ($ev, $self, @args); }); } =item B This method removes the extension C<$ext>. =cut sub remove_extension { my ($self, $ext) = @_; $self->remove_forward ($ext); } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/0000755000000000000000000000000012057744573016645 5ustar rootrootAnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Exception.pm0000644000175000000620000000173512035245233021714 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Exception; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::Exception - Some exception was thrown somewhere Subclass of L =head2 METHODS =over 4 =item B This returns the exception object that was thrown in C<$@>. =cut sub exception { $_[0]->{exception} } =item B This returns a string which describes the context in which this exception was thrown =cut sub context { $_[0]->{context} } sub string { my ($self) = @_; sprintf "exception in context '%s': %s", $self->context, $self->exception } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Presence.pm0000644000175000000620000000136212035245233021516 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Presence; use AnyEvent::XMPP::Error::Stanza; use strict; our @ISA = qw/AnyEvent::XMPP::Error::Stanza/; =head1 NAME AnyEvent::XMPP::Error::Presence - Presence errors Subclass of L =cut sub string { my ($self) = @_; sprintf "presence error: %s/%s (type %s): %s", $self->code || '', $self->condition || '', $self->type, $self->text } =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Stanza.pm0000644000175000000620000000775512035245233021226 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Stanza; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::Stanza - Stanza errors Subclass of L =cut sub init { my ($self) = @_; my $node = $self->xml_node; unless (defined $node) { $self->{error_cond} = 'client-timeout'; $self->{error_type} = 'cancel'; return; } my @error; my ($err) = $node->find_all ([qw/client error/]); unless ($err) { warn "No error element found in error stanza!"; $self->{text} = "Unknown Stanza error"; return } $self->{error_type} = $err->attr ('type'); $self->{error_code} = $err->attr ('code'); if (my ($txt) = $err->find_all ([qw/stanzas text/])) { $self->{error_text} = $txt->text; } for my $er ( qw/bad-request conflict feature-not-implemented forbidden gone internal-server-error item-not-found jid-malformed not-acceptable not-allowed not-authorized payment-required recipient-unavailable redirect registration-required remote-server-not-found remote-server-timeout resource-constraint service-unavailable subscription-required undefined-condition unexpected-request/) { if (my ($el) = $err->find_all ([stanzas => $er])) { $self->{error_cond} = $er; $self->{error_cond_node} = $el; last; } } if (not ($self->{error_cond}) && defined $self->{error_code}) { for my $er (keys %AnyEvent::XMPP::Writer::STANZA_ERRORS) { my $ern = $AnyEvent::XMPP::Writer::STANZA_ERRORS{$er}; if ($ern->[1] == $self->{error_code} && $ern->[0] eq $self->{error_type}) { $self->{error_cond} = $er; last; } } } if (!(defined $self->{error_code}) && $self->{error_cond}) { my $ern = $AnyEvent::XMPP::Writer::STANZA_ERRORS{$self->{error_cond}}; $self->{error_type} = $ern->[0]; $self->{error_code} = $ern->[1]; } } =head2 METHODS =over 4 =item B Returns the L object for this Stanza error. This method returns undef if the Stanza timeouted. In the case of a timeout the C method returns C, C returns 'cancel' and C undef. =cut sub xml_node { $_[0]->{node} } =item B This method returns one of: 'cancel', 'continue', 'modify', 'auth' and 'wait' =cut sub type { $_[0]->{error_type} } =item B This method returns the error code if one was found. =cut sub code { $_[0]->{error_code} } =item B Returns the error condition string if one was found when receiving the Stanza error. It can be undef or one of: bad-request conflict feature-not-implemented forbidden gone internal-server-error item-not-found jid-malformed not-acceptable not-allowed not-authorized payment-required recipient-unavailable redirect registration-required remote-server-not-found remote-server-timeout resource-constraint service-unavailable subscription-required undefined-condition unexpected-request =cut sub condition { $_[0]->{error_cond} } =item B Returns the error condition node if one was found when receiving the Stanza error. This is mostly for debugging purposes. =cut sub condition_node { $_[0]->{error_cond_node} } =item B The humand readable error portion. Might be undef if none was received. =cut sub text { $_[0]->{error_text} } sub string { my ($self) = @_; sprintf "stanza error: %s/%s (type %s): %s", $self->code || '', $self->condition || '', $self->type, $self->text } =back =cut =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Register.pm0000644000175000000620000000205712035245233021540 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Register; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error::IQ/; =head1 NAME AnyEvent::XMPP::Error::Register - In-band registration error Subclass of L =cut =head1 DESCRIPTION This is a In-band registration error. For a mapping of IQ error values to their meaning please consult XEP-0077 for now. =head1 METHODS =over 4 =item B Returns the state of registration, one of: register unregister submit =cut sub register_state { my ($self) = @_; $self->{register_state} } sub string { my ($self) = @_; sprintf "ibb registration error (in %s): %s", $self->register_state, $self->SUPER::string } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/IQ.pm0000644000175000000620000000216612035245233020266 0ustar michaelstaffpackage AnyEvent::XMPP::Error::IQ; use strict; no warnings; use AnyEvent::XMPP::Error::Stanza; our @ISA = qw/AnyEvent::XMPP::Error::Stanza/; =head1 NAME AnyEvent::XMPP::Error::IQ - IQ errors Subclass of L =cut sub init { my ($self) = @_; my $node = $self->xml_node; unless (defined $node) { $self->{error_cond} = 'client-timeout'; $self->{error_type} = 'cancel'; return; } $self->SUPER::init; } =head2 METHODS =over 4 =item B Same as L except that in case of a IQ timeout it returns: 'client-timeout' =cut sub string { my ($self) = @_; sprintf "iq error: %s/%s (type %s): %s", $self->code || '', $self->condition || '', $self->type, $self->text } =back =cut =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/SASL.pm0000644000175000000620000000234512035245233020516 0ustar michaelstaffpackage AnyEvent::XMPP::Error::SASL; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::SASL - SASL authentication error Subclass of L =cut sub init { my ($self) = @_; my $node = $self->xml_node; my $error; for ($node->nodes) { $error = $_->name; last } $self->{error_cond} = $error; } =head2 METHODS =over 4 =item B Returns the L object for this stream error. =cut sub xml_node { $_[0]->{node} } =item B Returns the error condition, which might be one of: aborted incorrect-encoding invalid-authzid invalid-mechanism mechanism-too-weak not-authorized temporary-auth-failure =cut sub condition { $_[0]->{error_cond} } sub string { my ($self) = @_; sprintf "sasl error: %s", $self->condition } =back =cut =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Message.pm0000644000175000000620000000137312035245233021340 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Message; use strict; no warnings; use AnyEvent::XMPP::Error::Stanza; our @ISA = qw/AnyEvent::XMPP::Error::Stanza/; =head1 NAME AnyEvent::XMPP::Error::Message - Message errors Subclass of L =cut sub string { my ($self) = @_; sprintf "message error: %s/%s (type %s): %s", $self->code || '', $self->condition || '', $self->type, $self->text } =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/IQAuth.pm0000644000175000000620000000200612035245233021101 0ustar michaelstaffpackage AnyEvent::XMPP::Error::IQAuth; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::IQAuth - IQ authentication error Subclass of L =head2 METHODS =over 4 =item B This method returns either: C which means that a IQ error was caught, which can be accessed with the C method. Or: C which means that no form fields were found in the IQ auth result. =cut sub context { $_[0]->{context} } sub iq_error { $_[0]->{iq_error} } sub string { my ($self) = @_; sprintf "iq auth error: '%s' %s", $self->context, ($self->context eq 'iq_error' ? $self->iq_error ()->string : '') } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Stream.pm0000644000175000000620000000522112035245233021203 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Stream; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::Stream - XML Stream errors Subclass of L =cut sub init { my ($self) = @_; my $node = $self->xml_node; my @txt = $node->find_all ([qw/streams text/]); my $error; for my $er ( qw/bad-format bad-namespace-prefix conflict connection-timeout host-gone host-unknown improper-addressing internal-server-error invalid-from invalid-id invalid-namespace invalid-xml not-authorized policy-violation remote-connection-failed resource-constraint restricted-xml see-other-host system-shutdown undefined-condition unsupported-stanza-type unsupported-version xml-not-well-formed/) { if (my (@n) = $node->find_all ([streams => $er])) { $error = $n[0]->name; last; } } unless ($error) { #d# warn "got undefined error stanza, trying to find any undefined error..."; for my $n ($node->nodes) { if ($n->eq_ns ('streams')) { $error = $n->name; } } } $self->{error_name} = $error; $self->{error_text} = @txt ? $txt[0]->text : ''; } =head2 METHODS =over 4 =item B Returns the L object for this stream error. =cut sub xml_node { $_[0]->{node} } =item B Returns the name of the error. That might be undef, one of the following strings or some other string that has been discovered by a heuristic (because some servers send errors that are not in the RFC). bad-format bad-namespace-prefix conflict connection-timeout host-gone host-unknown improper-addressing internal-server-error invalid-from invalid-id invalid-namespace invalid-xml not-authorized policy-violation remote-connection-failed resource-constraint restricted-xml see-other-host system-shutdown undefined-condition unsupported-stanza-type unsupported-version xml-not-well-formed =cut sub name { $_[0]->{error_name} } =item B The humand readable error portion. Might be undef if none was received. =cut sub text { $_[0]->{error_text} } sub string { my ($self) = @_; sprintf ("stream error: %s: %s", $self->name, $self->text) } =back =cut =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/Parser.pm0000644000175000000620000000166412035245233021213 0ustar michaelstaffpackage AnyEvent::XMPP::Error::Parser; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::Parser - XML parse errors Subclass of L =cut sub init { my ($self) = @_; } =head2 METHODS =over 4 =item B Returns the XML parser exception. =cut sub exception { return $_[0]->{exception} } =item B Returns the errornous data. =cut sub data { $_[0]->{data} } sub string { my ($self) = @_; sprintf ("xml parse error: exception: %s, data: [%s]", $self->exception, $self->data) } =back =cut =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Error/MUC.pm0000644000175000000620000001056512035245233020403 0ustar michaelstaffpackage AnyEvent::XMPP::Error::MUC; use AnyEvent::XMPP::Error; use strict; our @ISA = qw/AnyEvent::XMPP::Error/; =head1 NAME AnyEvent::XMPP::Error::MUC - MUC error Subclass of L =head2 METHODS =over 4 =cut sub init { my ($self) = @_; if ($self->{presence_error}) { my %mapping = ( 'not-authorized' => 'password_required', 'forbidden' => 'banned', 'item-not-found' => 'room_locked', 'not-allowed' => 'room_not_creatable', 'not-acceptable' => 'use_reserved_nick', 'registration-required' => 'not_on_memberlist', 'conflict' => 'nickname_in_use', 'service-unavailable' => 'room_full', ); my $cond = $self->{presence_error}->{error_cond}; $self->{type} = $mapping{$cond}; } if ($self->{message_node}) { my $error = AnyEvent::XMPP::Error::Message->new (node => $self->{message_node}); if ($self->{message}->any_subject && not defined $self->{message}->any_body) { $self->{type} = 'subject_change_forbidden'; } else { $self->{type} = 'message_error'; } $self->{message_error} = $error; } } =item B This method returns either: =over 4 =item join_timeout If the joining of the room took too long. =item no_config_form If the room we requested the configuration from didn't provide a data form. =item subject_change_forbidden If changing the subject of a room is not allowed. =item message_error If this is an unidentified message error. =back If we got a presence error the method C returns a L object with further details. However, this class tries to provide a mapping for you (the developer) to ease the load of figuring out which error means what. To make identification of the errors with XEP-0045 more clear I included the error codes and condition names. Here are the more descriptive types: =over 4 =item password_required Entering a room Inform user that a password is required. (Condition: not-authorized, Code: 401) =item banned Entering a room Inform user that he or she is banned from the room (Condition: forbidden, Code: 403) =item room_locked Entering a room Inform user that the room does not exist and someone is currently creating it. (Condition: item-not-found, Code: 404) =item room_not_creatable Entering a room Inform user that room creation is restricted (Condition: not-allowed, Code: 405) =item use_reserved_nick Entering a room Inform user that the reserved roomnick must be used (Condition: not-acceptable, Code: 406) =item not_on_memberlist Entering a room Inform user that he or she is not on the member list (Condition: registration-required, Code: 407) =item nickname_in_use Entering a room Inform user that his or her desired room nickname is in use or registered by another user (Condition: conflict, Code: 409) =item room_full Entering a room Inform user that the maximum number of users has been reached (Condition: service-unavailable, Code: 503) =back The condition and code are also available through the L object returned by C, see below. =cut sub type { $_[0]->{type} } =item B This method returns a human readable text if one is available. =cut sub text { my ($self) = @_; if (my $p = $self->presence_error) { return $p->text; } elsif (my $m = $self->message_error) { return $m->text; } else { return $self->{text} } } =item B Returns a L object if this error origins to such an error and not some internal error. =cut sub presence_error { $_[0]->{presence_error} } =item B Returns a L object if this error origins to such an error and not some internal error. =cut sub message_error { $_[0]->{message_error} } sub string { my ($self) = @_; sprintf "muc error: '%s': %s", $self->type, ( $self->presence_error ? $self->presence_error ()->string : $self->text ) } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Client.pm0000644000175000000620000003326512035245233020106 0ustar michaelstaffpackage AnyEvent::XMPP::Client; use strict; use AnyEvent; use AnyEvent::XMPP::IM::Connection; use AnyEvent::XMPP::Util qw/stringprep_jid prep_bare_jid dump_twig_xml bare_jid cmp_bare_jid/; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Extendable; use AnyEvent::XMPP::IM::Account; use Object::Event; use Scalar::Util; #use XML::Twig; # #sub _dumpxml { # my $data = shift; # my $t = XML::Twig->new; # if ($t->safe_parse ("$data")) { # $t->set_pretty_print ('indented'); # $t->print; # print "\n"; # } else { # print "[$data]\n"; # } #} our @ISA = qw/Object::Event AnyEvent::XMPP::Extendable/; =head1 NAME AnyEvent::XMPP::Client - XMPP Client abstraction =head1 SYNOPSIS use AnyEvent::XMPP::Client; use AnyEvent; my $j = AnyEvent->condvar; my $cl = AnyEvent::XMPP::Client->new; $cl->start; $j->wait; =head1 DESCRIPTION This module tries to implement a straight forward and easy to use API to communicate with XMPP entities. L handles connections and timeouts and all such stuff for you. For more flexibility please have a look at L and L, they allow you to control what and how something is being sent more precisely. =head1 METHODS =head2 new (%args) Following arguments can be passed in C<%args>: =over 4 =item debug => 1 This will install callbacks which produce debugging output. This will require L to be installed (as it is used for pretty printing the "XML" output). =back =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = { @_ }; bless $self, $class; if ($self->{debug}) { $self->reg_cb ( debug_recv => sub { my ($self, $acc, $data) = @_; printf "recv>> %s\n%s", $acc->jid, dump_twig_xml ($data) }, debug_send => sub { my ($self, $acc, $data) = @_; printf "send<< %s\n%s", $acc->jid, dump_twig_xml ($data) }, ) } return $self; } sub add_extension { my ($self, $ext) = @_; $self->add_forward ($ext, sub { my ($self, $ext, $ev, $acc, @args) = @_; return if $ext->{inhibit_forward}->{$ev}; $ext->_event ($ev, $acc->connection (), @args); }); } =head2 add_account ($jid, $password, $host, $port, $connection_args) This method adds a jabber account for connection with the JID C<$jid> and the password C<$password>. C<$host> and C<$port> can be undef and their default will be the domain of the C<$jid> and the default for the C parameter to the constructor of L (look there for details about DNS-SRV lookups). C<$connection_args> must either be undef or a hash reference to additional arguments for the constructor of the L that will be used to connect the account. Returns 1 on success and undef when the account already exists. =cut sub add_account { my ($self, $jid, $password, $host, $port, $connection_args) = @_; my $bj = prep_bare_jid $jid; my $acc = $self->{accounts}->{$bj}; if ($acc) { $acc->{password} = $password; $acc->{host} = $host; $acc->{port} = $port; $acc->{args} = $connection_args; return; } $acc = $self->{accounts}->{$bj} = AnyEvent::XMPP::IM::Account->new ( jid => $jid, password => $password, host => $host, port => $port, args => $connection_args, ); $self->event (added_account => $acc); $self->update_connections if $self->{started}; $acc } =head2 start () This method initiates the connections to the XMPP servers. =cut sub start { my ($self) = @_; $self->{started} = 1; $self->update_connections; } =head2 update_connections () This method tries to connect all unconnected accounts. =cut sub update_connections { my ($self) = @_; Scalar::Util::weaken $self; for (values %{$self->{accounts}}) { my $acc = $_; if (!$acc->is_connected && !$self->{prep_connections}->{$acc->bare_jid}) { my %args = (initial_presence => 10); if (defined $self->{presence}) { if (defined $self->{presence}->{priority}) { $args{initial_presence} = $self->{presence}->{priority}; } } my $con = $acc->spawn_connection (%args); $self->{prep_connections}->{$acc->bare_jid} = $con; $con->add_forward ($self, sub { my ($con, $self, $ev, @arg) = @_; $self->_event ($ev, $acc, @arg); }); $con->reg_cb ( session_ready => sub { my ($con) = @_; delete $self->{prep_connections}->{$acc->bare_jid}; $self->event (connected => $acc); if (defined $self->{presence}) { $con->send_presence (undef, undef, %{$self->{presence} || {}}); } $con->unreg_me }, disconnect => sub { my ($con, $h, $p, $err) = @_; $self->event (connect_error => $acc, $err); delete $self->{prep_connections}->{$acc->bare_jid}; $con->unreg_me; }, after_disconnect => sub { my ($con, $h, $p, $err) = @_; $con->remove_forward ($self); } ); $con->connect; } } } =head2 disconnect ($msg) Disconnect all accounts. =cut sub disconnect { my ($self, $msg) = @_; for my $acc (values %{$self->{accounts}}) { if ($acc->is_connected) { $acc->connection ()->disconnect ($msg) } } } =head2 remove_accounts ($reason) Removes all accounts and disconnects. C<$reason> should be some descriptive reason why this account was removed (just for logging purposes). =cut sub remove_accounts { my ($self, $reason) = @_; for my $acc (keys %{$self->{accounts}}) { $self->remove_account ($acc, $reason); } } =head2 remove_account ($acc, $reason) Removes and disconnects account C<$acc> (which is a L object). The reason for the removal can be given via C<$reason>. =cut sub remove_account { my ($self, $acc, $reason) = @_; my $acca = $self->{accounts}->{$acc}; $self->event (removed_account => $acca); if ($acca->is_connected) { $acca->connection ()->disconnect ($reason) } delete $self->{accounts}->{$acc}; } =head2 set_accounts (%$accounts) Sets the set of (to be connected) accounts. C<$accounts> must be a hash reference which contains the JIDs of the accounts as keys and the values for C<$password>, C<$domain>, C<$port> and C<$connection_args> as described in C above. If the account is not yet connected it will be connected on the next call to C and if an account is connected that is not in C<$accounts> it will be disconnected. =cut sub set_accounts { my ($self, $accounts) = @_; for my $accid (keys %{$self->{accounts}}) { my $acca = $self->{accounts}->{$accid}; if (!grep { cmp_bare_jid ($acca->jid, $_) } keys %$accounts) { $self->remove_account ($accid, "removed from set"); } } for my $acc_jid (keys %$accounts) { $self->add_account ($acc_jid, @{$accounts->{$acc_jid}}); } } =head2 send_message ($msg, $dest_jid, $src, $type) Sends a message to the destination C<$dest_jid>. C<$msg> can either be a string or a L object. If C<$msg> is such an object C<$dest_jid> is optional, but will, when passed, override the destination of the message. NOTE: C<$dest_jid> is transformed into a bare JID and the routing is done by the conversation tracking mechanism which keeps track of which resource should get the message. C<$src> is optional. It specifies which account to use to send the message. If it is not passed L will try to find an account itself. First it will look through all rosters to find C<$dest_jid> and if none found it will pick any of the accounts that are connected. C<$src> can either be a JID or a L object as returned by C and C. C<$type> is optional but overrides the type of the message object in C<$msg> if C<$msg> is such an object. C<$type> should be 'chat' for normal chatter. If no C<$type> is specified the type of the message defaults to the value documented in L (should be 'normal'). =cut sub send_message { my ($self, $msg, $dest_jid, $src, $type) = @_; unless (ref $msg) { $msg = AnyEvent::XMPP::IM::Message->new (body => $msg); } if (defined $dest_jid) { my $jid = stringprep_jid $dest_jid or die "send_message: \$dest_jid is not a proper JID"; $msg->to ($jid); } $msg->type ($type) if defined $type; my $srcacc; if (ref $src) { $srcacc = $src; } elsif (defined $src) { $srcacc = $self->get_account ($src) } else { $srcacc = $self->find_account_for_dest_jid ($dest_jid); } unless ($srcacc && $srcacc->is_connected) { die "send_message: Couldn't get connected account for sending" } $srcacc->send_tracked_message ($msg); } =head2 get_account ($jid) Returns the L account object for the JID C<$jid> if there is any such account added. (returns undef otherwise). =cut sub get_account { my ($self, $jid) = @_; $self->{accounts}->{prep_bare_jid $jid} } =head2 get_accounts () Returns a list of Ls. =cut sub get_accounts { my ($self) = @_; values %{$self->{accounts}} } =head2 get_connected_accounts () Returns a list of connected Ls. Same as: grep { $_->is_connected } $client->get_accounts (); =cut sub get_connected_accounts { my ($self, $jid) = @_; my (@a) = grep $_->is_connected, values %{$self->{accounts}}; @a } =head2 find_account_for_dest_jid ($jid) This method tries to find any account that has the contact C<$jid> on his roster. If no account with C<$jid> on his roster was found it takes the first one that is connected. (Return value is a L object). If no account is connected it returns undef. =cut sub find_account_for_dest_jid { my ($self, $jid) = @_; my $any_acc; for my $acc (values %{$self->{accounts}}) { next unless $acc->is_connected; # take "first" active account $any_acc = $acc unless defined $any_acc; my $roster = $acc->connection ()->get_roster; if (my $c = $roster->get_contact ($jid)) { return $acc; } } $any_acc } =head2 get_contacts_for_jid ($jid) This method returns all contacts that we are connected to. That means: It joins the contact lists of all account's rosters that we are connected to. =cut sub get_contacts_for_jid { my ($self, $jid) = @_; my @cons; for ($self->get_connected_accounts) { my $roster = $_->connection ()->get_roster (); my $con = $roster->get_contact ($jid); push @cons, $con if $con; } return @cons; } =head2 get_priority_presence_for_jid ($jid) This method returns the presence for the contact C<$jid> with the highest priority. If the contact C<$jid> is on multiple account's rosters it's undefined which roster the presence belongs to. =cut sub get_priority_presence_for_jid { my ($self, $jid) = @_; my $lpres; for ($self->get_connected_accounts) { my $roster = $_->connection ()->get_roster (); my $con = $roster->get_contact ($jid); next unless defined $con; my $pres = $con->get_priority_presence ($jid); next unless defined $pres; if ((not defined $lpres) || $lpres->priority < $pres->priority) { $lpres = $pres; } } $lpres } =head2 set_presence ($show, $status, $priority) This sets the presence of all accounts. For a meaning of C<$show>, C<$status> and C<$priority> see the description of the C<%attrs> hash in C method of L. =cut sub set_presence { my ($self, $show, $status, $priority) = @_; $self->{presence} = { show => $show, status => $status, priority => $priority }; for my $ac ($self->get_connected_accounts) { my $con = $ac->connection (); $con->send_presence (undef, undef, %{$self->{presence}}); } } =head1 EVENTS In the following event descriptions the argument C<$account> is always a L object. All events from L are forwarded to the client, only that the first argument for every event is a C<$account> object. Aside fom those, these events can be registered on with C: =over 4 =item connected => $account This event is sent when the C<$account> was successfully connected. =item connect_error => $account, $reason This event is emitted when an error occured in the connection process for the account C<$account>. =item error => $account, $error This event is emitted when any error occured while communicating over the connection to the C<$account> - after a connection was established. C<$error> is an error object which is derived from L. It will reveal human readable information about the error by calling the C method (which returns a descriptive error string about the nature of the error). =item added_account => $account Called whenever an account is added. =item removed_account => $account Called whenever an account is removed. =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP::Client AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Writer.pm0000644000175000000620000005404712035246171020147 0ustar michaelstaffpackage AnyEvent::XMPP::Writer; use strict; use XML::Writer; use Authen::SASL qw/Perl/; use MIME::Base64; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/simxml filter_xml_chars filter_xml_attr_hash_chars/; use Digest::SHA qw/sha1_hex/; use Encode; =head1 NAME AnyEvent::XMPP::Writer - "XML" writer for XMPP =head1 SYNOPSIS use AnyEvent::XMPP::Writer; ... =head1 DESCRIPTION This module contains some helper functions for writing XMPP "XML", which is not real XML at all ;-( I use L and tune it until it creates "XML" that is accepted by most servers propably (all of the XMPP servers I tested should work (jabberd14, jabberd2, ejabberd, googletalk). I hope the semantics of L don't change much in the future, but if they do and you run into problems, please report them! The whole "XML" concept of XMPP is fundamentally broken anyway. It's supposed to be an subset of XML. But a subset of XML productions is not XML. Strictly speaking you need a special XMPP "XML" parser and writer to be 100% conformant. On top of that XMPP B you to parse these partial "XML" documents. But a partial XML document is not well-formed, heck, it's not even a XML document! And a parser should bail out with an error. But XMPP doesn't care, it just relies on implementation dependend behaviour of chunked parsing modes for SAX parsing. This functionality isn't even specified by the XML recommendation in any way. The recommendation even says that it's undefined what happens if you process not-well-formed XML documents. But I try to be as XMPP "XML" conformant as possible (it should be around 99-100%). But it's hard to say what XML is conformant, as the specifications of XMPP "XML" and XML are contradicting. For example XMPP also says you only have to generated and accept UTF-8 encodings of XML, but the XML recommendation says that each parser has to accept UTF-8 B UTF-16. So, what do you do? Do you use a XML conformant parser or do you write your own? I'm using XML::Parser::Expat because expat knows how to parse broken (aka 'partial') "XML" documents, as XMPP requires. Another argument is that if you capture a XMPP conversation to the end, and even if a '' tag was captured, you wont have a valid XML document. The problem is that you have to resent a tag after TLS and SASL authentication each! Awww... I'm repeating myself. But well... AnyEvent::XMPP does it's best with expat to cope with the fundamental brokeness of "XML" in XMPP. Back to the issue with "XML" generation: I've discoverd that many XMPP servers (eg. jabberd14 and ejabberd) have problems with XML namespaces. Thats the reason why I'm assigning the namespace prefixes manually: The servers just don't accept validly namespaced XML. The draft 3921bis does even state that a client SHOULD generate a 'stream' prefix for the tag. I advice you to explicitly set the namespaces too if you generate "XML" for XMPP yourself, at least until all or most of the XMPP servers have been fixed. Which might take some years :-) And maybe will happen never. And another note: As XMPP requires all predefined entity characters to be escaped in character data you need a "XML" writer that will escape everything: RFC 3920 - 11.1. Restrictions: character data or attribute values containing unescaped characters that map to the predefined entities (Section 4.6 therein); such characters MUST be escaped This means: You have to escape '>' in the character data. I don't know whether XML::Writer does that. And I honestly don't care much about this. XMPP is broken by design and I have barely time to writer my own XML parsers and writers to suit their sick taste of "XML". (Do I repeat myself?) I would be happy if they finally say (in RFC3920): "XMPP is NOT XML. It's just XML-like, and some XML utilities allow you to process this kind of XML.". =head1 METHODS =over 4 =item B This methods takes following arguments: =over 4 =item write_cb The callback that is called when a XML stanza was completely written and is ready for transfer. The first argument of the callback will be the character data to send to the socket. =back And calls C. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = { write_cb => sub {}, send_iq_cb => sub {}, send_msg_cb => sub {}, send_pres_cb => sub {}, @_ }; bless $self, $class; $self->init; return $self; } =item B (Re)initializes the writer. =cut sub init { my ($self) = @_; $self->{write_buf} = ""; $self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1, UNSAFE => 1); } =item B This method flushes the internal write buffer and will invoke the C callback. (see also C above) =cut sub flush { my ($self) = @_; $self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), ''); } =item B This method will generate a XMPP stream header. C<$domain> has to be the domain of the server (or endpoint) we want to connect to. C<$namespace> is the namespace URI or the tag (from L) for the stream namespace. (This is used by L to connect as component to a server). C<$namespace> can also be undefined, in this case the C namespace will be used. =cut sub send_init_stream { my ($self, $language, $domain, $ns, $vers_override) = @_; $ns ||= 'client'; my $w = $self->{writer}; $w->xmlDecl (); $w->addPrefix (xmpp_ns ('stream'), 'stream'); $w->addPrefix (xmpp_ns ($ns), ''); $w->forceNSDecl (xmpp_ns ($ns)); $w->startTag ( [xmpp_ns ('stream'), 'stream'], to => $domain, version => (defined $vers_override ? $vers_override : '1.0'), [xmpp_ns ('xml'), 'lang'] => $language ); $self->flush; } =item B This method sends a single space to the server. =cut sub send_whitespace_ping { my ($self) = @_; $self->{writer}->raw (' '); $self->flush; } =item B This method sends a component handshake. Please note that C<$secret> must be XML escaped! =cut sub send_handshake { my ($self, $id, $secret) = @_; my $out_secret = encode ("UTF-8", $secret); my $out = lc sha1_hex ($id . $out_secret); simxml ($self->{writer}, defns => 'component', node => { ns => 'component', name => 'handshake', childs => [ $out ] }); $self->flush; } =item B Sends end of the stream. =cut sub send_end_of_stream { my ($self) = @_; my $w = $self->{writer}; $w->endTag ([xmpp_ns ('stream'), 'stream']); $self->flush; } =item B This methods sends the start of a SASL authentication. C<$mechanisms> is an array reference, containing the mechanism names that are to be tried. =cut sub send_sasl_auth { my ($self, $mechs, $user, $hostname, $pass) = @_; my $data; my $found_mech = 0; while (!$found_mech) { my $sasl = Authen::SASL->new ( mechanism => join (' ', @$mechs), callback => { # XXX: removed authname, because it ensures maximum connectivitiy # along multiple server implementations - XMPP is such a crap # authname => $user . '@' . $domain, user => $user, pass => $pass, } ); my $mech = $sasl->client_new ('xmpp', $hostname); $data = $mech->client_start; if (my $e = $mech->error) { @$mechs = grep { $_ ne $mech->mechanism } @$mechs; die "No usable SASL mechanism found (tried: " . join (', ', @$mechs) . ")!\n" unless @$mechs; next; } $found_mech = 1; $self->{sasl} = $mech; } my $w = $self->{writer}; $w->addPrefix (xmpp_ns ('sasl'), ''); $w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism); $w->characters (MIME::Base64::encode_base64 ($data, '')); $w->endTag; $self->flush; } =item B This method generated the SASL authentication response to a C<$challenge>. You must not call this method without calling C before. =cut sub send_sasl_response { my ($self, $challenge) = @_; $challenge = MIME::Base64::decode_base64 ($challenge); my $ret = ''; unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done $ret = $self->{sasl}->client_step ($challenge); if (my $e = $self->{sasl}->error) { die "Error in SASL authentication in client step with challenge: '" . $e . "'\n"; } } my $w = $self->{writer}; $w->addPrefix (xmpp_ns ('sasl'), ''); $w->startTag ([xmpp_ns ('sasl'), 'response']); $w->characters (MIME::Base64::encode_base64 ($ret, '')); $w->endTag; $self->flush; } =item B Sends the starttls command to the server. =cut sub send_starttls { my ($self) = @_; my $w = $self->{writer}; $w->addPrefix (xmpp_ns ('tls'), ''); $w->emptyTag ([xmpp_ns ('tls'), 'starttls']); $self->flush; } =item B This method sends an IQ stanza of type C<$type> (to be compliant only use: 'get', 'set', 'result' and 'error'). If C<$create_cb> is a code reference it will be called with an XML::Writer instance as first argument, which must be used to fill the IQ stanza. The XML::Writer is in UNSAFE mode, so you can safely use C to write out XML. C<$create_cb> is a hash reference the hash will be used as key=>value arguments for the C function defined in L. C will then be used to generate the contents of the IQ stanza. (This is very convenient when you want to write the contents of stanzas in the code and don't want to build a DOM tree yourself...). If C<$create_cb> is an array reference it's elements will be interpreted as single C<$create_cb> argument (which can either be a hash reference or code reference themself) and executed sequentially. If C<$create_cb> is undefined an empty tag will be generated. Example: $writer->send_iq ('newid', 'get', { defns => 'version', node => { name => 'query', ns => 'version' } }, to => 'jabber.org') C<%attrs> should have further attributes for the IQ stanza tag. For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute it will be put into the 'xml' namespace. If the 'to' attribute contains an undef it will be omitted. C<$id> is the id to give this IQ stanza and is mandatory in this API. Please note that all attribute values and character data will be filtered by C (see also L). =cut sub send_iq { my ($self, $id, $type, $create_cb, %attrs) = @_; $create_cb = _trans_create_cb ($create_cb); $create_cb = $self->_fetch_cb_additions (send_iq_cb => $create_cb, $id, $type, \%attrs); my (@from) = ($self->{jid} ? (from => $self->{jid}) : ()); if ($attrs{lang}) { push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng}) } unless (defined $attrs{to}) { delete $attrs{to}; } push @from, (id => filter_xml_chars $id) if defined $id; filter_xml_attr_hash_chars \%attrs; my $w = $self->{writer}; $w->addPrefix (xmpp_ns ('client'), ''); if (defined $create_cb) { $w->startTag ([xmpp_ns ('client'), 'iq'], type => $type, @from, %attrs); $create_cb->($w); $w->endTag; } else { $w->emptyTag ([xmpp_ns ('client'), 'iq'], type => $type, @from, %attrs); } $self->flush; } =item B Sends a presence stanza. C<$create_cb> has the same meaning as for C. C<%attrs> will let you pass further optional arguments like 'to'. C<$type> is the type of the presence, which may be one of: unavailable, subscribe, subscribed, unsubscribe, unsubscribed, probe, error Or undef, in case you want to send a 'normal' presence. Or something completely different if you don't like the RFC 3921 :-) C<%attrs> contains further attributes for the presence tag or may contain one of the following exceptional keys: If C<%attrs> contains a 'show' key: a child xml tag with that name will be generated with the value as the content, which should be one of 'away', 'chat', 'dnd' and 'xa'. If it contains an undefined value no such tag will be generated, which usually means that the 'available' presence is meant. If C<%attrs> contains a 'status' key: a child xml tag with that name will be generated with the value as content. If the value of the 'status' key is an hash reference the keys will be interpreted as language identifiers for the xml:lang attribute of each status element. If one of these keys is the empty string '' no xml:lang attribute will be generated for it. The values will be the character content of the status tags. If C<%attrs> contains a 'priority' key: a child xml tag with that name will be generated with the value as content, which must be a number between -128 and +127. Note: If C<$create_cb> is undefined and one of the above attributes (show, status or priority) were given, the generates presence tag won't be empty. Please note that all attribute values and character data will be filtered by C (see also L). =cut sub _generate_key_xml { my ($w, $key, $value) = @_; $w->startTag ($key); $w->characters (filter_xml_chars $value); $w->endTag; } sub _generate_key_xmls { my ($w, $key, $value) = @_; if (ref ($value) eq 'HASH') { for (keys %$value) { $w->startTag ($key, ($_ ne '' ? ([xmpp_ns ('xml'), 'lang'] => $_) : ())); $w->characters (filter_xml_chars $value->{$_}); $w->endTag; } } else { $w->startTag ($key); $w->characters (filter_xml_chars $value); $w->endTag; } } sub _trans_create_cb { my ($cb) = @_; return unless defined $cb; if (ref ($cb) eq 'HASH') { my $args = $cb; $cb = sub { my ($w) = @_; simxml ($w, %$args); } } elsif (ref ($cb) eq 'ARRAY') { my @cbs = map { _trans_create_cb ($_) } @$cb; $cb = sub { my ($w) = @_; for (@cbs) { $_->($w) } } } $cb } sub _fetch_cb_additions { my ($self, $key, $create_cb, @args) = @_; my (@add_cbs) = $self->{$key}->(@args); @add_cbs = map { _trans_create_cb ($_) } @add_cbs; if (@add_cbs) { my $crcb = $create_cb; $create_cb = sub { my (@args) = @_; $crcb->(@args) if $crcb; for (@add_cbs) { $_->(@args) } } } $create_cb } sub send_presence { my ($self, $id, $type, $create_cb, %attrs) = @_; $create_cb = _trans_create_cb ($create_cb); $create_cb = $self->_fetch_cb_additions (send_pres_cb => $create_cb, $id, $type, \%attrs); my $w = $self->{writer}; $w->addPrefix (xmpp_ns ('client'), ''); my @add; push @add, (type => $type) if defined $type; push @add, (id => $id) if defined $id; my %fattrs = map { $_ => $attrs{$_} } grep { my $k = $_; not grep { $k eq $_ } qw/show priority status/ } keys %attrs; filter_xml_attr_hash_chars \%fattrs; if (defined $create_cb) { $w->startTag ([xmpp_ns ('client'), 'presence'], @add, %fattrs); _generate_key_xml ($w, show => $attrs{show}) if defined $attrs{show}; _generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority}; _generate_key_xmls ($w, status => $attrs{status}) if defined $attrs{status}; $create_cb->($w); $w->endTag; } else { if (exists $attrs{show} or $attrs{priority} or $attrs{status}) { $w->startTag ([xmpp_ns ('client'), 'presence'], @add, %fattrs); _generate_key_xml ($w, show => $attrs{show}) if defined $attrs{show}; _generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority}; _generate_key_xmls ($w, status => $attrs{status}) if defined $attrs{status}; $w->endTag; } else { $w->emptyTag ([xmpp_ns ('client'), 'presence'], @add, %fattrs); } } $self->flush; } =item B Sends a message stanza. C<$to> is the destination JID of the message. C<$type> is the type of the message, and if C<$type> is undefined it will default to 'chat'. C<$type> must be one of the following: 'chat', 'error', 'groupchat', 'headline' or 'normal'. C<$create_cb> has the same meaning as in C. C<%attrs> contains further attributes for the message tag or may contain one of the following exceptional keys: If C<%attrs> contains a 'body' key: a child xml tag with that name will be generated with the value as content. If the value of the 'body' key is an hash reference the keys will be interpreted as language identifiers for the xml:lang attribute of each body element. If one of these keys is the empty string '' no xml:lang attribute will be generated for it. The values will be the character content of the body tags. If C<%attrs> contains a 'subject' key: a child xml tag with that name will be generated with the value as content. If the value of the 'subject' key is an hash reference the keys will be interpreted as language identifiers for the xml:lang attribute of each subject element. If one of these keys is the empty string '' no xml:lang attribute will be generated for it. The values will be the character content of the subject tags. If C<%attrs> contains a 'thread' key: a child xml tag with that name will be generated and the value will be the character content. Please note that all attribute values and character data will be filtered by C (see also L). =cut sub send_message { my ($self, $id, $to, $type, $create_cb, %attrs) = @_; $create_cb = _trans_create_cb ($create_cb); $create_cb = $self->_fetch_cb_additions (send_msg_cb => $create_cb, $id, $to, $type, \%attrs); my $w = $self->{writer}; $w->addPrefix (xmpp_ns ('client'), ''); my @add; push @add, (id => $id) if defined $id; $type ||= 'chat'; my %fattrs = map { $_ => $attrs{$_} } grep { my $k = $_; not grep { $k eq $_ } qw/subject body thread/ } keys %attrs; if (defined $create_cb) { $w->startTag ([xmpp_ns ('client'), 'message'], @add, to => $to, type => $type, %fattrs); _generate_key_xmls ($w, subject => $attrs{subject}) if defined $attrs{subject}; _generate_key_xmls ($w, body => $attrs{body}) if defined $attrs{body}; _generate_key_xml ($w, thread => $attrs{thread}) if defined $attrs{thread}; $create_cb->($w); $w->endTag; } else { if (exists $attrs{subject} or $attrs{body} or $attrs{thread}) { $w->startTag ([xmpp_ns ('client'), 'message'], @add, to => $to, type => $type, %fattrs); _generate_key_xmls ($w, subject => $attrs{subject}) if defined $attrs{subject}; _generate_key_xmls ($w, body => $attrs{body}) if defined $attrs{body}; _generate_key_xml ($w, thread => $attrs{thread}) if defined $attrs{thread}; $w->endTag; } else { $w->emptyTag ([xmpp_ns ('client'), 'message'], @add, to => $to, type => $type, %fattrs); } } $self->flush; } =item B C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'. C<$error> is the name of the error tag child element. If C<$error> is one of the following: 'bad-request', 'conflict', 'feature-not-implemented', 'forbidden', 'gone', 'internal-server-error', 'item-not-found', 'jid-malformed', 'not-acceptable', 'not-allowed', 'not-authorized', 'payment-required', 'recipient-unavailable', 'redirect', 'registration-required', 'remote-server-not-found', 'remote-server-timeout', 'resource-constraint', 'service-unavailable', 'subscription-required', 'undefined-condition', 'unexpected-request' then a default can be select for C<$error_type>, and the argument can be undefined. Note: This method is currently a bit limited in the generation of the xml for the errors, if you need more please contact me. =cut our %STANZA_ERRORS = ( 'bad-request' => ['modify', 400], 'conflict' => ['cancel', 409], 'feature-not-implemented' => ['cancel', 501], 'forbidden' => ['auth', 403], 'gone' => ['modify', 302], 'internal-server-error' => ['wait', 500], 'item-not-found' => ['cancel', 404], 'jid-malformed' => ['modify', 400], 'not-acceptable' => ['modify', 406], 'not-allowed' => ['cancel', 405], 'not-authorized' => ['auth', 401], 'payment-required' => ['auth', 402], 'recipient-unavailable' => ['wait', 404], 'redirect' => ['modify', 302], 'registration-required' => ['auth', 407], 'remote-server-not-found' => ['cancel', 404], 'remote-server-timeout' => ['wait', 504], 'resource-constraint' => ['wait', 500], 'service-unavailable' => ['cancel', 503], 'subscription-required' => ['auth', 407], 'undefined-condition' => ['cancel', 500], 'unexpected-request' => ['wait', 400], ); sub write_error_tag { my ($self, $errstanza, $type, $error) = @_; my $w = $self->{writer}; $_->write_on ($w) for $errstanza->nodes; my @add; unless (defined $type and defined $STANZA_ERRORS{$error}) { $type = $STANZA_ERRORS{$error}->[0]; } push @add, (code => $STANZA_ERRORS{$error}->[1]); my %add = @add; filter_xml_attr_hash_chars \%add; $w->addPrefix (xmpp_ns ('client'), ''); $w->startTag ([xmpp_ns ('client') => 'error'], type => $type, %add); $w->addPrefix (xmpp_ns ('stanzas'), ''); $w->emptyTag ([xmpp_ns ('stanzas') => filter_xml_chars $error]); $w->endTag; } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.54/lib/AnyEvent/XMPP/Util.pm0000644000175000000620000003336112035245233017602 0ustar michaelstaffpackage 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/; use Time::Local; 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/; =head1 NAME AnyEvent::XMPP::Util - Utility functions for AnyEvent::XMPP =head1 SYNOPSIS use AnyEvent::XMPP::Util qw/split_jid/; ... =head1 FUNCTIONS These functions can be exported if you want: =over 4 =item B 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 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 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 This is a plain concatenation of C<$user>, C<$domain> and C<$resource> without stringprep. See also L =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 This function splits up the C<$uri> into service and node part and will return them as list. my ($service, $node) = split_uri ($uri); =cut sub split_uri { my ($uri) = @_; if ($uri =~ /^xmpp:(\S+)\?\w+;node=(\S+)$/) { return ($1, $2); } else { return (undef, $uri); } } =item B 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 eq '' ? undef : $1, $2, $3 eq '' ? undef : $3); } else { return (undef, undef, undef); } } =item B See C below. =item B See C below. =item B See C below. =item B See C below. =item B See C below. =item B These functions return the corresponding parts of a JID. The C prefixed JIDs return the stringprep'ed versions. =cut 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])) } =item B 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 This function compares two jids C<$jid1> and C<$jid2> whether they are equal. =cut sub cmp_jid { my ($jid1, $jid2) = @_; stringprep_jid ($jid1) eq stringprep_jid ($jid2) } =item B This function compares two jids C<$jid1> and C<$jid2> whether their bare part is equal. =cut sub cmp_bare_jid { my ($jid1, $jid2) = @_; cmp_jid (bare_jid ($jid1), bare_jid ($jid2)) } =item B 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 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 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); not defined $res } =item B This function removes all characters from C<$string> which are not allowed in XML and returns the new string. =cut 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 } =item B This runs all values of the C<$hashref> through C (see above) and changes them in-place! =cut sub filter_xml_attr_hash_chars { my ($hash) = @_; $hash->{$_} = filter_xml_chars $hash->{$_} for keys %$hash } =item B This function takes a L as first argument (C<$w>) and the rest key value pairs: simxml ($w, defns => '', node => , prefixes => { prefix => namespace, ... }, ); Where node is: := { ns => '', name => 'tagname', attrs => [ 'name', 'value', 'name2', 'value2', ... ], childs => [ , ... ] } | { dns => '', # this will set that namespace to # the default namespace before using it. name => 'tagname', attrs => [ 'name', 'value', 'name2', 'value2', ... ], childs => [ , ... ] } | sub { my ($w) = @_; ... } # with $w being a XML::Writer object | "textnode" Please note: C stands for C :-) Also note that if you omit the C 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 C in the node.) Please note that all attribute values and character data will be filtered by C. 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 element in the invite element 'name' => 'reason', childs => [ $reason ] } ], } ] } ); }); =cut 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); } } =item B This function transforms a time to the XMPP date time format. The meanings and value ranges of C<$sec>, ..., C<$hour> are explained in the perldoc of Perl's builtin C. C<$tz> has to be either C<"UTC"> or of the form C<[+-]hh:mm>, it can be undefined and wont occur in the time string then. C<$secfrac> are optional and can be the fractions of the second. See also XEP-0082. =cut 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 : "") } =item B This function transforms a time to the XMPP date time format. The meanings of C<$sec>, ..., C<$year> are explained in the perldoc of Perl's C builtin and have the same value ranges. C<$tz> has to be either C<"Z"> (for UTC) or of the form C<[+-]hh:mm> (offset from UTC), if it is undefined "Z" will be used. C<$secfrac> are optional and can be the fractions of the second. See also XEP-0082. =cut 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; } =item B This function transforms the C<$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 C<$sec>, ..., C<$srcfrac> please look at the documentation for C. C<$tz> and C<$secfrac> might be undefined. If C<$tz> is undefined the timezone is to be assumed to be UTC. If C<$string> contained just a time C<$mday>, C<$mon> and C<$year> will be undefined. See also XEP-0082. =cut 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)) } =item B This function takes the same arguments as C, but returns a unix timestamp, like C